source: trunk/source/cocoa-ide/hemlock/src/filecoms.lisp @ 15536

Last change on this file since 15536 was 15536, checked in by gb, 7 years ago

Support using the "coding" option in a file's file options line (a
line at the start of a text file that contains name:value pairs
separated by semicolons bracketed by -*- sequences) to determine a
file's character encoding. Specifically:

  • OPEN now allows an external-format of :INFERRED; previously, this was shorthand for an external-format whose line-termination was inferred and whose character encoding was based on *DEFAULT-FILE-CHARACTER-ENCODING*. When an input file whose external-format is specified as :INFERRED is opened, its file options are parsed and the value of the "coding" option is used if such an option is found (and if the value is something that CCL supports.) If a supported "coding" option isn't found, *DEFAULT-FILE-CHARACTER-ENCODING* is used as before.
  • In the Cocoa IDE, the Hemlock command "Ensure File Options Line" (bound to Control-Meta-M by default) ensures that the first line in the current buffer is a file options line and fills in some plausible values for the "Mode", "Package", and "Coding" options. The "Process File Options" command (Control-Meta-m) can be used to process the file options line after it's been edited. (The file options line is always processed when the file is first opened; changes to the "coding" option affect how the file will be saved.)

When a Lisp source file is opened in the IDE editor, the following
character encodings are tried in this order until one of them

  • if the "Open ..." panel was used to open the file and an encoding other than "Automatic" - which is now the default - is selected, that encoding is tried.
  • if a "coding" option is found, that encoding is tried.
  • the value of *DEFAULT-FILE-CHARACTER-ENCODING* is tried.
  • iso-8859-1 is tried. All files can be decoded in iso-8859-1.

This is all supposed to be what Emacs does and I think that it's
pretty close in practice.

