/[cmucl]/src/hemlock/bufed.lisp
ViewVC logotype

Contents of /src/hemlock/bufed.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Wed May 9 13:03:09 1990 UTC (23 years, 11 months ago) by ram
Branch: MAIN
Initial revision
1 ;;; -*- Log: hemlock.log; Package: Hemlock -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the Spice Lisp project at
5 ;;; Carnegie-Mellon University, and has been placed in the public domain.
6 ;;; Spice Lisp is currently incomplete and under active development.
7 ;;; If you want to use this code or any part of Spice Lisp, please contact
8 ;;; Scott Fahlman (FAHLMAN@CMUC).
9 ;;; **********************************************************************
10 ;;;
11 ;;; This file contains Bufed (Buffer Editing) code.
12 ;;;
13
14 (in-package "HEMLOCK")
15
16
17
18 ;;;; Representation of existing buffers.
19
20 ;;; This is the array of buffers in the bufed buffer. Each element is a cons,
21 ;;; where the CAR is the buffer, and the CDR indicates whether the buffer
22 ;;; should be deleted (t deleted, nil don't).
23 ;;;
24 (defvar *bufed-buffers* nil)
25 (defvar *bufed-buffers-end* nil)
26 ;;;
27 (defmacro bufed-buffer (x) `(car ,x))
28 (defmacro bufed-buffer-deleted (x) `(cdr ,x))
29 (defmacro make-bufed-buffer (buffer) `(list ,buffer))
30
31
32 ;;; This is the bufed buffer if it exists.
33 ;;;
34 (defvar *bufed-buffer* nil)
35
36 ;;; This is the cleanup method for deleting *bufed-buffer*.
37 ;;;
38 (defun delete-bufed-buffers (buffer)
39 (when (eq buffer *bufed-buffer*)
40 (setf *bufed-buffer* nil)
41 (setf *bufed-buffers* nil)))
42
43
44
45 ;;;; Commands.
46
47 (defmode "Bufed" :major-p t
48 :documentation
49 "Bufed allows the user to quickly save, goto, delete, etc., his buffers.")
50
51 (defhvar "Virtual Buffer Deletion"
52 "When set, \"Bufed Delete\" marks a buffer for deletion instead of immediately
53 deleting it."
54 :value t)
55
56 (defhvar "Bufed Delete Confirm"
57 "When set, \"Bufed\" commands that actually delete buffers ask for
58 confirmation before taking action."
59 :value t)
60
61 (defcommand "Bufed Delete" (p)
62 "Delete the buffer.
63 Any windows displaying this buffer will display some other buffer."
64 "Delete the buffer indicated by the current line. Any windows displaying this
65 buffer will display some other buffer."
66 (declare (ignore p))
67 (let* ((point (current-point))
68 (buf-info (array-element-from-mark point *bufed-buffers*)))
69 (if (and (not (value virtual-buffer-deletion))
70 (or (not (value bufed-delete-confirm))
71 (prompt-for-y-or-n :prompt "Delete buffer? " :default t
72 :must-exist t :default-string "Y")))
73 (delete-bufed-buffer (bufed-buffer buf-info))
74 (with-writable-buffer (*bufed-buffer*)
75 (setf (bufed-buffer-deleted buf-info) t)
76 (with-mark ((point point))
77 (setf (next-character (line-start point)) #\D))))))
78
79 (defcommand "Bufed Undelete" (p)
80 "Undelete the buffer.
81 Any windows displaying this buffer will display some other buffer."
82 "Undelete the buffer. Any windows displaying this buffer will display some
83 other buffer."
84 (declare (ignore p))
85 (with-writable-buffer (*bufed-buffer*)
86 (setf (bufed-buffer-deleted (array-element-from-mark
87 (current-point) *bufed-buffers*))
88 nil)
89 (with-mark ((point (current-point)))
90 (setf (next-character (line-start point)) #\space))))
91
92 (defcommand "Bufed Expunge" (p)
93 "Expunge buffers marked for deletion."
94 "Expunge buffers marked for deletion."
95 (declare (ignore p))
96 (expunge-bufed-buffers))
97
98 (defcommand "Bufed Quit" (p)
99 "Kill the bufed buffer, expunging any buffer marked for deletion."
100 "Kill the bufed buffer, expunging any buffer marked for deletion."
101 (declare (ignore p))
102 (expunge-bufed-buffers)
103 (when *bufed-buffer* (delete-buffer-if-possible *bufed-buffer*)))
104
105 ;;; EXPUNGE-BUFED-BUFFERS deletes the marked buffers in the bufed buffer,
106 ;;; signalling an error if the current buffer is not the bufed buffer. This
107 ;;; returns t if it deletes some buffer, otherwise nil. We build a list of
108 ;;; buffers before deleting any because the BUFED-DELETE-HOOK moves elements
109 ;;; around in *bufed-buffers*.
110 ;;;
111 (defun expunge-bufed-buffers ()
112 (unless (eq *bufed-buffer* (current-buffer))
113 (editor-error "Not in the Bufed buffer."))
114 (let (buffers)
115 (dotimes (i *bufed-buffers-end*)
116 (let ((buf-info (svref *bufed-buffers* i)))
117 (when (bufed-buffer-deleted buf-info)
118 (push (bufed-buffer buf-info) buffers))))
119 (if (and buffers
120 (or (not (value bufed-delete-confirm))
121 (prompt-for-y-or-n :prompt "Delete buffers? " :default t
122 :must-exist t :default-string "Y")))
123 (dolist (b buffers t) (delete-bufed-buffer b)))))
124
125 (defun delete-bufed-buffer (buf)
126 (when (and (buffer-modified buf)
127 (prompt-for-y-or-n :prompt (list "~A is modified. Save it first? "
128 (buffer-name buf))))
129 (save-file-command nil buf))
130 (delete-buffer-if-possible buf))
131
132
133 (defcommand "Bufed Goto" (p)
134 "Change to the buffer."
135 "Change to the buffer."
136 (declare (ignore p))
137 (change-to-buffer
138 (bufed-buffer (array-element-from-mark (current-point) *bufed-buffers*))))
139
140 (defcommand "Bufed Goto and Quit" (p)
141 "Change to the buffer quitting Bufed.
142 This supplies a function for \"Generic Pointer Up\" which is a no-op."
143 "Change to the buffer quitting Bufed."
144 (declare (ignore p))
145 (expunge-bufed-buffers)
146 (point-to-here-command nil)
147 (change-to-buffer
148 (bufed-buffer (array-element-from-pointer-pos *bufed-buffers*
149 "No buffer on that line.")))
150 (when *bufed-buffer* (delete-buffer-if-possible *bufed-buffer*))
151 (supply-generic-pointer-up-function #'(lambda () nil)))
152
153 (defcommand "Bufed Save File" (p)
154 "Save the buffer."
155 "Save the buffer."
156 (declare (ignore p))
157 (save-file-command
158 nil
159 (bufed-buffer (array-element-from-mark (current-point) *bufed-buffers*))))
160
161 (defcommand "Bufed" (p)
162 "Creates a list of buffers in a buffer supporting operations such as deletion
163 and selection. If there already is a bufed buffer, just go to it."
164 "Creates a list of buffers in a buffer supporting operations such as deletion
165 and selection. If there already is a bufed buffer, just go to it."
166 (declare (ignore p))
167 (let ((buf (or *bufed-buffer*
168 (make-buffer "Bufed" :modes '("Bufed")
169 :delete-hook (list #'delete-bufed-buffers)))))
170
171 (unless *bufed-buffer*
172 (setf *bufed-buffer* buf)
173 (setf *bufed-buffers-end*
174 ;; -1 echo, -1 bufed.
175 (- (length (the list *buffer-list*)) 2))
176 (setf *bufed-buffers* (make-array *bufed-buffers-end*))
177 (setf (buffer-writable buf) t)
178 (with-output-to-mark (s (buffer-point buf))
179 (let ((i 0))
180 (do-strings (n b *buffer-names*)
181 (declare (simple-string n))
182 (unless (or (eq b *echo-area-buffer*)
183 (eq b buf))
184 (bufed-write-line b n s)
185 (setf (svref *bufed-buffers* i) (make-bufed-buffer b))
186 (incf i)))))
187 (setf (buffer-writable buf) nil)
188 (setf (buffer-modified buf) nil)
189 (let ((fields (buffer-modeline-fields *bufed-buffer*)))
190 (setf (cdr (last fields))
191 (list (or (modeline-field :bufed-cmds)
192 (make-modeline-field
193 :name :bufed-cmds :width 18
194 :function
195 #'(lambda (buffer window)
196 (declare (ignore buffer window))
197 " Type ? for help.")))))
198 (setf (buffer-modeline-fields *bufed-buffer*) fields))
199 (buffer-start (buffer-point buf)))
200 (change-to-buffer buf)))
201
202 (defun bufed-write-line (buffer name s
203 &optional (buffer-pathname (buffer-pathname buffer)))
204 (let ((modified (buffer-modified buffer)))
205 (write-string (if modified " *" " ") s)
206 (if buffer-pathname
207 (format s "~A ~A~:[~50T~A~;~]~%"
208 (file-namestring buffer-pathname)
209 (directory-namestring buffer-pathname)
210 (string= (pathname-to-buffer-name buffer-pathname) name)
211 name)
212 (write-line name s))))
213
214
215 (defcommand "Bufed Help" (p)
216 "Show this help."
217 "Show this help."
218 (declare (ignore p))
219 (describe-mode-command nil "Bufed"))
220
221
222
223 ;;;; Maintenance hooks.
224
225 (eval-when (compile eval)
226 (defmacro with-bufed-point ((point buffer &optional pos) &rest body)
227 (let ((pos (or pos (gensym))))
228 `(when (and *bufed-buffers*
229 (not (eq *bufed-buffer* ,buffer))
230 (not (eq *echo-area-buffer* ,buffer)))
231 (let ((,pos (position ,buffer *bufed-buffers* :key #'car
232 :test #'eq :end *bufed-buffers-end*)))
233 (unless ,pos (error "Unknown Bufed buffer."))
234 (let ((,point (buffer-point *bufed-buffer*)))
235 (unless (line-offset (buffer-start ,point) ,pos 0)
236 (error "Bufed buffer not displayed?"))
237 (with-writable-buffer (*bufed-buffer*) ,@body))))))
238 ) ;eval-when
239
240
241 (defun bufed-modified-hook (buffer modified)
242 (with-bufed-point (point buffer)
243 (setf (next-character (mark-after point)) (if modified #\* #\space))))
244 ;;;
245 (add-hook buffer-modified-hook 'bufed-modified-hook)
246
247 (defun bufed-make-hook (buffer)
248 (declare (ignore buffer))
249 (when *bufed-buffer* (delete-buffer-if-possible *bufed-buffer*)))
250 ;;;
251 (add-hook make-buffer-hook 'bufed-make-hook)
252
253 (defun bufed-delete-hook (buffer)
254 (with-bufed-point (point buffer pos)
255 (with-mark ((temp point :left-inserting))
256 (line-offset temp 1)
257 (delete-region (region point temp)))
258 (let ((len-1 (1- *bufed-buffers-end*)))
259 (replace *bufed-buffers* *bufed-buffers*
260 :start1 pos :end1 len-1
261 :start2 (1+ pos) :end1 *bufed-buffers-end*)
262 (setf (svref *bufed-buffers* len-1) nil)
263 (setf *bufed-buffers-end* len-1))))
264 ;;;
265 (add-hook delete-buffer-hook 'bufed-delete-hook)
266
267 (defun bufed-name-hook (buffer name)
268 (with-bufed-point (point buffer)
269 (with-mark ((temp point :left-inserting))
270 (line-offset temp 1)
271 (delete-region (region point temp)))
272 (with-output-to-mark (s point)
273 (bufed-write-line buffer name s))))
274 ;;;
275 (add-hook buffer-name-hook 'bufed-name-hook)
276
277 (defun bufed-pathname-hook (buffer pathname)
278 (with-bufed-point (point buffer)
279 (with-mark ((temp point :left-inserting))
280 (line-offset temp 1)
281 (delete-region (region point temp)))
282 (with-output-to-mark (s point)
283 (bufed-write-line buffer (buffer-name buffer) s pathname))))
284 ;;;
285 (add-hook buffer-pathname-hook 'bufed-pathname-hook)

  ViewVC Help
Powered by ViewVC 1.1.5