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

Contents of /src/hemlock/filecoms.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5