[climacs-cvs] CVS update: climacs/gui.lisp
Dave Murray
dmurray at common-lisp.net
Thu Aug 18 20:44:51 UTC 2005
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv29204
Modified Files:
gui.lisp
Log Message:
Add com-set-visited-file-name, com-revert-buffer,
backups ("file.foo~") when saving existing files,
some more file/directory checks.
Also fixed some problems I introduced last time.
(erase-buffer is v. slow.)
Date: Thu Aug 18 22:44:48 2005
Author: dmurray
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.178 climacs/gui.lisp:1.179
--- climacs/gui.lisp:1.178 Wed Aug 17 01:10:29 2005
+++ climacs/gui.lisp Thu Aug 18 22:44:48 2005
@@ -622,12 +622,9 @@
(complete-input stream
#'filename-completer
:allow-any-input t)
-; (declare (ignore success))
-; (or pathname string)))
(if success
- (values pathname 'pathname)
+ (values pathname 'completable-pathname)
(values string 'string))))
-
(defun filepath-filename (pathname)
(if (null (pathname-type pathname))
@@ -653,6 +650,12 @@
(and (or (null name) (eql name :unspecific))
(or (null type) (eql type :unspecific)))))
+(defun make-buffer (&optional name)
+ (let ((buffer (make-instance 'climacs-buffer)))
+ (when name (setf (name buffer) name))
+ (push buffer (buffers *application-frame*))
+ buffer))
+
(define-named-command com-find-file ()
(let ((filepath (accept 'completable-pathname
:prompt "Find File")))
@@ -660,10 +663,9 @@
(display-message "~A is a directory name." filepath)
(beep))
(t
- (let ((buffer (make-instance 'climacs-buffer))
+ (let ((buffer (make-buffer))
(pane (current-window)))
(setf (offset (point (buffer pane))) (offset (point pane)))
- (push buffer (buffers *application-frame*))
(setf (buffer (current-window)) buffer)
(setf (syntax buffer)
(make-instance (syntax-class-name-for-filepath filepath)
@@ -680,6 +682,15 @@
;; resets the low and high marks after redisplay
(redisplay-frame-panes *application-frame*))))))
+(defun set-visited-file-name (filename buffer)
+ (setf (filepath buffer) filename
+ (name buffer) (filepath-filename filename)
+ (needs-saving buffer) t))
+
+(define-named-command com-set-visited-file-name ()
+ (let ((filename (accept 'completable-pathname :prompt "New file name")))
+ (set-visited-file-name filename (buffer (current-window)))))
+
(define-named-command com-insert-file ()
(let ((filename (accept 'completable-pathname
:prompt "Insert File"))
@@ -694,6 +705,40 @@
(offset (point pane)) (offset (mark pane))))
(redisplay-frame-panes *application-frame*)))
+(defgeneric erase-buffer (buffer))
+
+(defmethod erase-buffer ((buffer string))
+ (let ((b (find buffer (buffers *application-frame*)
+ :key #'name :test #'string=)))
+ (when b (erase-buffer b))))
+
+(defmethod erase-buffer ((buffer climacs-buffer))
+ (let* ((point (point buffer))
+ (mark (clone-mark point)))
+ (beginning-of-buffer mark)
+ (end-of-buffer point)
+ (delete-region mark point)))
+
+(define-named-command com-revert-buffer ()
+ (let* ((pane (current-window))
+ (buffer (buffer pane))
+ (filepath (filepath buffer))
+ (save (offset (point pane))))
+ (when (accept 'boolean :prompt (format nil "Revert buffer from file ~A?"
+ (filepath buffer)))
+ (cond ((directory-pathname-p filepath)
+ (display-message "~A is a directory name." filepath)
+ (beep))
+ ((probe-file filepath)
+ (erase-buffer buffer)
+ (with-open-file (stream filepath :direction :input)
+ (input-from-stream stream buffer 0))
+ (setf (offset (point pane))
+ (min (size buffer) save)))
+ (t
+ (display-message "No file ~A" filepath)
+ (beep))))))
+
(defun save-buffer (buffer)
(let ((filepath (or (filepath buffer)
(accept 'completable-pathname
@@ -703,6 +748,11 @@
(display-message "~A is a directory." filepath)
(beep))
(t
+ (when (probe-file filepath)
+ (let ((backup-name (pathname-name filepath))
+ (backup-type (concatenate 'string (pathname-type filepath) "~")))
+ (rename-file filepath (make-pathname :name backup-name
+ :type backup-type))))
(with-open-file (stream filepath :direction :output :if-exists :supersede)
(output-to-stream stream buffer 0 (size buffer)))
(setf (filepath buffer) filepath
@@ -772,7 +822,7 @@
(pane (current-window)))
(if position
(rotatef (car buffers) (nth position buffers))
- (push buffer buffers))
+ (push buffer (buffers *application-frame*)))
(setf (offset (point (buffer pane))) (offset (point pane)))
(setf (buffer pane) buffer)
(full-redisplay pane)))
@@ -781,7 +831,7 @@
(let ((buffer (find name (buffers *application-frame*)
:key #'name :test #'string=)))
(switch-to-buffer (or buffer
- (make-instance 'climacs-buffer :name name)))))
+ (make-buffer name)))))
;;placeholder
(defmethod switch-to-buffer ((symbol (eql 'nil)))
@@ -805,8 +855,7 @@
(setf buffers (remove buffer buffers))
;; Always need one buffer.
(when (null buffers)
- (push (make-instance 'climacs-buffer :name "*scratch*")
- buffers))
+ (make-buffer "*scratch*"))
(setf (buffer (current-window)) (car buffers))))
(defmethod kill-buffer ((name string))
@@ -1224,7 +1273,7 @@
(display-message "Isearch backward: ")
(isearch-command-loop (current-window) nil))
-(define-command (com-append-char :name t :command-table isearch-climacs-table) ()
+(define-command (com-isearch-append-char :name t :command-table isearch-climacs-table) ()
(let* ((pane (current-window))
(states (isearch-states pane))
(string (concatenate 'string
@@ -1236,7 +1285,7 @@
(incf (offset mark)))
(isearch-from-mark pane mark string forwardp)))
-(define-command (com-delete-char :name t :command-table isearch-climacs-table) ()
+(define-command (com-isearch-delete-char :name t :command-table isearch-climacs-table) ()
(let* ((pane (current-window)))
(cond ((null (second (isearch-states pane)))
(display-message "Isearch: ")
@@ -1257,7 +1306,7 @@
(search-forward-p state)
(search-string state)))))))
-(define-command (com-forward :name t :command-table isearch-climacs-table) ()
+(define-command (com-isearch-search-forward :name t :command-table isearch-climacs-table) ()
(let* ((pane (current-window))
(point (point pane))
(states (isearch-states pane))
@@ -1267,7 +1316,7 @@
(mark (clone-mark point)))
(isearch-from-mark pane mark string t)))
-(define-command (com-backward :name t :command-table isearch-climacs-table) ()
+(define-command (com-isearch-search-backward :name t :command-table isearch-climacs-table) ()
(let* ((pane (current-window))
(point (point pane))
(states (isearch-states pane))
@@ -1277,7 +1326,7 @@
(mark (clone-mark point)))
(isearch-from-mark pane mark string nil)))
-(define-command (com-exit :name t :command-table isearch-climacs-table) ()
+(define-command (com-isearch-exit :name t :command-table isearch-climacs-table) ()
(setf (isearch-mode (current-window)) nil))
(defun isearch-set-key (gesture command)
@@ -1287,10 +1336,10 @@
(loop for code from (char-code #\Space) to (char-code #\~)
do (isearch-set-key (code-char code) 'com-append-char))
-(isearch-set-key '(#\Newline) 'com-exit)
-(isearch-set-key '(#\Backspace) 'com-delete-char)
-(isearch-set-key '(#\s :control) 'com-forward)
-(isearch-set-key '(#\r :control) 'com-backward)
+(isearch-set-key '(#\Newline) 'com-isearch-exit)
+(isearch-set-key '(#\Backspace) 'com-isearch-delete-char)
+(isearch-set-key '(#\s :control) 'com-isearch-search-forward)
+(isearch-set-key '(#\r :control) 'com-isearch-search-backward)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@@ -1349,7 +1398,7 @@
((setf (query-replace-mode pane) nil))))
(display-message "Replaced ~A occurrence~:P" occurrences)))
-(define-command (com-replace :name t :command-table query-replace-climacs-table) ()
+(define-command (com-query-replace-replace :name t :command-table query-replace-climacs-table) ()
(declare (special string1 string2 occurrences))
(let* ((pane (current-window))
(point (point pane))
@@ -1373,7 +1422,7 @@
string1 string2)
(setf (query-replace-mode pane) nil))))
-(define-command (com-skip :name t :command-table query-replace-climacs-table) ()
+(define-command (com-query-replace-skip :name t :command-table query-replace-climacs-table) ()
(declare (special string1 string2))
(let* ((pane (current-window))
(point (point pane)))
@@ -1382,20 +1431,20 @@
string1 string2)
(setf (query-replace-mode pane) nil))))
-(define-command (com-exit :name t :command-table query-replace-climacs-table) ()
+(define-command (com-query-replace-exit :name t :command-table query-replace-climacs-table) ()
(setf (query-replace-mode (current-window)) nil))
(defun query-replace-set-key (gesture command)
(add-command-to-command-table command 'query-replace-climacs-table
:keystroke gesture :errorp nil))
-(query-replace-set-key '(#\Newline) 'com-exit)
-(query-replace-set-key '(#\Space) 'com-replace)
-(query-replace-set-key '(#\Backspace) 'com-skip)
-(query-replace-set-key '(#\Rubout) 'com-skip)
-(query-replace-set-key '(#\q) 'com-exit)
-(query-replace-set-key '(#\y) 'com-replace)
-(query-replace-set-key '(#\n) 'com-skip)
+(query-replace-set-key '(#\Newline) 'com-query-replace-exit)
+(query-replace-set-key '(#\Space) 'com-query-replace-replace)
+(query-replace-set-key '(#\Backspace) 'com-query-replace-skip)
+(query-replace-set-key '(#\Rubout) 'com-query-replace-skip)
+(query-replace-set-key '(#\q) 'com-query-replace-exit)
+(query-replace-set-key '(#\y) 'com-query-replace-replace)
+(query-replace-set-key '(#\n) 'com-query-replace-skip)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@@ -2121,3 +2170,4 @@
:keystroke gesture :errorp nil))
(c-c-set-key '(#\l :control) 'com-load-file)
+
More information about the Climacs-cvs
mailing list