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

Last change on this file since 12234 was 12234, checked in by gb, 10 years ago

Use ALLOWING-BUFFER-DISPLAY in "Find File"; may need to use it elsewhere,too.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 25.4 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(defcommand "Visit File" (p &optional pathname (buffer (current-buffer)))
303  "Replaces the contents of Buffer with the file Pathname.  The prefix
304   argument is ignored.  The buffer is set to be writable, so its region
305   can be deleted."
306  "Replaces the contents of the current buffer with the text in the file
307   which is prompted for.  The prefix argument is, of course, ignored p times."
308  (declare (ignore p))
309  (when (and (buffer-modified buffer)
310             (prompt-for-y-or-n :prompt "Buffer is modified, save it? "))
311    (save-file-command () buffer))
312  (let ((pn (or pathname
313                (prompt-for-file :prompt "Visit File: "
314                                 :must-exist nil
315                                 :help "Name of file to visit."
316                                 :default (buffer-default-pathname buffer)))))
317    (setf (buffer-writable buffer) t)
318    (read-buffer-file pn buffer)
319    (let ((n (pathname-to-buffer-name (buffer-pathname buffer))))
320      (unless (getstring n *buffer-names*)
321        (setf (buffer-name buffer) n))
322      (warn-about-visit-file-buffers buffer))))
323
324(defun warn-about-visit-file-buffers (buffer)
325  (let ((buffer-pn (buffer-pathname buffer)))
326    (dolist (b *buffer-list*)
327      (unless (eq b buffer)
328        (let ((bpn (buffer-pathname b)))
329          (when (equal bpn buffer-pn)
330            (loud-message "Buffer ~A also contains ~A."
331                          (buffer-name b) (namestring buffer-pn))
332            (return)))))))
333
334
335(defhvar "Revert File Confirm"
336  "If this is true, Revert File will prompt before reverting."
337  :value t)
338
339(defcommand "Revert File" (p)
340  "Unless in Save Mode, reads in the last saved version of the file in
341   the current buffer. When in Save Mode, reads in the last checkpoint or
342   the last saved version, whichever is more recent. An argument will always
343   force Revert File to use the last saved version. In either case, if the
344   buffer has been modified and \"Revert File Confirm\" is true, then Revert
345   File will ask for confirmation beforehand. An attempt is made to maintain
346   the point's relative position."
347  "With an argument reverts to the last saved version of the file in the
348   current buffer. Without, reverts to the last checkpoint or last saved
349   version, whichever is more recent."
350  (declare (ignore p))
351  (let* ((doc (hi::buffer-document (current-buffer))))
352    (when doc
353      (hi::revert-document doc)))
354  (clear-echo-area))
355
356
357;;;; Find file.
358
359
360(defcommand "Find File" (p)
361  "Visit a file in its own buffer.
362   If the file is already in some buffer, select that buffer,
363   otherwise make a new buffer with the same name as the file and
364   read the file into it."
365  (declare (ignore p))
366  (hi::allowing-buffer-display ((current-buffer))
367    (hi::open-document)))
368 
369
370#|
371(defun find-file-buffer (pathname)
372  "Return a buffer associated with the file Pathname, reading the file into a
373   new buffer if necessary.  The second value is T if we created a buffer, NIL
374   otherwise.  If the file has already been read, we check to see if the file
375   has been modified on disk since it was read, giving the user various
376   recovery options."
377  (let* ((pathname (pathname pathname))
378         (trial-pathname (or (probe-file pathname)
379                             (merge-pathnames pathname (default-directory))))
380         (found (find trial-pathname (the list *buffer-list*)
381                     :key #'buffer-pathname :test #'equal)))
382    (cond ((not found)
383           (if (and (null (pathname-name trial-pathname))
384                    (null (pathname-type trial-pathname))
385                    (pathname-directory trial-pathname))
386               ;; This looks like a directory -- make dired buffer
387               (dired-guts nil nil trial-pathname)
388
389               (let* ((name (pathname-to-buffer-name trial-pathname))
390                      (found (getstring name *buffer-names*))
391                      (use (if found
392                               (prompt-for-buffer
393                                :prompt "Buffer to use: "
394                                :help
395                                "Buffer name in use; give another buffer name, or confirm to reuse."
396                                :default found
397                                :must-exist nil)
398                               (make-buffer name)))
399                      (buffer (if (stringp use) (make-buffer use) use)))
400                 (when (and (buffer-modified buffer)
401                            (prompt-for-y-or-n :prompt
402                                               "Buffer is modified, save it? "))
403                   (save-file-command () buffer))
404                 (read-buffer-file pathname buffer)
405                 (values buffer (stringp use)))))
406          ((check-disk-version-consistent pathname found)
407           (values found nil))
408          (t
409           (read-buffer-file pathname found)
410           (values found nil)))))
411|#
412
413;;; Check-Disk-Version-Consistent  --  Internal
414;;;
415;;;    Check that Buffer contains a valid version of the file Pathname,
416;;; harrassing the user if not.  We return true if the buffer is O.K., and
417;;; false if the file should be read.
418;;;
419(defun check-disk-version-consistent (pathname buffer)
420  (let ((ndate (file-write-date pathname))
421        (odate (buffer-write-date buffer)))
422    (cond ((not (and ndate odate (/= ndate odate)))
423           t)
424          ((buffer-modified buffer)
425           (beep)
426           (clear-input)
427           (command-case (:prompt (list
428 "File has been changed on disk since it was read and you have made changes too!~
429 ~%Read in the disk version of ~A? [Y] " (namestring pathname))
430                          :help
431 "The file in disk has been changed since Hemlock last saved it, meaning that
432 someone else has probably overwritten it.  Since the version read into Hemlock
433 has been changed as well, the two versions may have inconsistent changes.  If
434 this is the case, it would be a good idea to save your changes in another file
435 and compare the two versions.
436 
437 Type one of the following commands:")
438             ((:confirm :yes)
439 "Prompt for a file to write the buffer out to, then read in the disk version."
440              (write-buffer-file
441               buffer
442               (prompt-for-file
443                :prompt "File to save changes in: "
444                :help (list "Save buffer ~S to this file before reading ~A."
445                            (buffer-name buffer) (namestring pathname))
446                :must-exist nil
447                :default (buffer-default-pathname buffer)))
448              nil)
449             (:no
450              "Change to the buffer without reading the new version."
451              t)
452             (#\r
453              "Read in the new version, clobbering the changes in the buffer."
454              nil)))
455           (t
456            (not (prompt-for-yes-or-no :prompt
457                                       (list
458 "File has been changed on disk since it was read.~
459 ~%Read in the disk version of ~A? "
460                                        (namestring pathname))
461                                       :help
462 "Type Y to read in the new version or N to just switch to the buffer."
463                                       :default t))))))
464
465
466(defhvar "Read File Hook"
467  "These functions are called when a file is read into a buffer.  Each function
468   must take two arguments -- the buffer the file was read into and whether the
469   file existed (non-nil) or not (nil).")
470
471(defun read-buffer-file (pathname buffer)
472  "Delete the buffer's region, and uses READ-FILE to read pathname into it.
473   If the file exists, set the buffer's write date to the file's; otherwise,
474   MESSAGE that this is a new file and set the buffer's write date to nil.
475   Move buffer's point to the beginning, set the buffer unmodified.  If the
476   file exists, set the buffer's pathname to the probed pathname; else, set it
477   to pathname merged with DEFAULT-DIRECTORY.  Set \"Pathname Defaults\" to the
478   same thing.  Process the file options, and then invoke \"Read File Hook\"."
479  (setf (buffer-writable buffer) t)
480  (delete-region (buffer-region buffer))
481  (let* ((pathname (pathname pathname))
482         (probed-pathname (probe-file pathname))
483         (hi::*current-buffer* buffer))
484    (cond (probed-pathname
485           (read-file probed-pathname (buffer-point buffer))
486           (setf (buffer-write-date buffer) (file-write-date probed-pathname)))
487          (t
488           (message "(New File)")
489           (setf (buffer-write-date buffer) nil)))
490    (buffer-start (buffer-point buffer))
491    (setf (buffer-modified buffer) nil)
492    (let ((stored-pathname (or probed-pathname
493                               (merge-pathnames pathname (default-directory)))))
494      (setf (buffer-pathname buffer) stored-pathname)
495      (setf (value pathname-defaults) stored-pathname)
496      (process-file-options buffer stored-pathname)
497      (invoke-hook read-file-hook buffer probed-pathname))))
498
499
500
501;;;; File writing.
502
503(defhvar "Add Newline at EOF on Writing File"
504  "This controls whether WRITE-BUFFER-FILE adds a newline at the end of the
505   file when it ends at the end of a non-empty line.  When set, this may be
506   :ask-user and WRITE-BUFFER-FILE will prompt; otherwise, just add one and
507   inform the user.  When nil, never add one and don't ask."
508  :value :ask-user)
509
510(defhvar "Keep Backup Files"
511  "When set, .BAK files will be saved upon file writing.  This defaults to nil."
512  :value nil)
513
514(defhvar "Write File Hook"
515  "These functions are called when a buffer has been written.  Each function
516   must take the buffer as an argument.")
517
518(defun write-buffer-file (buffer pathname)
519  "Write's buffer to pathname.  This assumes pathname is somehow related to
520   the buffer's pathname, and if the buffer's write date is not the same as
521   pathname's, then this prompts the user for confirmation before overwriting
522   the file.  This consults \"Add Newline at EOF on Writing File\" and
523   interacts with the user if necessary.  This sets \"Pathname Defaults\", and
524   the buffer is marked unmodified.  The buffer's pathname and write date are
525   updated, and the buffer is renamed according to the new pathname if possible.
526   This invokes \"Write File Hook\"."
527  (let ((buffer-pn (buffer-pathname buffer)))
528    (let ((date (buffer-write-date buffer))
529          (file-date (when (probe-file pathname) (file-write-date pathname))))
530      (when (and buffer-pn date file-date
531                 (equal (make-pathname :version nil :defaults buffer-pn)
532                        (make-pathname :version nil :defaults pathname))
533                 (/= date file-date))
534        (unless (prompt-for-yes-or-no :prompt (list
535 "File has been changed on disk since it was read.~%Overwrite ~A anyway? "
536 (namestring buffer-pn))
537                                      :help
538                                      "Type No to abort writing the file or Yes to overwrite the disk version."
539                                      :default nil)
540          (editor-error "Write aborted."))))
541    (let ((val (value add-newline-at-eof-on-writing-file)))
542      (when val
543        (let ((end (buffer-end-mark buffer)))
544          (unless (start-line-p end)
545            (when (if (eq val :ask-user)
546                      (prompt-for-y-or-n
547                       :prompt
548                       (list "~A~%File does not have a newline at EOF, add one? "
549                             (buffer-name buffer))
550                       :default t)
551                      t)
552              (insert-character end #\newline)
553              (message "Added newline at EOF."))))))
554    (setv pathname-defaults pathname)
555    (write-file (buffer-region buffer) pathname)
556    (let ((tn (truename pathname)))
557      (message "~A written." (namestring tn))
558      (setf (buffer-modified buffer) nil)
559      (unless (equal tn buffer-pn)
560        (setf (buffer-pathname buffer) tn))
561      (setf (buffer-write-date buffer) (file-write-date tn))
562      (let ((name (pathname-to-buffer-name tn)))
563        (unless (getstring name *buffer-names*)
564          (setf (buffer-name buffer) name)))))
565  (invoke-hook write-file-hook buffer))
566 
567(defcommand "Write File" (p &optional (buffer (current-buffer)))
568  "Writes the contents of Buffer, which defaults to the current buffer to
569  the file named by Pathname.  The prefix argument is ignored."
570  "Prompts for a file to write the contents of the current Buffer to.
571  The prefix argument is ignored."
572  (declare (ignore p))
573  (let* ((document (hi::buffer-document buffer)))
574    (when document
575      (hi::save-hemlock-document-as document))))
576
577(defcommand "Save To File" (p &optional (buffer (current-buffer)))
578  "Writes the contents of Buffer, which defaults to the current buffer to
579  the file named by Pathname.  The prefix argument is ignored."
580  "Prompts for a file to write the contents of the current Buffer to.
581  The prefix argument is ignored."
582  (declare (ignore p))
583  (let* ((document (hi::buffer-document buffer)))
584    (when document
585      (hi::save-hemlock-document-to document))))
586
587(defcommand "Save File" (p &optional (buffer (current-buffer)))
588  "Writes the contents of the current buffer to the associated file.  If there
589  is no associated file, one is prompted for."
590  "Writes the contents of the current buffer to the associated file."
591  (declare (ignore p))
592  (when (buffer-modified buffer)
593    (let* ((document (hi::buffer-document buffer)))
594      (when document
595        (hi::save-hemlock-document document)))))
596
597(defhvar "Save All Files Confirm"
598  "When non-nil, prompts for confirmation before writing each modified buffer."
599  :value t)
600
601(defcommand "Save All Files" (p)
602  "Saves all modified buffers in their associated files.
603  If a buffer has no associated file it is ignored even if it is modified.."
604  "Saves each modified buffer that has a file."
605  (declare (ignore p))
606  (let ((saved-count 0))
607    (dolist (b *buffer-list*)
608      (let ((pn (buffer-pathname b))
609            (name (buffer-name b)))
610        (when
611            (and (buffer-modified b)
612                 pn
613                 (or (not (value save-all-files-confirm))
614                     (prompt-for-y-or-n
615                      :prompt (list
616                               "Write ~:[buffer ~A as file ~S~;file ~*~S~], ~
617                               Y or N: "
618                               (string= (pathname-to-buffer-name pn) name)
619                               name (namestring pn))
620                      :default t)))
621          (write-buffer-file b pn)
622          (incf saved-count))))
623    (if (zerop saved-count)
624        (message "No files were saved.")
625        (message "Saved ~S file~:P." saved-count))))
626
627(defcommand "Backup File" (p)
628  "Write the buffer to a file without changing the associated name."
629  "Write the buffer to a file without changing the associated name."
630  (declare (ignore p))
631  (let ((file (prompt-for-file :prompt "Backup to File: "
632                               :help
633 "Name of a file to backup the current buffer in."
634                               :default (buffer-default-pathname (current-buffer))
635                               :must-exist nil)))
636    (write-file (buffer-region (current-buffer)) file)
637    (message "~A written." (namestring (truename file)))))
638
639
640
641;;;; Buffer hacking commands:
642
643
644(defcommand "Buffer Not Modified" (p)
645  "Make the current buffer not modified."
646  "Make the current buffer not modified."
647  (declare (ignore p))
648  (setf (buffer-modified (current-buffer)) nil)
649  (message "Buffer marked as unmodified."))
650
651
652
653(defcommand "Set Buffer Read-Only" (p)
654  "Toggles the read-only flag for the current buffer."
655  "Toggles the read-only flag for the current buffer."
656  (declare (ignore p))
657  (let ((buffer (current-buffer)))
658    (message "Buffer ~S is now ~:[read-only~;writable~]."
659             (buffer-name buffer)
660             (setf (buffer-writable buffer) (not (buffer-writable buffer))))))
661
662(defcommand "Set Buffer Writable" (p)
663  "Make the current buffer modifiable."
664  "Make the current buffer modifiable."
665  (declare (ignore p))
666  (let ((buffer (current-buffer)))
667    (setf (buffer-writable buffer) t)
668    (message "Buffer ~S is now writable." (buffer-name buffer))))
669
670
671
672
673(defun universal-time-to-string (ut)
674  (multiple-value-bind (sec min hour day month year)
675                       (decode-universal-time ut)
676    (format nil "~2,'0D-~A-~2,'0D ~2,'0D:~2,'0D:~2,'0D"
677            day (svref '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug"
678                          "Sep" "Oct" "Nov" "Dec")
679                       (1- month))
680            (rem year 100)
681            hour min sec)))
Note: See TracBrowser for help on using the repository browser.