[climacs-cvs] CVS climacs

[dmurray]

Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv28753

Modified Files:
	file-commands.lisp 
Log Message:
find-file now takes an optional readonlyp argument, meaning
find-file-read-only (which had got out of sync/date) can go.


--- /project/climacs/cvsroot/climacs/file-commands.lisp	2006/05/06 15:40:47	1.14
+++ /project/climacs/cvsroot/climacs/file-commands.lisp	2006/05/07 20:11:20	1.15
@@ -228,7 +228,7 @@
     (and (or (null name) (eql name :unspecific))
 	 (or (null type) (eql type :unspecific)))))
 
-(defun find-file (filepath)
+(defun find-file (filepath &optional readonlyp)
   (cond ((null filepath)
 	 (display-message "No file name given.")
 	 (beep))
@@ -238,38 +238,45 @@
 	(t
 	 (let ((existing-buffer (find filepath (buffers *application-frame*)
 			       :key #'filepath :test #'equal)))
-	   (if existing-buffer
+	   (if (and existing-buffer (if readonlyp (read-only-p existing-buffer) t))
 	       (switch-to-buffer existing-buffer)
-	       (let ((buffer (make-buffer))
-		     (pane (current-window)))
-                 ;; Clear the pane's cache; otherwise residue from the
-                 ;; previously displayed buffer may under certain
-                 ;; circumstances be displayed.
-                 (clear-cache pane)
-                 (setf (syntax buffer) nil)
-		 (setf (offset (point (buffer pane))) (offset (point pane)))
-		 (setf (buffer (current-window)) buffer)
-		 ;; Don't want to create the file if it doesn't exist.
-		 (when (probe-file filepath)
-		   (with-open-file (stream filepath :direction :input)
-		     (input-from-stream stream buffer 0))
-		   (setf (file-write-time buffer) (file-write-date filepath))
-                   ;; A file! That means we may have a local options
-                   ;; line to parse.
-                   (evaluate-attributes-line buffer))
-                 ;; If the local options line didn't set a syntax, do
-                 ;; it now.
-                 (when (null (syntax buffer))
-                   (setf (syntax buffer)
-                         (make-instance (syntax-class-name-for-filepath filepath)
-                                        :buffer buffer)))
-		 (setf (filepath buffer) filepath
-		       (name buffer) (filepath-filename filepath)
-		       (needs-saving buffer) nil)
-		 (beginning-of-buffer (point pane))
-                 (update-syntax buffer (syntax buffer))
-                 (clear-modify buffer)
-		 buffer))))))
+	       (progn
+		 (when readonlyp
+		   (unless (probe-file filepath)
+		     (beep)
+		     (display-message "No such file: ~A" filepath)
+		     (return-from find-file nil)))
+		 (let ((buffer (make-buffer))
+		       (pane (current-window)))
+		   ;; Clear the pane's cache; otherwise residue from the
+		   ;; previously displayed buffer may under certain
+		   ;; circumstances be displayed.
+		   (clear-cache pane)
+		   (setf (syntax buffer) nil)
+		   (setf (offset (point (buffer pane))) (offset (point pane)))
+		   (setf (buffer (current-window)) buffer)
+		   ;; Don't want to create the file if it doesn't exist.
+		   (when (probe-file filepath)
+		     (with-open-file (stream filepath :direction :input)
+		       (input-from-stream stream buffer 0))
+		     (setf (file-write-time buffer) (file-write-date filepath))
+		     ;; A file! That means we may have a local options
+		     ;; line to parse.
+		     (evaluate-attributes-line buffer))
+		   ;; If the local options line didn't set a syntax, do
+		   ;; it now.
+		   (when (null (syntax buffer))
+		     (setf (syntax buffer)
+			   (make-instance (syntax-class-name-for-filepath filepath)
+			      :buffer buffer)))
+		   (setf (filepath buffer) filepath
+			 (name buffer) (filepath-filename filepath)
+			 (needs-saving buffer) nil
+			 (read-only-p buffer) readonlyp)
+		   (beginning-of-buffer (point pane))
+		   (update-syntax buffer (syntax buffer))
+		   (clear-modify buffer)
+		   buffer)))))))
 
 (defun directory-of-buffer (buffer)
   "Extract the directory part of the filepath to the file in BUFFER.
@@ -294,42 +301,6 @@
 	 'buffer-table
 	 '((#\x :control) (#\f :control)))
 
-(defun find-file-read-only (filepath)
-  (cond ((null filepath)
-	 (display-message "No file name given.")
-	 (beep))
-	((directory-pathname-p filepath)
-	 (display-message "~A is a directory name." filepath)
-	 (beep))
-	(t
-	 (let ((existing-buffer (find filepath (buffers *application-frame*)
-				      :key #'filepath :test #'equal)))
-	   (if (and existing-buffer (read-only-p existing-buffer))
-	       (switch-to-buffer existing-buffer)
-	       (if (probe-file filepath)
-		   (let ((buffer (make-buffer))
-			 (pane (current-window)))
-		     (setf (offset (point (buffer pane))) (offset (point pane)))
-		     (setf (buffer (current-window)) buffer)
-		     (setf (syntax buffer)
-			   (make-instance (syntax-class-name-for-filepath filepath)
-			      :buffer (buffer (point pane))))
-		     (with-open-file (stream filepath :direction :input)
-		       (input-from-stream stream buffer 0))
-		     (setf (filepath buffer) filepath
-			   (name buffer) (filepath-filename filepath)
-			   (needs-saving buffer) nil
-			   (read-only-p buffer) t)
-		     (beginning-of-buffer (point pane))
-		     ;; this one is needed so that the buffer modification protocol
-		     ;; resets the low and high marks after redisplay
-		     (redisplay-frame-panes *application-frame*)
-		     buffer)
-		   (progn
-		     (display-message "No such file: ~A" filepath)
-		     (beep)
-		     nil)))))))
-
 (define-command (com-find-file-read-only :name t :command-table buffer-table) ()
   "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."
@@ -337,7 +308,7 @@
 			  :default (directory-of-buffer (buffer (current-window)))
 			  :default-type 'pathname
 			  :insert-default t)))
-    (find-file-read-only filepath)))
+    (find-file filepath t)))
 
 (set-key 'com-find-file-read-only
 	 'buffer-table