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

Last change on this file since 12859 was 12859, checked in by gz, 10 years ago

Make sure that all hemlock functions defined outside of hemlock are in the hemlock-ext package, to make it easier to keep track of them

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