/[climacs]/climacs/file-commands.lisp
ViewVC logotype

Diff of /climacs/file-commands.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.10 by dmurray, Thu May 4 18:53:52 2006 UTC revision 1.11 by dmurray, Sat May 6 06:27:14 2006 UTC
# Line 212  Line 212 
212                 (switch-to-buffer existing-buffer)                 (switch-to-buffer existing-buffer)
213                 (let ((buffer (make-buffer))                 (let ((buffer (make-buffer))
214                       (pane (current-window)))                       (pane (current-window)))
215                   ;; Clear the panes cache; otherwise residue from the                   ;; Clear the pane's cache; otherwise residue from the
216                   ;; previously displayed buffer may under certain                   ;; previously displayed buffer may under certain
217                   ;; circumstances be displayed.                   ;; circumstances be displayed.
218                   (clear-cache pane)                   (clear-cache pane)
# Line 223  Line 223 
223                   (when (probe-file filepath)                   (when (probe-file filepath)
224                     (with-open-file (stream filepath :direction :input)                     (with-open-file (stream filepath :direction :input)
225                       (input-from-stream stream buffer 0))                       (input-from-stream stream buffer 0))
226                       (setf (file-write-time buffer) (file-write-date filepath))
227                     ;; A file! That means we may have a local options                     ;; A file! That means we may have a local options
228                     ;; line to parse.                     ;; line to parse.
229                     (evaluate-local-options-line buffer))                     (evaluate-local-options-line buffer))
# Line 242  Line 243 
243    
244  (defun directory-of-buffer (buffer)  (defun directory-of-buffer (buffer)
245    "Extract the directory part of the filepath to the file in BUFFER.    "Extract the directory part of the filepath to the file in BUFFER.
246     If BUFFER does not have a filepath, the path to the users home     If BUFFER does not have a filepath, the path to the user's home
247     directory will be returned."     directory will be returned."
248    (make-pathname    (make-pathname
249     :directory     :directory
# Line 324  When a buffer is readonly, attempts to c Line 325  When a buffer is readonly, attempts to c
325    
326  (defun set-visited-file-name (filename buffer)  (defun set-visited-file-name (filename buffer)
327    (setf (filepath buffer) filename    (setf (filepath buffer) filename
328            (file-saved-p buffer) nil
329            (file-write-time buffer) nil
330          (name buffer) (filepath-filename filename)          (name buffer) (filepath-filename filename)
331          (needs-saving buffer) t))          (needs-saving buffer) t))
332    
# Line 371  Signals an error if the file does not ex Line 374  Signals an error if the file does not ex
374             (display-message "~A is a directory name." filepath)             (display-message "~A is a directory name." filepath)
375             (beep))             (beep))
376            ((probe-file filepath)            ((probe-file filepath)
377               (unless (check-file-times buffer filepath "Revert" "reverted")
378                 (return-from com-revert-buffer))
379             (erase-buffer buffer)             (erase-buffer buffer)
380             (with-open-file (stream filepath :direction :input)             (with-open-file (stream filepath :direction :input)
381               (input-from-stream stream buffer 0))               (input-from-stream stream buffer 0))
382             (setf (offset (point pane))             (setf (offset (point pane)) (min (size buffer) save)
383                   (min (size buffer) save)))                   (file-saved-p buffer) nil))
384            (t            (t
385             (display-message "No file ~A" filepath)             (display-message "No file ~A" filepath)
386             (beep))))))             (beep))))))
387    
388    (defun extract-version-number (pathname)
389      "Extracts the emacs-style version-number from a pathname."
390      (let* ((type (pathname-type pathname))
391             (length (length type)))
392        (when (and (> length 2) (char= (char type (1- length)) #\~))
393          (let ((tilde (position #\~ type :from-end t :end (- length 2))))
394            (when tilde
395              (parse-integer type :start (1+ tilde) :junk-allowed t))))))
396    
397    (defun version-number (pathname)
398      "Return the number of the highest versioned backup of PATHNAME
399    or 0 if there is no versioned backup. Looks for name.type~X~,
400    returns highest X."
401      (let* ((wildpath (merge-pathnames (make-pathname :type :wild) pathname))
402             (possibilities (directory wildpath)))
403        (loop for possibility in possibilities
404              for version = (extract-version-number possibility)
405              if (numberp version)
406                maximize version into max
407              finally (return max))))
408    
409    (defun check-file-times (buffer filepath question answer)
410      "Return NIL if filepath newer than buffer and user doesn't want to overwrite"
411      (let ((f-w-d (file-write-date filepath))
412            (f-w-t (file-write-time buffer)))
413        (if (and f-w-d f-w-t (> f-w-d f-w-t))
414            (if (accept 'boolean
415                        :prompt (format nil "File has changed on disk. ~a anyway?"
416                                        question))
417                t
418                (progn (display-message "~a not ~a" filepath answer)
419                       nil))
420            t)))
421    
422  (defun save-buffer (buffer)  (defun save-buffer (buffer)
423    (let ((filepath (or (filepath buffer)    (let ((filepath (or (filepath buffer)
424                        (accept 'pathname :prompt "Save Buffer to File"))))                        (accept 'pathname :prompt "Save Buffer to File"))))
# Line 388  Signals an error if the file does not ex Line 427  Signals an error if the file does not ex
427         (display-message "~A is a directory." filepath)         (display-message "~A is a directory." filepath)
428         (beep))         (beep))
429        (t        (t
430         (when (probe-file filepath)         (unless (check-file-times buffer filepath "Overwrite" "written")
431             (return-from save-buffer))
432           (when  (and (probe-file filepath) (not (file-saved-p buffer)))
433           (let ((backup-name (pathname-name filepath))           (let ((backup-name (pathname-name filepath))
434                 (backup-type (concatenate 'string (pathname-type filepath) "~")))                 (backup-type (format nil "~A~~~D~~"
435                                        (pathname-type filepath)
436                                        (1+ (version-number filepath)))))
437             (rename-file filepath (make-pathname :name backup-name             (rename-file filepath (make-pathname :name backup-name
438                                                  :type backup-type))))                                                  :type backup-type)))
439             (setf (file-saved-p buffer) t))
440         (with-open-file (stream filepath :direction :output :if-exists :supersede)         (with-open-file (stream filepath :direction :output :if-exists :supersede)
441           (output-to-stream stream buffer 0 (size buffer)))           (output-to-stream stream buffer 0 (size buffer)))
442         (setf (filepath buffer) filepath         (setf (filepath buffer) filepath
443                 (file-write-time buffer) (file-write-date filepath)
444               (name buffer) (filepath-filename filepath))               (name buffer) (filepath-filename filepath))
445         (display-message "Wrote: ~a" (filepath buffer))         (display-message "Wrote: ~a" filepath)
446         (setf (needs-saving buffer) nil)))))         (setf (needs-saving buffer) nil)))))
447    
448  (define-command (com-save-buffer :name t :command-table buffer-table) ()  (define-command (com-save-buffer :name t :command-table buffer-table) ()

Legend:
Removed from v.1.10  
changed lines
  Added in v.1.11

  ViewVC Help
Powered by ViewVC 1.1.5