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
succeeds:

  • 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
Line 
1;;; -*- Package: Hemlock; Log: hemlock.log -*-
2;;;
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.
6;;;
7#+CMU (ext:file-comment
8  "$Header$")
9;;;
10;;; **********************************************************************
11;;;
12;;; This file contains file/buffer manipulating commands.
13;;;
14
15(in-package :hemlock)
16
17
18
19;;;; PROCESS-FILE-OPTIONS.
20
21(defvar *mode-option-handlers* ()
22  "Do not modify this; use Define-File-Option instead.")
23
24(defvar *file-type-hooks* ()
25  "Do not modify this; use Define-File-Type-Hook instead.") 
26
27(defun trim-subseq (string start end)
28  (declare (simple-string string))
29  (string-trim '(#\Space #\Tab) (subseq string start end)))
30
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.
36;;;
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.
41;;;
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))))))
92
93
94
95;;;; File options and file type hooks.
96
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))))
106
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))))))
128
129(define-file-option "log" (buffer string)
130  (declare (ignore buffer string)))
131
132(define-file-option "base" (buffer string)
133  (declare (ignore buffer string)))
134
135(define-file-option "syntax" (buffer string)
136  (declare (ignore buffer string)))
137
138(define-file-option "coding" (buffer string)
139  (hemlock-ext:set-buffer-external-format buffer string))
140
141
142
143
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)))))
155
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"))
160
161(define-file-type-hook ("lisp" "slisp" "l" "lsp" "mcl" "cl") (buffer type)
162  (declare (ignore type))
163  (setf (buffer-major-mode buffer) "Lisp"))
164
165(define-file-type-hook ("txt" "text" "tx") (buffer type)
166  (declare (ignore type))
167  (setf (buffer-major-mode buffer) "Text"))
168
169
170
171;;;; Support for file hacking commands:
172
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"))
177
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"))
183
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))))
194
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))))
206
207
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))))
215
216
217
218;;;; File hacking commands.
219
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))
225
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))))
270   
271   
272                         
273                           
274           
275       
276           
277           
278         
279                 
280       
281 
282
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)))
301
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)))))
315
316
317
318;;;; Visiting and reverting files.
319
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))))
342
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)))))))
352
353
354(defhvar "Revert File Confirm"
355  "If this is true, Revert File will prompt before reverting."
356  :value t)
357
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))
372
373
374;;;; Find file.
375
376
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)))
385 
386
387#|
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)
405
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)))))
428|#
429
430;;; Check-Disk-Version-Consistent  --  Internal
431;;;
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.
435;;;
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.
453 
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))))))
481
482
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).")
487
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))))
515
516
517
518;;;; File writing.
519
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)
526
527(defhvar "Keep Backup Files"
528  "When set, .BAK files will be saved upon file writing.  This defaults to nil."
529  :value nil)
530
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.")
534
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))
583 
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))
589
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))
596
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)))
604
605(defhvar "Save All Files Confirm"
606  "When non-nil, prompts for confirmation before writing each modified buffer."
607  :value t)
608
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))))
634
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)))))
646
647
648
649;;;; Buffer hacking commands:
650
651
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."))
658
659
660
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))))))
669
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))))
677
Note: See TracBrowser for help on using the repository browser.