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

Contents of /src/hemlock/filecoms.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Fri Jul 13 15:11:57 1990 UTC (23 years, 9 months ago) by ram
Branch: MAIN
Changes since 1.1: +21 -1 lines
*** empty log message ***
1 ;;; -*- Package: Hemlock; Log: hemlock.log -*-
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 file/buffer manipulating commands.
12 ;;;
13 (in-package "HEMLOCK")
14
15
16
17 ;;;; PROCESS-FILE-OPTIONS.
18
19 (defvar *mode-option-handlers* ()
20 "Do not modify this; use Define-File-Option instead.")
21
22 (defvar *file-type-hooks* ()
23 "Do not modify this; use Define-File-Type-Hook instead.")
24
25 (defun trim-subseq (string start end)
26 (declare (simple-string string))
27 (string-trim '(#\Space #\Tab) (subseq string start end)))
28
29 ;;; PROCESS-FILE-OPTIONS checks the first line of buffer for the file options
30 ;;; indicator "-*-". IF it finds this, then it enters a do-file-options block.
31 ;;; If any parsing errors occur while picking out options, we return from this
32 ;;; block. Staying inside this function at this point, allows us to still set
33 ;;; a major mode if no file option specified one.
34 ;;;
35 ;;; We also cater to old style mode comments:
36 ;;; -*- Lisp -*-
37 ;;; -*- Text -*-
38 ;;; This kicks in if we find no colon on the file options line.
39 ;;;
40 (defun process-file-options (buffer &optional
41 (pathname (buffer-pathname buffer)))
42 "Checks for file options and invokes handlers if there are any. If no
43 \"Mode\" mode option is specified, then this tries to invoke the appropriate
44 file type hook."
45 (let* ((string
46 (line-string (mark-line (buffer-start-mark buffer))))
47 (found (search "-*-" string))
48 (no-major-mode t)
49 (type (if pathname (pathname-type pathname))))
50 (declare (simple-string string))
51 (when found
52 (block do-file-options
53 (let* ((start (+ found 3))
54 (end (search "-*-" string :start2 start)))
55 (unless end
56 (loud-message "No closing \"-*-\". Aborting file options.")
57 (return-from do-file-options))
58 (cond
59 ((find #\: string :start start :end end)
60 (do ((opt-start start (1+ semi)) colon semi)
61 (nil)
62 (setq colon (position #\: string :start opt-start :end end))
63 (unless colon
64 (loud-message "Missing \":\". Aborting file options.")
65 (return-from do-file-options))
66 (setq semi (or (position #\; string :start colon :end end) end))
67 (let* ((option (nstring-downcase
68 (trim-subseq string opt-start colon)))
69 (handler (assoc option *mode-option-handlers*
70 :test #'string=)))
71 (declare (simple-string option))
72 (cond
73 (handler
74 (let ((result (funcall (cdr handler) buffer
75 (trim-subseq string (1+ colon) semi))))
76 (when (string= option "mode")
77 (setq no-major-mode (not result)))))
78 (t (message "Unknown file option: ~S" option)))
79 (when (= semi end) (return nil)))))
80 (t
81 ;; Old style mode comment.
82 (setq no-major-mode nil)
83 (funcall (cdr (assoc "mode" *mode-option-handlers* :test #'string=))
84 buffer (trim-subseq string start end)))))))
85 (when (and no-major-mode type)
86 (let ((hook (assoc (string-downcase type) *file-type-hooks*
87 :test #'string=)))
88 (when hook (funcall (cdr hook) buffer type))))))
89
90
91
92 ;;;; File options and file type hooks.
93
94 (defmacro define-file-option (name lambda-list &body body)
95 "Define-File-Option Name (Buffer Value) {Form}*
96 Defines a new file option to be user in the -*- line at the top of a file.
97 The body is evaluated with Buffer bound to the buffer the file has been read
98 into and Value to the string argument to the option."
99 (let ((name (string-downcase name)))
100 `(setf (cdr (or (assoc ,name *mode-option-handlers* :test #'string=)
101 (car (push (cons ,name nil) *mode-option-handlers*))))
102 #'(lambda ,lambda-list ,@body))))
103
104 (define-file-option "Mode" (buffer str)
105 (let ((seen-major-mode-p nil)
106 (lastpos 0))
107 (loop
108 (let* ((pos (position #\, str :start lastpos))
109 (substr (trim-subseq str lastpos pos)))
110 (cond ((getstring substr *mode-names*)
111 (cond ((mode-major-p substr)
112 (when seen-major-mode-p
113 (loud-message
114 "Major mode already processed. Using ~S now."
115 substr))
116 (setf seen-major-mode-p t)
117 (setf (buffer-major-mode buffer) substr))
118 (t
119 (setf (buffer-minor-mode buffer substr) t))))
120 (t
121 (loud-message "~S is not a defined mode -- ignored." substr)))
122 (unless pos
123 (return seen-major-mode-p))
124 (setf lastpos (1+ pos))))))
125
126
127 (defmacro define-file-type-hook (type-list (buffer type) &body body)
128 "Define-File-Type-Hook ({Type}*) (Buffer Type) {Form}*
129 Define some code to be evaluated when a file having one of the specified
130 Types is read by a file command. Buffer is bound to the buffer the
131 file is in, and Type is the actual type read."
132 (let ((fun (gensym)) (str (gensym)))
133 `(flet ((,fun (,buffer ,type) ,@body))
134 (dolist (,str ',(mapcar #'string-downcase type-list))
135 (setf (cdr (or (assoc ,str *file-type-hooks* :test #'string=)
136 (car (push (cons ,str nil) *file-type-hooks*))))
137 #',fun)))))
138
139 (define-file-type-hook ("pas" "pasmac" "macro" "defs" "spc" "bdy")
140 (buffer type)
141 (declare (ignore type))
142 (setf (buffer-major-mode buffer) "Pascal"))
143
144 (define-file-type-hook ("lisp" "slisp" "l" "lsp" "mcl") (buffer type)
145 (declare (ignore type))
146 (setf (buffer-major-mode buffer) "Lisp"))
147
148 (define-file-type-hook ("txt" "text" "tx") (buffer type)
149 (declare (ignore type))
150 (setf (buffer-major-mode buffer) "Text"))
151
152
153
154 ;;;; Support for file hacking commands:
155
156 (defhvar "Pathname Defaults"
157 "This variable contains a pathname which is used to supply defaults
158 when we don't have anything better."
159 :value (pathname "gazonk.del"))
160
161 (defhvar "Last Resort Pathname Defaults"
162 "This variable contains a pathname which is used to supply defaults when
163 we don't have anything better, but unlike \"Pathname Defaults\", this is
164 never set to some buffer's pathname."
165 :value (pathname "gazonk"))
166
167 (defhvar "Last Resort Pathname Defaults Function"
168 "This variable contains a function that is called when a default pathname is
169 needed, the buffer has no pathname, and the buffer's name is not entirely
170 composed of alphanumerics. The default value is a function that simply
171 returns \"Last Resort Pathname Defaults\". The function must take a buffer
172 as an argument, and it must return some pathname."
173 :value #'(lambda (buffer)
174 (declare (ignore buffer))
175 (merge-pathnames (value last-resort-pathname-defaults)
176 (value pathname-defaults))))
177
178 (defun buffer-default-pathname (buffer)
179 "Returns \"Buffer Pathname\" if it is bound. If it is not, and buffer's name
180 is composed solely of alphnumeric characters, then return a pathname formed
181 from the buffer's name. If the buffer's name has other characters in it,
182 then return the value of \"Last Resort Pathname Defaults Function\" called
183 on buffer."
184 (or (buffer-pathname buffer)
185 (if (every #'alphanumericp (the simple-string (buffer-name buffer)))
186 (merge-pathnames (make-pathname :name (buffer-name buffer))
187 (value pathname-defaults))
188 (funcall (value last-resort-pathname-defaults-function) buffer))))
189
190
191 (defun pathname-to-buffer-name (pathname)
192 "Returns a simple-string using components from pathname."
193 (let ((pathname (pathname pathname)))
194 (concatenate 'simple-string
195 (file-namestring pathname)
196 " "
197 (directory-namestring pathname))))
198
199
200
201 ;;;; File hacking commands.
202
203 (defcommand "Process File Options" (p)
204 "Reprocess this buffer's file options."
205 "Reprocess this buffer's file options."
206 (declare (ignore p))
207 (process-file-options (current-buffer)))
208
209 (defcommand "Insert File" (p &optional pathname (buffer (current-buffer)))
210 "Inserts a file which is prompted for into the current buffer at the point.
211 The prefix argument is ignored."
212 "Inserts the file named by Pathname into Buffer at the point."
213 (declare (ignore p))
214 (let* ((pn (or pathname
215 (prompt-for-file :default (buffer-default-pathname buffer)
216 :prompt "Insert File: "
217 :help "Name of file to insert")))
218 (point (buffer-point buffer))
219 ;; start and end will be deleted by undo stuff
220 (start (copy-mark point :right-inserting))
221 (end (copy-mark point :left-inserting))
222 (region (region start end)))
223 (setv pathname-defaults pn)
224 (push-buffer-mark (copy-mark end))
225 (read-file pn end)
226 (make-region-undo :delete "Insert File" region)))
227
228 (defcommand "Write Region" (p &optional pathname)
229 "Writes the current region to a file. "
230 "Writes the current region to a file. "
231 (declare (ignore p))
232 (let ((region (current-region))
233 (pn (or pathname
234 (prompt-for-file :prompt "File to Write: "
235 :help "The name of the file to write the region to. "
236 :default (buffer-default-pathname
237 (current-buffer))
238 :must-exist nil))))
239 (write-file region pn)
240 (message "~A written." (namestring (truename pn)))))
241
242
243
244 ;;;; Visiting and reverting files.
245
246 (defcommand "Visit File" (p &optional pathname (buffer (current-buffer)))
247 "Replaces the contents of Buffer with the file Pathname. The prefix
248 argument is ignored. The buffer is set to be writable, so its region
249 can be deleted."
250 "Replaces the contents of the current buffer with the text in the file
251 which is prompted for. The prefix argument is, of course, ignored p times."
252 (declare (ignore p))
253 (when (and (buffer-modified buffer)
254 (prompt-for-y-or-n :prompt "Buffer is modified, save it? "))
255 (save-file-command () buffer))
256 (let ((pn (or pathname
257 (prompt-for-file :prompt "Visit File: "
258 :must-exist nil
259 :help "Name of file to visit."
260 :default (buffer-default-pathname buffer)))))
261 (setf (buffer-writable buffer) t)
262 (read-buffer-file pn buffer)
263 (let ((n (pathname-to-buffer-name (buffer-pathname buffer))))
264 (unless (getstring n *buffer-names*)
265 (setf (buffer-name buffer) n))
266 (warn-about-visit-file-buffers buffer))))
267
268 (defun warn-about-visit-file-buffers (buffer)
269 (let ((buffer-pn (buffer-pathname buffer)))
270 (dolist (b *buffer-list*)
271 (unless (eq b buffer)
272 (let ((bpn (buffer-pathname b)))
273 (when (equal bpn buffer-pn)
274 (message "Buffer ~A also contains ~A."
275 (buffer-name b) (namestring buffer-pn))
276 (return)))))))
277
278
279 (defhvar "Revert File Confirm"
280 "If this is true, Revert File will prompt before reverting."
281 :value t)
282
283 (defcommand "Revert File" (p)
284 "Unless in Save Mode, reads in the last saved version of the file in
285 the current buffer. When in Save Mode, reads in the last checkpoint or
286 the last saved version, whichever is more recent. An argument will always
287 force Revert File to use the last saved version. In either case, if the
288 buffer has been modified and \"Revert File Confirm\" is true, then Revert
289 File will ask for confirmation beforehand. An attempt is made to maintain
290 the point's relative position."
291 "With an argument reverts to the last saved version of the file in the
292 current buffer. Without, reverts to the last checkpoint or last saved
293 version, whichever is more recent."
294 (let* ((buffer (current-buffer))
295 (buffer-pn (buffer-pathname buffer))
296 (point (current-point))
297 (lines (1- (count-lines (region (buffer-start-mark buffer) point)))))
298 (multiple-value-bind (revert-pn used-checkpoint)
299 (if p buffer-pn (revert-pathname buffer))
300 (unless revert-pn
301 (editor-error "No file associated with buffer to revert to!"))
302 (when (or (not (value revert-file-confirm))
303 (not (buffer-modified buffer))
304 (prompt-for-y-or-n
305 :prompt
306 "Buffer contains changes, are you sure you want to revert? "
307 :help (list
308 "Reverting the file will undo any changes by reading in the last ~
309 ~:[saved version~;checkpoint file~]." used-checkpoint)
310 :default t))
311 (read-buffer-file revert-pn buffer)
312 (when used-checkpoint
313 (setf (buffer-modified buffer) t)
314 (setf (buffer-pathname buffer) buffer-pn)
315 (message "Reverted to checkpoint file ~A." (namestring revert-pn)))
316 (unless (line-offset point lines)
317 (buffer-end point))))))
318
319 ;;; REVERT-PATHNAME -- Internal
320 ;;;
321 ;;; If in Save Mode, return either the checkpoint pathname or the buffer
322 ;;; pathname whichever is more recent. Otherwise return the buffer-pathname
323 ;;; if it exists. If neither file exists, return NIL.
324 ;;;
325 (defun revert-pathname (buffer)
326 (let* ((buffer-pn (buffer-pathname buffer))
327 (buffer-pn-date (file-write-date buffer-pn))
328 (checkpoint-pn (get-checkpoint-pathname buffer))
329 (checkpoint-pn-date (file-write-date checkpoint-pn)))
330 (cond (checkpoint-pn-date
331 (if (> checkpoint-pn-date (or buffer-pn-date 0))
332 (values checkpoint-pn t)
333 (values buffer-pn nil)))
334 (buffer-pn-date (values buffer-pn nil))
335 (t (values nil nil)))))
336
337
338
339 ;;;; Find file.
340
341 (defcommand "Find File" (p &optional pathname)
342 "Visit a file in its own buffer.
343 If the file is already in some buffer, select that buffer,
344 otherwise make a new buffer with the same name as the file and
345 read the file into it."
346 "Make a buffer containing the file Pathname current, creating a buffer
347 if necessary. The buffer is returned."
348 (declare (ignore p))
349 (let* ((pn (or pathname
350 (prompt-for-file
351 :prompt "Find File: "
352 :must-exist nil
353 :help "Name of file to read into its own buffer."
354 :default (buffer-default-pathname (current-buffer)))))
355 (buffer (find-file-buffer pn)))
356 (change-to-buffer buffer)
357 buffer))
358
359 (defun find-file-buffer (pathname)
360 "Return a buffer assoicated with the file Pathname, reading the file into a
361 new buffer if necessary. The second value is T if we created a buffer, NIL
362 otherwise. If the file has already been read, we check to see if the file
363 has been modified on disk since it was read, giving the user various
364 recovery options."
365 (let* ((pathname (pathname pathname))
366 (trial-pathname (or (probe-file pathname)
367 (merge-pathnames pathname (default-directory))))
368 (found (find trial-pathname (the list *buffer-list*)
369 :key #'buffer-pathname :test #'equal)))
370 (cond ((not found)
371 (let* ((name (pathname-to-buffer-name trial-pathname))
372 (buffer (getstring name *buffer-names*))
373 (use (if buffer
374 (prompt-for-buffer
375 :prompt "Buffer to use: "
376 :help
377 "Buffer name in use; give another buffer name, or confirm to reuse."
378 :default buffer :must-exist nil)
379 (make-buffer name)))
380 (buffer (if (stringp use) (make-buffer use) use)))
381 (when (and (buffer-modified buffer)
382 (prompt-for-y-or-n :prompt
383 "Buffer is modified, save it? "))
384 (save-file-command () buffer))
385 (read-buffer-file pathname buffer)
386 (values buffer (stringp use))))
387 ((check-disk-version-consistent pathname found)
388 (values found nil))
389 (t
390 (read-buffer-file pathname found)
391 (values found nil)))))
392
393 ;;; Check-Disk-Version-Consistent -- Internal
394 ;;;
395 ;;; Check that Buffer contains a valid version of the file Pathname,
396 ;;; harrassing the user if not. We return true if the buffer is O.K., and
397 ;;; false if the file should be read.
398 ;;;
399 (defun check-disk-version-consistent (pathname buffer)
400 (let ((ndate (file-write-date pathname))
401 (odate (buffer-write-date buffer)))
402 (cond ((not (and ndate odate (/= ndate odate)))
403 t)
404 ((buffer-modified buffer)
405 (beep)
406 (clear-input)
407 (command-case (:prompt (list
408 "File has been changed on disk since it was read and you have made changes too!~
409 ~%Read in the disk version of ~A? [Y] " (namestring pathname))
410 :help
411 "The file in disk has been changed since Hemlock last saved it, meaning that
412 someone else has probably overwritten it. Since the version read into Hemlock
413 has been changed as well, the two versions may have inconsistent changes. If
414 this is the case, it would be a good idea to save your changes in another file
415 and compare the two versions.
416
417 Type one of the following commands:")
418 ((:confirm :yes)
419 "Prompt for a file to write the buffer out to, then read in the disk version."
420 (write-buffer-file
421 buffer
422 (prompt-for-file
423 :prompt "File to save changes in: "
424 :help (list "Save buffer ~S to this file before reading ~A."
425 (buffer-name buffer) (namestring pathname))
426 :must-exist nil
427 :default (buffer-default-pathname buffer)))
428 nil)
429 (:no
430 "Change to the buffer without reading the new version."
431 t)
432 (#\r
433 "Read in the new version, clobbering the changes in the buffer."
434 nil)))
435 (t
436 (not (prompt-for-yes-or-no :prompt
437 (list
438 "File has been changed on disk since it was read.~
439 ~%Read in the disk version of ~A? "
440 (namestring pathname))
441 :help
442 "Type Y to read in the new version or N to just switch to the buffer."
443 :default t))))))
444
445
446 (defhvar "Read File Hook"
447 "These functions are called when a file is read into a buffer. Each function
448 must take two arguments -- the buffer the file was read into and whether the
449 file existed (non-nil) or not (nil).")
450
451 (defun read-buffer-file (pathname buffer)
452 "Delete the buffer's region, and uses READ-FILE to read pathname into it.
453 If the file exists, set the buffer's write date to the file's; otherwise,
454 MESSAGE that this is a new file and set the buffer's write date to nil.
455 Move buffer's point to the beginning, set the buffer unmodified. If the
456 file exists, set the buffer's pathname to the probed pathname; else, set it
457 to pathname merged with DEFAULT-DIRECTORY. Set \"Pathname Defaults\" to the
458 same thing. Process the file options, and then invoke \"Read File Hook\"."
459 (delete-region (buffer-region buffer))
460 (let* ((pathname (pathname pathname))
461 (probed-pathname (probe-file pathname)))
462 (cond (probed-pathname
463 (read-file probed-pathname (buffer-point buffer))
464 (setf (buffer-write-date buffer) (file-write-date probed-pathname)))
465 (t
466 (message "(New File)")
467 (setf (buffer-write-date buffer) nil)))
468 (buffer-start (buffer-point buffer))
469 (setf (buffer-modified buffer) nil)
470 (let ((stored-pathname (or probed-pathname
471 (merge-pathnames pathname (default-directory)))))
472 (setf (buffer-pathname buffer) stored-pathname)
473 (setf (value pathname-defaults) stored-pathname)
474 (process-file-options buffer stored-pathname)
475 (invoke-hook read-file-hook buffer probed-pathname))))
476
477
478
479 ;;;; File writing.
480
481 (defhvar "Add Newline at EOF on Writing File"
482 "This controls whether WRITE-BUFFER-FILE adds a newline at the end of the
483 file when it ends at the end of a non-empty line. When set, this may be
484 :ask-user and WRITE-BUFFER-FILE will prompt; otherwise, just add one and
485 inform the user. When nil, never add one and don't ask."
486 :value :ask-user)
487
488 (defhvar "Keep Backup Files"
489 "When set, .BAK files will be saved upon file writing. This defaults to nil."
490 :value nil)
491
492 (defhvar "Write File Hook"
493 "These functions are called when a buffer has been written. Each function
494 must take the buffer as an argument.")
495
496 (defun write-buffer-file (buffer pathname)
497 "Write's buffer to pathname. This assumes pathname is somehow related to
498 the buffer's pathname, and if the buffer's write date is not the same as
499 pathname's, then this prompts the user for confirmation before overwriting
500 the file. This consults \"Add Newline at EOF on Writing File\" and
501 interacts with the user if necessary. This sets \"Pathname Defaults\", and
502 the buffer is marked unmodified. The buffer's pathname and write date are
503 updated, and the buffer is renamed according to the new pathname if possible.
504 This invokes \"Write File Hook\"."
505 (let ((buffer-pn (buffer-pathname buffer)))
506 (let ((date (buffer-write-date buffer))
507 (file-date (when (probe-file pathname) (file-write-date pathname))))
508 (when (and buffer-pn date file-date
509 (equal (make-pathname :version nil :defaults buffer-pn)
510 (make-pathname :version nil :defaults pathname))
511 (/= date file-date))
512 (unless (prompt-for-yes-or-no :prompt (list
513 "File has been changed on disk since it was read.~%Overwrite ~A anyway? "
514 (namestring buffer-pn))
515 :help
516 "Type No to abort writing the file or Yes to overwrite the disk version."
517 :default nil)
518 (editor-error "Write aborted."))))
519 (let ((val (value add-newline-at-eof-on-writing-file)))
520 (when val
521 (let ((end (buffer-end-mark buffer)))
522 (unless (start-line-p end)
523 (when (if (eq val :ask-user)
524 (prompt-for-y-or-n
525 :prompt
526 (list "~A~%File does not have a newline at EOF, add one? "
527 (buffer-name buffer))
528 :default t)
529 t)
530 (insert-character end #\newline)
531 (message "Added newline at EOF."))))))
532 (setv pathname-defaults pathname)
533 (write-file (buffer-region buffer) pathname)
534 (let ((tn (truename pathname)))
535 (message "~A written." (namestring tn))
536 (setf (buffer-modified buffer) nil)
537 (unless (equal tn buffer-pn)
538 (setf (buffer-pathname buffer) tn))
539 (setf (buffer-write-date buffer) (file-write-date tn))
540 (let ((name (pathname-to-buffer-name tn)))
541 (unless (getstring name *buffer-names*)
542 (setf (buffer-name buffer) name)))))
543 (invoke-hook write-file-hook buffer))
544
545 (defcommand "Write File" (p &optional pathname (buffer (current-buffer)))
546 "Writes the contents of Buffer, which defaults to the current buffer to
547 the file named by Pathname. The prefix argument is ignored."
548 "Prompts for a file to write the contents of the current Buffer to.
549 The prefix argument is ignored."
550 (declare (ignore p))
551 (write-buffer-file
552 buffer
553 (or pathname
554 (prompt-for-file :prompt "Write File: "
555 :must-exist nil
556 :help "Name of file to write to"
557 :default (buffer-default-pathname buffer)))))
558
559 (defcommand "Save File" (p &optional (buffer (current-buffer)))
560 "Writes the contents of the current buffer to the associated file. If there
561 is no associated file, once is prompted for."
562 "Writes the contents of the current buffer to the associated file."
563 (declare (ignore p))
564 (when (or (buffer-modified buffer)
565 (prompt-for-y-or-n
566 :prompt "Buffer is unmodified, write it anyway? "
567 :default t))
568 (write-buffer-file
569 buffer
570 (or (buffer-pathname buffer)
571 (prompt-for-file :prompt "Save File: "
572 :help "Name of file to write to"
573 :default (buffer-default-pathname buffer)
574 :must-exist nil)))))
575
576 (defhvar "Save All Files Confirm"
577 "When non-nil, prompts for confirmation before writing each modified buffer."
578 :value t)
579
580 (defcommand "Save All Files" (p)
581 "Saves all modified buffers in their associated files.
582 If a buffer has no associated file it is ignored even if it is modified.."
583 "Saves each modified buffer that has a file."
584 (declare (ignore p))
585 (let ((saved-count 0))
586 (dolist (b *buffer-list*)
587 (let ((pn (buffer-pathname b))
588 (name (buffer-name b)))
589 (when
590 (and (buffer-modified b)
591 pn
592 (or (not (value save-all-files-confirm))
593 (prompt-for-y-or-n
594 :prompt (list
595 "Write ~:[buffer ~A as file ~S~;file ~*~S~], ~
596 Y or N: "
597 (string= (pathname-to-buffer-name pn) name)
598 name (namestring pn))
599 :default t)))
600 (write-buffer-file b pn)
601 (incf saved-count))))
602 (if (zerop saved-count)
603 (message "No files were saved.")
604 (message "Saved ~S file~:P." saved-count))))
605
606 (defcommand "Save All Files and Exit" (p)
607 "Save all modified buffers in their associated files and exit;
608 a combination of \"Save All Files\" and \"Exit Hemlock\"."
609 "Do a save-all-files-command and then an exit-hemlock."
610 (declare (ignore p))
611 (save-all-files-command ())
612 (exit-hemlock))
613
614 (defcommand "Backup File" (p)
615 "Write the buffer to a file without changing the associated name."
616 "Write the buffer to a file without changing the associated name."
617 (declare (ignore p))
618 (let ((file (prompt-for-file :prompt "Backup to File: "
619 :help
620 "Name of a file to backup the current buffer in."
621 :default (buffer-default-pathname (current-buffer))
622 :must-exist nil)))
623 (write-file (buffer-region (current-buffer)) file)
624 (message "~A written." (namestring (truename file)))))
625
626
627
628 ;;;; Buffer hacking commands:
629
630 (defvar *buffer-history* ()
631 "A list of buffers, in order from most recently to least recently selected.")
632
633 (defun previous-buffer ()
634 "Returns some previously selected buffer that is not the current buffer.
635 Returns nil if no such buffer exists."
636 (let ((b (car *buffer-history*)))
637 (or (if (eq b (current-buffer)) (cadr *buffer-history*) b)
638 (find-if-not #'(lambda (x)
639 (or (eq x (current-buffer))
640 (eq x *echo-area-buffer*)))
641 (the list *buffer-list*)))))
642
643 ;;; ADD-BUFFER-HISTORY-HOOK makes sure every buffer will be visited by
644 ;;; "Circulate Buffers" even if it has never been before.
645 ;;;
646 (defun add-buffer-history-hook (buffer)
647 (let ((ele (last *buffer-history*))
648 (new-stuff (list buffer)))
649 (if ele
650 (setf (cdr ele) new-stuff)
651 (setf *buffer-history* new-stuff))))
652 ;;;
653 (add-hook make-buffer-hook 'add-buffer-history-hook)
654
655 ;;; DELETE-BUFFER-HISTORY-HOOK makes sure we never end up in a dead buffer.
656 ;;;
657 (defun delete-buffer-history-hook (buffer)
658 (setq *buffer-history* (delq buffer *buffer-history*)))
659 ;;;
660 (add-hook delete-buffer-hook 'delete-buffer-history-hook)
661
662 (defun change-to-buffer (buffer)
663 "Switches to buffer in the current window maintaining *buffer-history*."
664 (setq *buffer-history*
665 (cons (current-buffer) (delq (current-buffer) *buffer-history*)))
666 (setf (current-buffer) buffer)
667 (setf (window-buffer (current-window)) buffer))
668
669 (defun delete-buffer-if-possible (buffer)
670 "Deletes a buffer if at all possible. If buffer is the only buffer, other
671 than the echo area, signals an error. Otherwise, find some recently current
672 buffer, and make all of buffer's windows display this recent buffer. If
673 buffer is current, set the current buffer to be this recently current
674 buffer."
675 (let ((new-buf (flet ((frob (b)
676 (or (eq b buffer) (eq b *echo-area-buffer*))))
677 (or (find-if-not #'frob (the list *buffer-history*))
678 (find-if-not #'frob (the list *buffer-list*))))))
679 (unless new-buf
680 (error "Cannot delete only buffer ~S." buffer))
681 (dolist (w (buffer-windows buffer))
682 (setf (window-buffer w) new-buf))
683 (when (eq buffer (current-buffer))
684 (setf (current-buffer) new-buf)))
685 (delete-buffer buffer))
686
687
688 (defvar *create-buffer-count* 0)
689
690 (defcommand "Create Buffer" (p &optional buffer-name)
691 "Create a new buffer. If a buffer with the specified name already exists,
692 then go to it."
693 "Create or go to the buffer with the specifed name."
694 (declare (ignore p))
695 (let ((name (or buffer-name
696 (prompt-for-buffer :prompt "Create Buffer: "
697 :default-string
698 (format nil "Buffer ~D"
699 (incf *create-buffer-count*))
700 :must-exist nil))))
701 (if (bufferp name)
702 (change-to-buffer name)
703 (change-to-buffer (or (getstring name *buffer-names*)
704 (make-buffer name))))))
705
706 (defcommand "Select Buffer" (p)
707 "Select a different buffer.
708 The buffer to go to is prompted for."
709 "Select a different buffer.
710 The buffer to go to is prompted for."
711 (declare (ignore p))
712 (let ((buf (prompt-for-buffer :prompt "Select Buffer: "
713 :default (previous-buffer))))
714 (when (eq buf *echo-area-buffer*)
715 (editor-error "Cannot select Echo Area buffer."))
716 (change-to-buffer buf)))
717
718
719 (defvar *buffer-history-ptr* ()
720 "The successively previous buffer to the current buffer.")
721
722 (defcommand "Select Previous Buffer" (p)
723 "Select the buffer selected before this one. If called repeatedly
724 with an argument, select the successively previous buffer to the
725 current one leaving the buffer history as it is."
726 "Select the buffer selected before this one."
727 (if p
728 (circulate-buffers-command nil)
729 (let ((b (previous-buffer)))
730 (unless b (editor-error "No previous buffer."))
731 (change-to-buffer b)
732 ;;
733 ;; If the pointer goes to nil, then "Circulate Buffers" will keep doing
734 ;; "Select Previous Buffer".
735 (setf *buffer-history-ptr* (cddr *buffer-history*))
736 (setf (last-command-type) :previous-buffer))))
737
738 (defcommand "Circulate Buffers" (p)
739 "Advance through buffer history, selecting successively previous buffer."
740 "Advance through buffer history, selecting successively previous buffer."
741 (declare (ignore p))
742 (if (and (eq (last-command-type) :previous-buffer)
743 *buffer-history-ptr*) ;Possibly nil if never CHANGE-TO-BUFFER.
744 (let ((b (pop *buffer-history-ptr*)))
745 (when (eq b (current-buffer))
746 (setf b (pop *buffer-history-ptr*)))
747 (unless b
748 (setf *buffer-history-ptr*
749 (or (cdr *buffer-history*) *buffer-history*))
750 (setf b (car *buffer-history*)))
751 (setf (current-buffer) b)
752 (setf (window-buffer (current-window)) b)
753 (setf (last-command-type) :previous-buffer))
754 (select-previous-buffer-command nil)))
755
756
757 (defcommand "Buffer Not Modified" (p)
758 "Make the current buffer not modified."
759 "Make the current buffer not modified."
760 (declare (ignore p))
761 (setf (buffer-modified (current-buffer)) nil)
762 (message "Buffer marked as unmodified."))
763
764 (defcommand "Check Buffer Modified" (p)
765 "Say whether the buffer is modified or not."
766 "Say whether the current buffer is modified or not."
767 (declare (ignore p))
768 (clear-echo-area)
769 (message "Buffer ~S ~:[is not~;is~] modified."
770 (buffer-name (current-buffer)) (buffer-modified (current-buffer))))
771
772 (defcommand "Set Buffer Read-Only" (p)
773 "Toggles the read-only flag for the current buffer."
774 "Toggles the read-only flag for the current buffer."
775 (declare (ignore p))
776 (let ((buffer (current-buffer)))
777 (message "Buffer ~S is now ~:[read-only~;writable~]."
778 (buffer-name buffer)
779 (setf (buffer-writable buffer) (not (buffer-writable buffer))))))
780
781 (defcommand "Kill Buffer" (p &optional buffer-name)
782 "Prompts for a buffer to delete.
783 If the buffer is modified, then let the user save the file before doing so.
784 When deleting the current buffer, prompts for a new buffer to select. If
785 a buffer other than the current one is deleted then any windows into it
786 are deleted."
787 "Delete buffer Buffer-Name, doing sensible things if the buffer is displayed
788 or current."
789 (declare (ignore p))
790 (let ((buffer (if buffer-name
791 (getstring buffer-name *buffer-names*)
792 (prompt-for-buffer :prompt "Kill Buffer: "
793 :default (current-buffer)))))
794 (if (not buffer)
795 (editor-error "No buffer named ~S" buffer-name))
796 (if (and (buffer-modified buffer)
797 (prompt-for-y-or-n :prompt "Save it first? "))
798 (save-file-command () buffer))
799 (if (eq buffer (current-buffer))
800 (let ((new (prompt-for-buffer :prompt "New Buffer: "
801 :default (previous-buffer)
802 :help "Buffer to change to after the current one is killed.")))
803 (when (eq new buffer)
804 (editor-error "You must select a different buffer."))
805 (dolist (w (buffer-windows buffer))
806 (setf (window-buffer w) new))
807 (setf (current-buffer) new))
808 (dolist (w (buffer-windows buffer))
809 (delete-window w)))
810 (delete-buffer buffer)))
811
812 (defcommand "Rename Buffer" (p)
813 "Change the current buffer's name.
814 The name, which is prompted for, defaults to the name of the associated
815 file."
816 "Change the name of the current buffer."
817 (declare (ignore p))
818 (let* ((buf (current-buffer))
819 (pn (buffer-pathname buf))
820 (name (if pn (pathname-to-buffer-name pn) (buffer-name buf)))
821 (new (prompt-for-string :prompt "New Name: "
822 :help "Give a new name for the current buffer"
823 :default name)))
824 (multiple-value-bind (entry foundp) (getstring new *buffer-names*)
825 (cond ((or (not foundp) (eq entry buf))
826 (setf (buffer-name buf) new))
827 (t (editor-error "Name ~S already in use." new))))))
828
829
830 (defcommand "Insert Buffer" (p)
831 "Insert the contents of a buffer.
832 The name of the buffer to insert is prompted for."
833 "Prompt for a buffer to insert at the point."
834 (declare (ignore p))
835 (let ((point (current-point))
836 (region (buffer-region (prompt-for-buffer
837 :default (previous-buffer)
838 :help
839 "Type the name of a buffer to insert."))))
840 ;;
841 ;; start and end will be deleted by undo stuff
842 (let ((save (region (copy-mark point :right-inserting)
843 (copy-mark point :left-inserting))))
844 (push-buffer-mark (copy-mark point))
845 (insert-region point region)
846 (make-region-undo :delete "Insert Buffer" save))))
847
848
849
850 ;;;; File utility commands:
851
852 (defcommand "Directory" (p)
853 "Do a directory into a pop-up window. If an argument is supplied, then
854 dot files are listed too (as with ls -a). Prompts for a pathname which
855 may contain wildcards in the name and type."
856 "Do a directory into a pop-up window."
857 (let* ((dpn (value pathname-defaults))
858 (pn (prompt-for-file
859 :prompt "Directory: "
860 :help "Pathname to do directory on."
861 :default (make-pathname :device (pathname-device dpn)
862 :directory (pathname-directory dpn))
863 :must-exist nil)))
864 (setf (value pathname-defaults) (merge-pathnames pn dpn))
865 (with-pop-up-display (s)
866 (print-directory pn s :all p))))
867
868 (defcommand "Verbose Directory" (p)
869 "Do a directory into a pop-up window. If an argument is supplied, then
870 dot files are listed too (as with ls -a). Prompts for a pathname which
871 may contain wildcards in the name and type."
872 "Do a directory into a pop-up window."
873 (let* ((dpn (value pathname-defaults))
874 (pn (prompt-for-file
875 :prompt "Verbose Directory: "
876 :help "Pathname to do directory on."
877 :default (make-pathname :device (pathname-device dpn)
878 :directory (pathname-directory dpn))
879 :must-exist nil)))
880 (setf (value pathname-defaults) (merge-pathnames pn dpn))
881 (with-pop-up-display (s)
882 (print-directory pn s :verbose t :all p))))
883
884
885
886 ;;;; Change log stuff:
887
888 (define-file-option "Log" (buffer value)
889 (defhvar "Log File Name"
890 "The name of the file for the change log for the file in this buffer."
891 :buffer buffer :value value))
892
893 (defhvar "Log Entry Template"
894 "The format string used to generate the template for a change-log entry.
895 Three arguments are given: the file, the date (create if available, now
896 otherwise) and the file author, or NIL if not available. The last \"@\"
897 is deleted and the point placed where it was."
898 :value "~A, ~A, Edit by ~:[???~;~:*~:(~A~)~].~% @~2%")
899
900 (defmode "Log"
901 :major-p t
902 :setup-function
903 #'(lambda (buffer)
904 (setf (buffer-minor-mode buffer "Fill") t))
905 :cleanup-function
906 #'(lambda (buffer)
907 (setf (buffer-minor-mode buffer "Fill") nil)))
908
909 (defhvar "Fill Prefix" "The fill prefix in Log mode."
910 :value " " :mode "Log")
911
912 (define-file-type-hook ("log") (buffer type)
913 (declare (ignore type))
914 (setf (buffer-major-mode buffer) "Log"))
915
916 (defun universal-time-to-string (ut)
917 (multiple-value-bind (sec min hour day month year)
918 (decode-universal-time ut)
919 (format nil "~2,'0D-~A-~2,'0D ~2,'0D:~2,'0D:~2,'0D"
920 day (svref '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug"
921 "Sep" "Oct" "Nov" "Dec")
922 (1- month))
923 (rem year 100)
924 hour min sec)))
925
926 (defvar *back-to-@-pattern* (new-search-pattern :character :backward #\@))
927 (defcommand "Log Change" (p)
928 "Make an entry in the change-log file for this buffer.
929 Saves the file in the current buffer if it is modified, then finds the file
930 specified in the \"Log\" file option, adds the template for a change-log
931 entry at the beginning, then does a recursive edit, saving the log file on
932 exit."
933 "Find the change-log file as specified by \"Log File Name\" and edit it."
934 (declare (ignore p))
935 (unless (hemlock-bound-p 'log-file-name)
936 (editor-error "No log file defined."))
937 (let* ((buffer (current-buffer))
938 (pathname (buffer-pathname buffer)))
939 (when (or (buffer-modified buffer) (null pathname))
940 (save-file-command ()))
941 (unwind-protect
942 (progn
943 (find-file-command nil (merge-pathnames
944 (value log-file-name)
945 (buffer-default-pathname buffer)))
946 (let ((point (current-point)))
947 (buffer-start point)
948 (with-output-to-mark (s point :full)
949 (format s (value log-entry-template)
950 (namestring pathname)
951 (universal-time-to-string
952 (or (file-write-date pathname)
953 (get-universal-time)))
954 (file-author pathname)))
955 (when (find-pattern point *back-to-@-pattern*)
956 (delete-characters point 1)))
957 (do-recursive-edit)
958 (when (buffer-modified (current-buffer)) (save-file-command ())))
959 (if (member buffer *buffer-list* :test #'eq)
960 (change-to-buffer buffer)
961 (editor-error "Old buffer has been deleted.")))))
962
963
964
965 ;;;; Window hacking commands:
966
967 (defcommand "Next Window" (p)
968 "Change the current window to be the next window and the current buffer
969 to be it's buffer."
970 "Go to the next window.
971 If the next window is the bottom window then wrap around to the top window."
972 (declare (ignore p))
973 (let* ((next (next-window (current-window)))
974 (buffer (window-buffer next)))
975 (setf (current-buffer) buffer (current-window) next)))
976
977 (defcommand "Previous Window" (p)
978 "Change the current window to be the previous window and the current buffer
979 to be it's buffer."
980 "Go to the previous window.
981 If the Previous window is the top window then wrap around to the bottom."
982 (declare (ignore p))
983 (let* ((previous (previous-window (current-window)))
984 (buffer (window-buffer previous)))
985 (setf (current-buffer) buffer (current-window) previous)))
986
987 (defcommand "Split Window" (p)
988 "Make a new window by splitting the current window.
989 The new window is made the current window and displays starting at
990 the same place as the current window."
991 "Create a new window which displays starting at the same place
992 as the current window."
993 (declare (ignore p))
994 (let ((new (make-window (window-display-start (current-window)))))
995 (unless new (editor-error "Could not make a new window."))
996 (setf (current-window) new)))
997
998 (defcommand "New Window" (p)
999 "Make a new window and go to it.
1000 The window will display the same buffer as the current one."
1001 "Create a new window which displays starting at the same place
1002 as the current window."
1003 (declare (ignore p))
1004 (let ((new (make-window (window-display-start (current-window))
1005 :ask-user t)))
1006 (unless new (editor-error "Could not make a new window."))
1007 (setf (current-window) new)))
1008
1009 (defcommand "Delete Window" (p)
1010 "Delete the current window, going to the previous window."
1011 "Delete the window we are in, going to the previous window."
1012 (declare (ignore p))
1013 (let ((window (current-window)))
1014 (previous-window-command ())
1015 (when (eq (current-window) window)
1016 (editor-error "Cannot delete current window."))
1017 (delete-window window)))
1018
1019 (defcommand "Line to Top of Window" (p)
1020 "Move current line to top of window."
1021 "Move current line to top of window."
1022 (declare (ignore p))
1023 (with-mark ((mark (current-point)))
1024 (move-mark (window-display-start (current-window)) (line-start mark))))
1025
1026 (defcommand "Delete Next Window" (p)
1027 "Deletes the next window on display."
1028 "Deletes then next window on display."
1029 (declare (ignore p))
1030 (if (eq (next-window (current-window))
1031 (current-window))
1032 (editor-error "Cannot delete only window")
1033 (delete-window (next-window (current-window)))))
1034
1035 (defcommand "Go to One Window" (p)
1036 "Deletes all windows leaving one with the \"Default Initial Window X\",
1037 \"Default Initial Window Y\", \"Default Initial Window Width\", and
1038 \"Default Initial Window Height\"."
1039 "Deletes all windows leaving one with the \"Default Initial Window X\",
1040 \"Default Initial Window Y\", \"Default Initial Window Width\", and
1041 \"Default Initial Window Height\"."
1042 (declare (ignore p))
1043 (let ((win (make-window (window-display-start (current-window))
1044 :ask-user t
1045 :x (value default-initial-window-x)
1046 :y (value default-initial-window-y)
1047 :width (value default-initial-window-width)
1048 :height (value default-initial-window-height))))
1049 (setf (current-window) win)
1050 (dolist (w *window-list*)
1051 (unless (or (eq w win)
1052 (eq w *echo-area-window*))
1053 (delete-window w)))))
1054
1055 (defcommand "Line to Center of Window" (p)
1056 "Moves current line to the center of the window."
1057 "Moves current line to the center of the window."
1058 (declare (ignore p))
1059 (center-window (current-window) (current-point)))

  ViewVC Help
Powered by ViewVC 1.1.5