files.lisp

   1 (in-package :lice)
   2
   3 (defun format-filename (filename)
   4   (declare (type pathname filename))
   5   (format nil "~a~@[.~a~]"
   6           (pathname-name filename)
   7           (pathname-type filename)))
   8
   9 (defun slurp-file (filename)
  10   "Return the contents of FILENAME as a string."
  11   (declare (type pathname filename))
  12   (with-open-file (in filename)
  13     ;; Note the 1+ is to leave a 1 character gap, because a buffer
  14     ;; can't have a 0 length gap.
  15     (let* ((str (make-array (1+ (file-length in)) :element-type 'character)))
  16       (read-sequence str in)
  17       str)))
  18
  19 (defun make-file-buffer (filename)
  20   "Assumes filename has been verified to exist and is a file."
  21   ;; load the file, put it in a buffer
  22   (declare (type pathname filename))
  23   (let* ((data (slurp-file filename))
  24          (b (make-instance 'buffer
  25                            :file filename
  26                            :point (make-marker)
  27                            :mark (make-marker)
  28                            :data data
  29                            :mode-line *mode-line-format*
  30                            :name (format-filename filename)
  31                            ;; 1- because the data has been allocated with 1 extra character
  32                            :gap-start (1- (length data))
  33                            :gap-size 1 ;;(length +other-buf+)
  34                            :major-mode fundamental-mode)))
  35     (set-marker (buffer-point b) 0 b)
  36     (set-marker (mark-marker b) 0 b)
  37     b))
  38
  39 (defun find-file-no-select (filename)
  40   ;; TODO: verify the file is a file (not a dir) and it exists, etc.
  41   (let ((pn (parse-namestring filename)))
  42     ;; check that the directory exists
  43     (unless (ensure-directories-exist pn)
  44       (error "dir doesn't exist"))
  45     (if (probe-file pn)
  46         (let ((b (make-file-buffer pn)))
  47           (push b *buffer-list*)
  48           b)
  49       ;; It doesn't exist so open an empty buffer but give it a file,
  50       ;; so it can be saved.
  51       (let ((b (get-buffer-create (format-filename pn))))
  52         (setf (buffer-file b) pn)
  53         b))))
  54
  55 (defcommand find-file ((filename)
  56                        (:file "Find File: "))
  57   ""
  58   (let ((b (find-file-no-select filename)))
  59     (switch-to-buffer b)))
  60
  61 (defcommand save-buffer ()
  62   (let ((buffer (current-buffer)))
  63     (when (buffer-file buffer)
  64       (if (buffer-modified-p buffer)
  65           (with-open-file (out (buffer-file buffer)
  66                                :direction :output
  67                                :if-exists :overwrite
  68                                :if-does-not-exist :create)
  69             ;; write the data before the gap
  70             (write-sequence (buffer-data buffer) out
  71                             :start (buffer-min buffer)
  72                             :end (buffer-gap-start buffer))
  73             ;; write the data after the gap
  74             (write-sequence (buffer-data buffer) out
  75                             :start (gap-end buffer)
  76                             :end (length (buffer-data buffer)))
  77             (setf (buffer-modified-p buffer) nil)
  78             (message "Wrote ~a~%" (buffer-file (current-buffer))))
  79         (message "(No changes need to be saved)")))))
  80
  81 (defun file-completions (base predicate other)
  82   "Return a list of possible file completions given the base file, BASE. OTHER is not used."
  83   (declare (ignore other))
  84   ;; FIXME: they need to be strings
  85   (let ((tester (or predicate
  86                     (lambda (s)
  87                       (string= base s :end2 (min (length base)
  88                                                  (length s)))))))
  89     (loop for elt in (mapcar 'princ-to-string (directory (merge-pathnames (make-pathname :name :wild) base)))
  90        when (funcall tester elt)
  91        collect elt)))
  92
  93 (defcommand load-file ((file)
  94                        (:file "Load file: "))
  95   "Load the Lisp file named FILE."
  96   (load file))
  97
  98 ;;; auto save
  99
 100 (defun recent-auto-save-p ()
 101   "Return t if current buffer has been auto-saved recently.
 102 More precisely, if it has been auto-saved since last read from or saved
 103 in the visited file.  If the buffer has no visited file,
 104 then any auto-save counts as \"recent\"."
 105   ;; FIXME: implement
 106   nil)
 107
 108 (defun set-buffer-auto-saved ()
 109 "Mark current buffer as auto-saved with its current text.
 110 No auto-save file will be written until the buffer changes again."
 111   (setf (buffer-auto-save-modified (current-buffer)) (buffer-modiff (current-buffer))))
 112
 113 ;; FIXME: maybe this should be a slot in the buffer with the rest of the autosave slots
 114 (define-buffer-local buffer-auto-save-file-name nil
 115   "Name of file for auto-saving current buffer.
 116 If it is nil, that means don't auto-save this buffer.")
 117
 118 (defcustom *delete-auto-save-files* t
 119   "Non-nil means delete auto-save file when a buffer is saved or killed.
 120
 121 Note that the auto-save file will not be deleted if the buffer is killed
 122 when it has unsaved changes."
 123   :type 'boolean
 124   :group 'auto-save)
 125
 126 (defun delete-auto-save-file-if-necessary (&optional force)
 127   "Delete auto-save file for current buffer if `delete-auto-save-files' is t.
 128 Normally delete only if the file was written by this Emacs since
 129 the last real save, but optional arg FORCE non-nil means delete anyway."
 130   (and buffer-auto-save-file-name *delete-auto-save-files*
 131        (not (string= (buffer-file (current-buffer)) buffer-auto-save-file-name))
 132        (or force (recent-auto-save-p))
 133        (progn
 134          (handler-case
 135              (delete-file buffer-auto-save-file-name)
 136            (file-error () nil))
 137          (set-buffer-auto-saved))))
 138
 139 (provide :lice-0.1/files)