[climacs-cvs] CVS esa
thenriksen
thenriksen at common-lisp.net
Sun Aug 20 10:08:23 UTC 2006
Update of /project/climacs/cvsroot/esa
In directory clnet:/tmp/cvs-serv3479
Modified Files:
packages.lisp esa-io.lisp esa-buffer.lisp
Log Message:
Expanded `esa-buffer-mixin', added docstrings to some commands and
expanded some commands to prepare for the use of ESA-IO in Climacs.
--- /project/climacs/cvsroot/esa/packages.lisp 2006/05/13 17:15:10 1.5
+++ /project/climacs/cvsroot/esa/packages.lisp 2006/08/20 10:08:23 1.6
@@ -18,7 +18,7 @@
(defpackage :esa-buffer
(:use :clim-lisp :clim :esa)
(:export #:make-buffer-from-stream #:save-buffer-to-stream
- #:filepath #:name #:needs-saving
+ #:filepath #:name #:needs-saving #:file-write-time #:file-saved-p
#:esa-buffer-mixin
#:make-new-buffer
#:read-only-p))
--- /project/climacs/cvsroot/esa/esa-io.lisp 2006/05/10 09:53:55 1.2
+++ /project/climacs/cvsroot/esa/esa-io.lisp 2006/08/20 10:08:23 1.3
@@ -158,6 +158,9 @@
buffer)))))
(defun directory-of-current-buffer ()
+ "Extract the directory part of the filepath to the file in the current buffer.
+ If the current buffer does not have a filepath, the path to
+ the user's home directory will be returned."
(make-pathname
:directory
(pathname-directory
@@ -165,9 +168,16 @@
(user-homedir-pathname)))))
(define-command (com-find-file :name t :command-table esa-io-table)
- ((filepath 'pathname :prompt "Find File: " :prompt-mode :raw
- :default (directory-of-current-buffer) :default-type 'pathname
+ ((filepath 'pathname
+ :prompt "Find File: "
+ :prompt-mode :raw
+ :default (directory-of-current-buffer)
+ :default-type 'pathname
:insert-default t))
+ "Prompt for a filename then edit that file.
+If a buffer is already visiting that file, switch to that
+buffer. Does not create a file if the filename given does not
+name an existing file."
(find-file filepath *application-frame*))
(set-key `(com-find-file ,*unsupplied-argument-marker*)
@@ -196,13 +206,26 @@
nil))))))
(define-command (com-find-file-read-only :name t :command-table esa-io-table)
- ((filepath 'pathname :prompt "Find File read-only: " :prompt-mode :raw))
+ ((filepath 'pathname
+ :prompt "Find File read-only: "
+ :prompt-mode :raw
+ :default (directory-of-current-buffer)
+ :default-type 'pathname
+ :insert-default t))
+ "Prompt for a filename then open that file readonly.
+If a buffer is already visiting that file, switch to that
+buffer. If the filename given does not name an existing file,
+signal an error."
(find-file-read-only filepath *application-frame*))
(set-key `(com-find-file-read-only ,*unsupplied-argument-marker*)
'esa-io-table '((#\x :control) (#\r :control)))
-(define-command (com-read-only :name t :command-table esa-io-table) ()
+(define-command (com-read-only :name t :command-table esa-io-table)
+ ()
+ "Toggle the readonly status of the current buffer.
+When a buffer is readonly, attempts to change the contents of the
+buffer signal an error."
(let ((buffer (current-buffer *application-frame*)))
(setf (read-only-p buffer) (not (read-only-p buffer)))))
@@ -214,11 +237,38 @@
(needs-saving buffer) t))
(define-command (com-set-visited-file-name :name t :command-table esa-io-table)
- ((filename 'pathname :prompt "New file name: " :prompt-mode :raw
- :default (directory-of-current-buffer) :insert-default t
- :default-type 'pathname))
+ ((filename 'pathname :prompt "New filename: "
+ :prompt-mode :raw
+ :default (directory-of-current-buffer)
+ :insert-default t
+ :default-type 'pathname
+ :insert-default t))
+ "Prompt for a new filename for the current buffer.
+The next time the buffer is saved it will be saved to a file with
+that filename."
(set-visited-file-name filename (current-buffer *application-frame*) *application-frame*))
+(defun extract-version-number (pathname)
+ "Extracts the emacs-style version-number from a pathname."
+ (let* ((type (pathname-type pathname))
+ (length (length type)))
+ (when (and (> length 2) (char= (char type (1- length)) #\~))
+ (let ((tilde (position #\~ type :from-end t :end (- length 2))))
+ (when tilde
+ (parse-integer type :start (1+ tilde) :junk-allowed t))))))
+
+(defun version-number (pathname)
+ "Return the number of the highest versioned backup of PATHNAME
+or 0 if there is no versioned backup. Looks for name.type~X~,
+returns highest X."
+ (let* ((wildpath (merge-pathnames (make-pathname :type :wild) pathname))
+ (possibilities (directory wildpath)))
+ (loop for possibility in possibilities
+ for version = (extract-version-number possibility)
+ if (numberp version)
+ maximize version into max
+ finally (return max))))
+
(defmethod save-buffer (buffer application-frame)
(let ((filepath (or (filepath buffer)
(accept 'pathname :prompt "Save Buffer to File"))))
@@ -229,17 +279,23 @@
(t
(when (probe-file filepath)
(let ((backup-name (pathname-name filepath))
- (backup-type (concatenate 'string (pathname-type filepath) "~")))
+ (backup-type (format nil "~A~~~D~~"
+ (pathname-type filepath)
+ (1+ (version-number filepath)))))
(rename-file filepath (make-pathname :name backup-name
:type backup-type))))
(with-open-file (stream filepath :direction :output :if-exists :supersede)
(save-buffer-to-stream buffer stream))
(setf (filepath buffer) filepath
+ (file-write-time buffer) (file-write-date filepath)
(name buffer) (filepath-filename filepath))
(display-message "Wrote: ~a" (filepath buffer))
(setf (needs-saving buffer) nil)))))
(define-command (com-save-buffer :name t :command-table esa-io-table) ()
+ "Write the contents of the buffer to a file.
+If there is filename associated with the buffer, write to that
+file, replacing its contents. If not, prompt for a filename."
(let ((buffer (current-buffer *application-frame*)))
(if (or (null (filepath buffer))
(needs-saving buffer))
@@ -264,6 +320,8 @@
((filepath 'pathname :prompt "Write Buffer to File: " :prompt-mode :raw
:default (directory-of-current-buffer) :insert-default t
:default-type 'pathname))
+ "Prompt for a filename and write the current buffer to it.
+Changes the file visted by the buffer to the given file."
(let ((buffer (current-buffer *application-frame*)))
(write-buffer buffer filepath *application-frame*)))
--- /project/climacs/cvsroot/esa/esa-buffer.lisp 2006/03/25 00:08:07 1.1.1.1
+++ /project/climacs/cvsroot/esa/esa-buffer.lisp 2006/08/20 10:08:23 1.2
@@ -31,16 +31,11 @@
(:documentation "Save the entire BUFFER to STREAM in the appropriate
external representation"))
-(defgeneric filepath (buffer))
-(defgeneric (setf filepath) (filepath buffer))
-(defgeneric name (buffer))
-(defgeneric (setf name) (name buffer))
-(defgeneric needs-saving (buffer))
-(defgeneric (setf needs-saving) (needs-saving buffer))
-
(defclass esa-buffer-mixin ()
((%filepath :initform nil :accessor filepath)
(%name :initarg :name :initform "*scratch*" :accessor name)
(%needs-saving :initform nil :accessor needs-saving)
+ (%file-write-time :initform nil :accessor file-write-time)
+ (%file-saved-p :initform nil :accessor file-saved-p)
(%read-only-p :initform nil :accessor read-only-p)))
More information about the Climacs-cvs
mailing list