[mcclim-cvs] CVS mcclim/ESA
thenriksen
thenriksen at common-lisp.net
Sun Jan 13 22:22:14 UTC 2008
Update of /project/mcclim/cvsroot/mcclim/ESA
In directory clnet:/tmp/cvs-serv8307/ESA
Modified Files:
esa-io.lisp packages.lisp
Log Message:
Added facility for ESA for controlling whether or not a buffer is "saveable".
Could be used for more than it currently is (such as integrating the
user-confirmation stuff when the file already exists).
--- /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2007/12/27 16:34:59 1.5
+++ /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2008/01/13 22:22:06 1.6
@@ -2,7 +2,7 @@
;;; (c) copyright 2006 by
;;; Robert Strandh (strandh at labri.fr)
-;;; (c) copyright 2007 by
+;;; (c) copyright 2007-2008 by
;;; Troels Henriksen (athas at sigkill.dk)
;;; This library is free software; you can redistribute it and/or
@@ -29,9 +29,45 @@
buffer having the associated file name."))
(defgeneric frame-find-file-read-only (application-frame file-path))
(defgeneric frame-set-visited-file-name (application-frame filepath buffer))
+(defgeneric check-buffer-writability (application-frame filepath buffer)
+ (:documentation "Check that `buffer' can be written to
+`filepath', which can be an arbitrary pathname. If there is a
+problem, an error that is a subclass of
+`buffer-writing-error'should be signalled."))
(defgeneric frame-save-buffer (application-frame buffer))
(defgeneric frame-write-buffer (application-frame filepath buffer))
+(define-condition buffer-writing-error (error)
+ ((%buffer :reader buffer
+ :initarg :buffer
+ :initform (error "A buffer must be provided")
+ :documentation "The buffer that was attempted written when this error occured.")
+ (%filepath :reader filepath
+ :initarg :filepath
+ :initform (error "A filepath must be provided")
+ :documentation "The filepath that the buffer was attempted to be saved to when this error occured"))
+ (:report (lambda (condition stream)
+ (format stream "~A could not be saved to ~A"
+ (name (buffer condition)) (filepath condition))))
+ (:documentation "An error that is a subclass of
+`buffer-writing-error' will be signalled when a buffer is
+attempted saved to a file, but something goes wrong. Not all
+error cases will result in the signalling of a
+`buffer-writing-error', but some defined cases will."))
+
+(define-condition filepath-is-directory (buffer-writing-error)
+ ()
+ (:report (lambda (condition stream)
+ (format stream "Cannot save buffer ~A to just a directory"
+ (name (buffer condition)))))
+ (:documentation "This error is signalled when a buffer is
+attempted saved to a directory."))
+
+(defun filepath-is-directory (buffer filepath)
+ "Signal an error of type `filepath-is-directory' with the
+buffer `buffer' and the filepath `filepath'."
+ (error 'filepath-is-directory :buffer buffer :filepath filepath))
+
(defun find-file (file-path)
(frame-find-file *application-frame* file-path))
(defun find-file-read-only (file-path)
@@ -170,6 +206,12 @@
that filename."
(set-visited-file-name filename (current-buffer)))
+(defmethod check-buffer-writability (application-frame (filepath pathname)
+ (buffer esa-buffer-mixin))
+ ;; Cannot write to a directory.
+ (when (directory-pathname-p filepath)
+ (filepath-is-directory buffer filepath)))
+
(defun extract-version-number (pathname)
"Extracts the emacs-style version-number from a pathname."
(let* ((type (pathname-type pathname))
@@ -208,27 +250,23 @@
(defmethod frame-save-buffer (application-frame buffer)
(let ((filepath (or (filepath buffer)
(accept 'pathname :prompt "Save Buffer to File"))))
- (cond
- ((directory-pathname-p filepath)
- (display-message "~A is a directory." filepath)
- (beep))
- (t
- (unless (check-file-times buffer filepath "Overwrite" "written")
- (return-from frame-save-buffer))
- (when (and (probe-file filepath) (not (file-saved-p buffer)))
- (let ((backup-name (pathname-name 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)))))
+ (check-buffer-writability application-frame filepath buffer)
+ (unless (check-file-times buffer filepath "Overwrite" "written")
+ (return-from frame-save-buffer))
+ (when (and (probe-file filepath) (not (file-saved-p buffer)))
+ (let ((backup-name (pathname-name 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.
@@ -237,22 +275,23 @@
(let ((buffer (current-buffer)))
(if (or (null (filepath buffer))
(needs-saving buffer))
- (save-buffer buffer)
+ (handler-case (save-buffer buffer)
+ (buffer-writing-error (e)
+ (with-minibuffer-stream (minibuffer)
+ (let ((*print-escape* nil))
+ (print-object e minibuffer)))))
(display-message "No changes need to be saved from ~a" (name buffer)))))
(set-key 'com-save-buffer 'esa-io-table '((#\x :control) (#\s :control)))
(defmethod frame-write-buffer (application-frame filepath buffer)
- (cond
- ((directory-pathname-p filepath)
- (display-message "~A is a directory name." filepath))
- (t
- (with-open-file (stream filepath :direction :output :if-exists :supersede)
- (save-buffer-to-stream buffer stream))
- (setf (filepath buffer) filepath
- (name buffer) (filepath-filename filepath)
- (needs-saving buffer) nil)
- (display-message "Wrote: ~a" (filepath buffer)))))
+ (check-buffer-writability application-frame filepath buffer)
+ (with-open-file (stream filepath :direction :output :if-exists :supersede)
+ (save-buffer-to-stream buffer stream))
+ (setf (filepath buffer) filepath
+ (name buffer) (filepath-filename filepath)
+ (needs-saving buffer) nil)
+ (display-message "Wrote: ~a" (filepath buffer)))
(define-command (com-write-buffer :name t :command-table esa-io-table)
((filepath 'pathname :prompt "Write Buffer to File: " :prompt-mode :raw
@@ -261,7 +300,11 @@
"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)))
- (write-buffer filepath buffer)))
+ (handler-case (write-buffer filepath buffer)
+ (buffer-writing-error (e)
+ (with-minibuffer-stream (minibuffer)
+ (let ((*print-escape* nil))
+ (print-object e minibuffer)))))))
(set-key `(com-write-buffer ,*unsupplied-argument-marker*)
'esa-io-table '((#\x :control) (#\w :control)))
--- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/01/11 02:44:14 1.11
+++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/01/13 22:22:06 1.12
@@ -2,7 +2,7 @@
;;; (c) copyright 2004-2006 by
;;; Robert Strandh (strandh at labri.fr)
-;;; (c) copyright 2006 by
+;;; (c) copyright 2006-2008 by
;;; Troels Henriksen (athas at sigkill.dk)
;;; This library is free software; you can redistribute it and/or
@@ -106,8 +106,11 @@
(:export #:frame-find-file #:find-file
#:frame-find-file-read-only #:find-file-read-only
#:frame-set-visited-file-name #:set-visited-filename
+ #:check-buffer-writability
#:frame-save-buffer #:save-buffer
#:frame-write-buffer #:write-buffer
+ #:buffer-writing-error #:buffer #:filepath
+ #:filepath-is-directory
#:esa-io-table))
#-(or mcclim building-mcclim)
More information about the Mcclim-cvs
mailing list