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

Last change on this file since 14734 was 14734, checked in by gz, 8 years ago

Add "Insert Date and Time" and "Insert Date", bind the former to c-x c-d. Also bind c-S and c-R same as c-s and c-r, respectively, and bind c-= to "What Cursor Position"

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