A file that caused problems for Paul Krueger a few days ago
because its encoding (ISO-8859-1) wasn't guessed correctly
now has an explicit "coding" option and serves as a test case.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 25.6 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 (&optional (buffer (current-buffer))
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 real-semi)
63                (nil)
64              (setq colon (position #\: string :start opt-start :end end))
65              (unless colon
66                (unless real-semi
67                  (loud-message "Missing \":\".  Aborting file options."))
68                (return-from do-file-options))
69              (setq semi (or (setq real-semi (position #\; string :start colon :end end)) end))
70              (let* ((option (nstring-downcase
71                              (trim-subseq string opt-start colon)))
72                     (handler (assoc option *mode-option-handlers*
73                                     :test #'string=)))
74                (declare (simple-string option))
75                (cond
76                 (handler
77                  (let ((result (funcall (cdr handler) buffer
78                                         (trim-subseq string (1+ colon) semi))))
79                    (when (string= option "mode")
80                      (setq no-major-mode (not result)))))
81                 (t (message "Unknown file option: ~S" option)))
82                (when (= semi end) (return nil)))))
83           (t
84            ;; Old style mode comment.
85            (setq no-major-mode nil)
86            (funcall (cdr (assoc "mode" *mode-option-handlers* :test #'string=))
87                     buffer (trim-subseq string start end)))))))
88    (when (and no-major-mode type)
89      (let ((hook (assoc (string-downcase type) *file-type-hooks*
90                         :test #'string=)))
91        (when hook (funcall (cdr hook) buffer type))))))
95;;;; File options and file type hooks.
97(defmacro define-file-option (name lambda-list &body body)
98  "Define-File-Option Name (Buffer Value) {Form}*
99   Defines a new file option to be user in the -*- line at the top of a file.
100   The body is evaluated with Buffer bound to the buffer the file has been read
101   into and Value to the string argument to the option."
102  (let ((name (string-downcase name)))
103    `(setf (cdr (or (assoc ,name *mode-option-handlers*  :test #'string=)
104                    (car (push (cons ,name nil) *mode-option-handlers*))))
105           #'(lambda ,lambda-list ,@body))))
107(define-file-option "Mode" (buffer str)
108  (let ((seen-major-mode-p nil)
109        (lastpos 0))
110    (loop
111      (let* ((pos (position #\, str :start lastpos))
112             (substr (trim-subseq str lastpos pos)))
113        (cond ((getstring substr *mode-names*)
114               (cond ((mode-major-p substr)
115                      (when seen-major-mode-p
116                        (loud-message
117                         "Major mode already processed. Using ~S now."
118                         substr))
119                      (setf seen-major-mode-p t)
120                      (setf (buffer-major-mode buffer) substr))
121                     (t
122                      (setf (buffer-minor-mode buffer substr) t))))
123              (t
124               (loud-message "~S is not a defined mode -- ignored." substr)))
125        (unless pos
126          (return seen-major-mode-p))
127        (setf lastpos (1+ pos))))))
129(define-file-option "log" (buffer string)
130  (declare (ignore buffer string)))
132(define-file-option "base" (buffer string)
133  (declare (ignore buffer string)))
135(define-file-option "syntax" (buffer string)
136  (declare (ignore buffer string)))
138(define-file-option "coding" (buffer string)
139  (hemlock-ext:set-buffer-external-format buffer string))
144(defmacro define-file-type-hook (type-list (buffer type) &body body)
145  "Define-File-Type-Hook ({Type}*) (Buffer Type) {Form}*
146  Define some code to be evaluated when a file having one of the specified
147  Types is read by a file command.  Buffer is bound to the buffer the
148  file is in, and Type is the actual type read."
149  (let ((fun (gensym)) (str (gensym)))
150    `(flet ((,fun (,buffer ,type) ,@body))
151       (dolist (,str ',(mapcar #'string-downcase type-list))
152         (setf (cdr (or (assoc ,str *file-type-hooks*  :test #'string=)
153                        (car (push (cons ,str nil) *file-type-hooks*))))
154               #',fun)))))
156(define-file-type-hook ("pas" "pasmac" "macro" "defs" "spc" "bdy")
157                       (buffer type)
158  (declare (ignore type))
159  (setf (buffer-major-mode buffer) "Pascal"))
161(define-file-type-hook ("lisp" "slisp" "l" "lsp" "mcl" "cl") (buffer type)
162  (declare (ignore type))
163  (setf (buffer-major-mode buffer) "Lisp"))
165(define-file-type-hook ("txt" "text" "tx") (buffer type)
166  (declare (ignore type))
167  (setf (buffer-major-mode buffer) "Text"))
171;;;; Support for file hacking commands:
173(defhvar "Pathname Defaults"
174  "This variable contains a pathname which is used to supply defaults
175   when we don't have anything better."
176  :value (pathname "gazonk.del"))
178(defhvar "Last Resort Pathname Defaults"
179  "This variable contains a pathname which is used to supply defaults when
180   we don't have anything better, but unlike \"Pathname Defaults\", this is
181   never set to some buffer's pathname."
182  :value (pathname "gazonk"))
184(defhvar "Last Resort Pathname Defaults Function"
185  "This variable contains a function that is called when a default pathname is
186   needed, the buffer has no pathname, and the buffer's name is not entirely
187   composed of alphanumerics.  The default value is a function that simply
188   returns \"Last Resort Pathname Defaults\".  The function must take a buffer
189   as an argument, and it must return some pathname."
190  :value #'(lambda (buffer)
191             (declare (ignore buffer))
192             (merge-pathnames (value last-resort-pathname-defaults)
193                              (value pathname-defaults))))
195(defun buffer-default-pathname (buffer)
196  "Returns \"Buffer Pathname\" if it is bound.  If it is not, and buffer's name
197   is composed solely of alphnumeric characters, then return a pathname formed
198   from the buffer's name.  If the buffer's name has other characters in it,
199   then return the value of \"Last Resort Pathname Defaults Function\" called
200   on buffer."
201  (or (buffer-pathname buffer)
202      (if (every #'alphanumericp (the simple-string (buffer-name buffer)))
203          (merge-pathnames (make-pathname :name (buffer-name buffer))
204                           (value pathname-defaults))
205          (funcall (value last-resort-pathname-defaults-function) buffer))))
208(defun pathname-to-buffer-name (pathname)
209  "Returns a simple-string using components from pathname."
210  (let ((pathname (pathname pathname)))
211    (concatenate 'simple-string
212                 (file-namestring pathname)
213                 " "
214                 (directory-namestring pathname))))
218;;;; File hacking commands.
220(defcommand "Process File Options" (p)
221  "Reprocess this buffer's file options."
222  "Reprocess this buffer's file options."
223  (declare (ignore p))
224  (process-file-options))
226(defcommand "Ensure File Options Line" (p)
227  "Insert a default file options line at the beginning of the buffer, unless such a line already exists."
228  "Insert a default file options line at the beginning of the buffer, unless such a line already exists."
229  (declare (ignore p))
230  (let* ((buffer (current-buffer))
231         (string
232          (line-string (mark-line (buffer-start-mark buffer))))
233         (found (search "-*-" string))
234         (end (if found (search "-*-" string :start2 (+ found 3)))))
235    (unless end
236      (let* ((mode (buffer-major-mode buffer)))
237        (unless mode
238          ;; Try to derive the buffer's major mode from its pathname's
239          ;; type.
240          (let* ((pathname (buffer-pathname buffer))
241                 (type (if pathname (pathname-type pathname)))
242                 (hook (if type
243                         (assoc (string-downcase type) *file-type-hooks*
244                                :test #'string=))))
245            (when hook
246              (funcall (cdr hook) buffer type)
247              (setq mode (buffer-major-mode buffer)))))
248        (with-mark ((mark (buffer-start-mark buffer) :left-inserting))
249          (if (string-equal mode "Lisp")
250            (let* ((package-name
251                    (if (hemlock-bound-p 'current-package :buffer buffer)
252                      (variable-value 'hemlock::current-package
253                                      :buffer buffer)
254                      "CL-USER"))
255                   (encoding-string (let* ((string (hemlock-ext:buffer-encoding-name buffer))
256                                           (suffix (case (hi::buffer-line-termination buffer)
257                                                     (:cr "mac")
258                                                     (:crlf "dos"))))
259                                      (if suffix
260                                        (concatenate 'string string "-" suffix)
261                                        string))))
262              (insert-string
263               mark
264               (format nil ";;; -*- Mode: Lisp; Package: ~a; Coding: ~a; -*-" package-name encoding-string)))
265            (insert-string
266             mark
267             (format nil ";;; -*- Mode: ~a -*-" (or mode "Fundamental"))))
268          (insert-character mark #\NewLine))))
269    (buffer-start (buffer-point buffer))))
283(defcommand "Insert File" (p &optional pathname (buffer (current-buffer)))
284  "Inserts a file which is prompted for into the current buffer at the point.
285  The prefix argument is ignored."
286  "Inserts the file named by Pathname into Buffer at the point."
287  (declare (ignore p))
288  (let* ((pn (or pathname
289                 (prompt-for-file :default (buffer-default-pathname buffer)
290                                  :prompt "Insert File: "
291                                  :help "Name of file to insert")))
292         (point (buffer-point buffer))
293         ;; start and end will be deleted by undo stuff
294         (start (copy-mark point :right-inserting))
295         (end (copy-mark point :left-inserting))
296         (region (region start end)))
297    (setv pathname-defaults pn)
298    (push-new-buffer-mark end)
299    (read-file pn end)
300    (make-region-undo :delete "Insert File" region)))
302(defcommand "Write Region" (p &optional pathname)
303  "Writes the current region to a file. "
304  "Writes the current region to a file. "
305  (declare (ignore p))
306  (let ((region (current-region))
307        (pn (or pathname
308                (prompt-for-file :prompt "File to Write: "
309                                 :help "The name of the file to write the region to. "
310                                 :default (buffer-default-pathname
311                                           (current-buffer))
312                                 :must-exist nil))))
313    (write-file region pn)
314    (message "~A written." (namestring (truename pn)))))
318;;;; Visiting and reverting files.
320#+No  ;; Dubious semantics in a document-centered model. Also, doesn't work, see bug #476.
321(defcommand "Visit File" (p &optional pathname (buffer (current-buffer)))
322  "Replaces the contents of Buffer with the file Pathname.  The prefix
323   argument is ignored.  The buffer is set to be writable, so its region
324   can be deleted."
325  "Replaces the contents of the current buffer with the text in the file
326   which is prompted for.  The prefix argument is, of course, ignored p times."
327  (declare (ignore p))
328  (when (and (buffer-modified buffer)
329             (prompt-for-y-or-n :prompt "Buffer is modified, save it? "))
330    (save-file-command () buffer))
331  (let ((pn (or pathname
332                (prompt-for-file :prompt "Visit File: "
333                                 :must-exist nil
334                                 :help "Name of file to visit."
335                                 :default (buffer-default-pathname buffer)))))
336    (setf (buffer-writable buffer) t)
337    (read-buffer-file pn buffer)
338    (let ((n (pathname-to-buffer-name (buffer-pathname buffer))))
339      (unless (getstring n *buffer-names*)
340        (setf (buffer-name buffer) n))
341      (warn-about-visit-file-buffers buffer))))
343(defun warn-about-visit-file-buffers (buffer)
344  (let ((buffer-pn (buffer-pathname buffer)))
345    (dolist (b *buffer-list*)
346      (unless (eq b buffer)
347        (let ((bpn (buffer-pathname b)))
348          (when (equal bpn buffer-pn)
349            (loud-message "Buffer ~A also contains ~A."
350                          (buffer-name b) (namestring buffer-pn))
351            (return)))))))
354(defhvar "Revert File Confirm"
355  "If this is true, Revert File will prompt before reverting."
356  :value t)
358(defcommand "Revert File" (p)
359  "Unless in Save Mode, reads in the last saved version of the file in
360   the current buffer. When in Save Mode, reads in the last checkpoint or
361   the last saved version, whichever is more recent. An argument will always
362   force Revert File to use the last saved version. In either case, if the
363   buffer has been modified and \"Revert File Confirm\" is true, then Revert
364   File will ask for confirmation beforehand. An attempt is made to maintain
365   the point's relative position."
366  "With an argument reverts to the last saved version of the file in the
367   current buffer. Without, reverts to the last checkpoint or last saved
368   version, whichever is more recent."
369  (declare (ignore p))
370  (hemlock-ext:revert-hemlock-buffer (current-buffer))
371  (clear-echo-area))
374;;;; Find file.
377(defcommand "Find File" (p)
378  "Visit a file in its own buffer.
379   If the file is already in some buffer, select that buffer,
380   otherwise make a new buffer with the same name as the file and
381   read the file into it."
382  (declare (ignore p))
383  (hi::allowing-buffer-display ((current-buffer))
384    (hemlock-ext:open-hemlock-buffer :pathname :prompt)))
388(defun find-file-buffer (pathname)
389  "Return a buffer associated with the file Pathname, reading the file into a
390   new buffer if necessary.  The second value is T if we created a buffer, NIL
391   otherwise.  If the file has already been read, we check to see if the file
392   has been modified on disk since it was read, giving the user various
393   recovery options."
394  (let* ((pathname (pathname pathname))
395         (trial-pathname (or (probe-file pathname)
396                             (merge-pathnames pathname (default-directory))))
397         (found (find trial-pathname (the list *buffer-list*)
398                     :key #'buffer-pathname :test #'equal)))
399    (cond ((not found)
400           (if (and (null (pathname-name trial-pathname))
401                    (null (pathname-type trial-pathname))
402                    (pathname-directory trial-pathname))
403               ;; This looks like a directory -- make dired buffer
404               (dired-guts nil nil trial-pathname)
406               (let* ((name (pathname-to-buffer-name trial-pathname))
407                      (found (getstring name *buffer-names*))
408                      (use (if found
409                               (prompt-for-buffer
410                                :prompt "Buffer to use: "
411                                :help
412                                "Buffer name in use; give another buffer name, or confirm to reuse."
413                                :default found
414                                :must-exist nil)
415                               (make-buffer name)))
416                      (buffer (if (stringp use) (make-buffer use) use)))
417                 (when (and (buffer-modified buffer)
418                            (prompt-for-y-or-n :prompt
419                                               "Buffer is modified, save it? "))
420                   (save-file-command () buffer))
421                 (read-buffer-file pathname buffer)
422                 (values buffer (stringp use)))))
423          ((check-disk-version-consistent pathname found)
424           (values found nil))
425          (t
426           (read-buffer-file pathname found)
427           (values found nil)))))
430;;; Check-Disk-Version-Consistent  --  Internal
432;;;    Check that Buffer contains a valid version of the file Pathname,
433;;; harrassing the user if not.  We return true if the buffer is O.K., and
434;;; false if the file should be read.
436(defun check-disk-version-consistent (pathname buffer)
437  (let ((ndate (file-write-date pathname))
438        (odate (buffer-write-date buffer)))
439    (cond ((not (and ndate odate (/= ndate odate)))
440           t)
441          ((buffer-modified buffer)
442           (beep)
443           (clear-input)
444           (command-case (:prompt (list
445 "File has been changed on disk since it was read and you have made changes too!~
446 ~%Read in the disk version of ~A? [Y] " (namestring pathname))
447                          :help
448 "The file in disk has been changed since Hemlock last saved it, meaning that
449 someone else has probably overwritten it.  Since the version read into Hemlock
450 has been changed as well, the two versions may have inconsistent changes.  If
451 this is the case, it would be a good idea to save your changes in another file
452 and compare the two versions.
454 Type one of the following commands:")
455             ((:confirm :yes)
456 "Prompt for a file to write the buffer out to, then read in the disk version."
457              (write-buffer-file
458               buffer
459               (prompt-for-file
460                :prompt "File to save changes in: "
461                :help (list "Save buffer ~S to this file before reading ~A."
462                            (buffer-name buffer) (namestring pathname))
463                :must-exist nil
464                :default (buffer-default-pathname buffer)))
465              nil)
466             (:no
467              "Change to the buffer without reading the new version."
468              t)
469             (#\r
470              "Read in the new version, clobbering the changes in the buffer."
471              nil)))
472           (t
473            (not (prompt-for-yes-or-no :prompt
474                                       (list
475 "File has been changed on disk since it was read.~
476 ~%Read in the disk version of ~A? "
477                                        (namestring pathname))
478                                       :help
479 "Type Y to read in the new version or N to just switch to the buffer."
480                                       :default t))))))
483(defhvar "Read File Hook"
484  "These functions are called when a file is read into a buffer.  Each function
485   must take two arguments -- the buffer the file was read into and whether the
486   file existed (non-nil) or not (nil).")
488(defun read-buffer-file (pathname buffer)
489  "Delete the buffer's region, and uses READ-FILE to read pathname into it.
490   If the file exists, set the buffer's write date to the file's; otherwise,
491   MESSAGE that this is a new file and set the buffer's write date to nil.
492   Move buffer's point to the beginning, set the buffer unmodified.  If the
493   file exists, set the buffer's pathname to the probed pathname; else, set it
494   to pathname merged with DEFAULT-DIRECTORY.  Set \"Pathname Defaults\" to the
495   same thing.  Process the file options, and then invoke \"Read File Hook\"."
496  (setf (buffer-writable buffer) t)
497  (delete-region (buffer-region buffer))
498  (let* ((pathname (pathname pathname))
499         (probed-pathname (probe-file pathname))
500         (hi::*current-buffer* buffer))
501    (cond (probed-pathname
502           (read-file probed-pathname (buffer-point buffer))
503           (setf (buffer-write-date buffer) (file-write-date probed-pathname)))
504          (t
505           (message "(New File)")
506           (setf (buffer-write-date buffer) nil)))
507    (buffer-start (buffer-point buffer))
508    (setf (buffer-modified buffer) nil)
509    (let ((stored-pathname (or probed-pathname
510                               (merge-pathnames pathname (default-directory)))))
511      (setf (buffer-pathname buffer) stored-pathname)
512      (setf (value pathname-defaults) stored-pathname)
513      (process-file-options buffer stored-pathname)
514      (invoke-hook read-file-hook buffer probed-pathname))))
518;;;; File writing.
520(defhvar "Add Newline at EOF on Writing File"
521  "This controls whether WRITE-BUFFER-FILE adds a newline at the end of the
522   file when it ends at the end of a non-empty line.  When set, this may be
523   :ask-user and WRITE-BUFFER-FILE will prompt; otherwise, just add one and
524   inform the user.  When nil, never add one and don't ask."
525  :value :ask-user)
527(defhvar "Keep Backup Files"
528  "When set, .BAK files will be saved upon file writing.  This defaults to nil."
529  :value nil)
531(defhvar "Write File Hook"
532  "These functions are called when a buffer has been written.  Each function
533   must take the buffer as an argument.")
535(defun write-buffer-file (buffer pathname)
536  "Write's buffer to pathname.  This assumes pathname is somehow related to
537   the buffer's pathname, and if the buffer's write date is not the same as
538   pathname's, then this prompts the user for confirmation before overwriting
539   the file.  This consults \"Add Newline at EOF on Writing File\" and
540   interacts with the user if necessary.  This sets \"Pathname Defaults\", and
541   the buffer is marked unmodified.  The buffer's pathname and write date are
542   updated, and the buffer is renamed according to the new pathname if possible.
543   This invokes \"Write File Hook\"."
544  (let ((buffer-pn (buffer-pathname buffer)))
545    (let ((date (buffer-write-date buffer))
546          (file-date (when (probe-file pathname) (file-write-date pathname))))
547      (when (and buffer-pn date file-date
548                 (equal (make-pathname :version nil :defaults buffer-pn)
549                        (make-pathname :version nil :defaults pathname))
550                 (/= date file-date))
551        (unless (prompt-for-yes-or-no :prompt (list
552 "File has been changed on disk since it was read.~%Overwrite ~A anyway? "
553 (namestring buffer-pn))
554                                      :help
555                                      "Type No to abort writing the file or Yes to overwrite the disk version."
556                                      :default nil)
557          (editor-error "Write aborted."))))
558    (let ((val (value add-newline-at-eof-on-writing-file)))
559      (when val
560        (let ((end (buffer-end-mark buffer)))
561          (unless (start-line-p end)
562            (when (if (eq val :ask-user)
563                      (prompt-for-y-or-n
564                       :prompt
565                       (list "~A~%File does not have a newline at EOF, add one? "
566                             (buffer-name buffer))
567                       :default t)
568                      t)
569              (insert-character end #\newline)
570              (message "Added newline at EOF."))))))
571    (setv pathname-defaults pathname)
572    (write-file (buffer-region buffer) pathname)
573    (let ((tn (truename pathname)))
574      (message "~A written." (namestring tn))
575      (setf (buffer-modified buffer) nil)
576      (unless (equal tn buffer-pn)
577        (setf (buffer-pathname buffer) tn))
578      (setf (buffer-write-date buffer) (file-write-date tn))
579      (let ((name (pathname-to-buffer-name tn)))
580        (unless (getstring name *buffer-names*)
581          (setf (buffer-name buffer) name)))))
582  (invoke-hook write-file-hook buffer))
584(defcommand "Write File" (p &optional (buffer (current-buffer)))
585  "Prompts for a filename, changes the buffer pathname to it and saves it.
586  The prefix argument is ignored."
587  (declare (ignore p))
588  (hemlock-ext:save-hemlock-buffer buffer :pathname :prompt))
590(defcommand "Save To File" (p &optional (buffer (current-buffer)))
591  "Prompts for a filename and writes a copy of the buffer to it.  Buffer's
592   pathname (and modified state) is unchanged.
593  The prefix argument is ignored."
594  (declare (ignore p))
595  (hemlock-ext:save-hemlock-buffer buffer :pathname :prompt :copy t))
597(defcommand "Save File" (p &optional (buffer (current-buffer)))
598  "Writes the contents of the current buffer to the associated file.  If there
599  is no associated file, one is prompted for."
600  "Writes the contents of the current buffer to the associated file."
601  (declare (ignore p))
602  (when (buffer-modified buffer)
603    (hemlock-ext:save-hemlock-buffer buffer)))
605(defhvar "Save All Files Confirm"
606  "When non-nil, prompts for confirmation before writing each modified buffer."
607  :value t)
609(defcommand "Save All Files" (p)
610  "Saves all modified buffers in their associated files.
611  If a buffer has no associated file it is ignored even if it is modified.."
612  "Saves each modified buffer that has a file."
613  (declare (ignore p))
614  (let ((saved-count 0))
615    (dolist (b *buffer-list*)
616      (let ((pn (buffer-pathname b))
617            (name (buffer-name b)))
618        (when
619            (and (buffer-modified b)
620                 pn
621                 (or (not (value save-all-files-confirm))
622                     (prompt-for-y-or-n
623                      :prompt (list
624                               "Write ~:[buffer ~A as file ~S~;file ~*~S~], ~
625                               Y or N: "
626                               (string= (pathname-to-buffer-name pn) name)
627                               name (namestring pn))
628                      :default t)))
629          (write-buffer-file b pn)
630          (incf saved-count))))
631    (if (zerop saved-count)
632        (message "No files were saved.")
633        (message "Saved ~S file~:P." saved-count))))
635(defcommand "Backup File" (p)
636  "Write the buffer to a file without changing the associated name."
637  "Write the buffer to a file without changing the associated name."
638  (declare (ignore p))
639  (let ((file (prompt-for-file :prompt "Backup to File: "
640                               :help
641 "Name of a file to backup the current buffer in."
642                               :default (buffer-default-pathname (current-buffer))
643                               :must-exist nil)))
644    (write-file (buffer-region (current-buffer)) file)
645    (message "~A written." (namestring (truename file)))))
649;;;; Buffer hacking commands:
652(defcommand "Buffer Not Modified" (p)
653  "Make the current buffer not modified."
654  "Make the current buffer not modified."
655  (declare (ignore p))
656  (setf (buffer-modified (current-buffer)) nil)
657  (message "Buffer marked as unmodified."))
661(defcommand "Set Buffer Read-Only" (p)
662  "Toggles the read-only flag for the current buffer."
663  "Toggles the read-only flag for the current buffer."
664  (declare (ignore p))
665  (let ((buffer (current-buffer)))
666    (message "Buffer ~S is now ~:[read-only~;writable~]."
667             (buffer-name buffer)
668             (setf (buffer-writable buffer) (not (buffer-writable buffer))))))
670(defcommand "Set Buffer Writable" (p)
671  "Make the current buffer modifiable."
672  "Make the current buffer modifiable."
673  (declare (ignore p))
674  (let ((buffer (current-buffer)))
675    (setf (buffer-writable buffer) t)
676    (message "Buffer ~S is now writable." (buffer-name buffer))))
Note: See TracBrowser for help on using the repository browser.