source: tags/pre_1_0_pre_hash_modifications/ccl/hemlock/src/filecoms.lisp @ 2475

Last change on this file since 2475 was 2475, checked in by anonymous, 15 years ago

This commit was manufactured by cvs2svn to create tag

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