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

Contents of /climacs/file-commands.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (hide annotations)
Sat May 6 06:27:14 2006 UTC (7 years, 11 months ago) by dmurray
Branch: MAIN
Changes since 1.10: +53 -8 lines
Changed backup behaviour. Now makes emacs-style versioned backups
(foo.lisp~42~) once per session. Also checks to see if the file
has changed on disk when saving and reverting.
1 dmurray 1.1 ;;; -*- Mode: Lisp; Package: CLIMACS-GUI -*-
2    
3     ;;; (c) copyright 2004-2005 by
4     ;;; Robert Strandh (strandh@labri.fr)
5     ;;; (c) copyright 2004-2005 by
6     ;;; Elliott Johnson (ejohnson@fasl.info)
7     ;;; (c) copyright 2005 by
8     ;;; Matthieu Villeneuve (matthieu.villeneuve@free.fr)
9     ;;; (c) copyright 2005 by
10     ;;; Aleksandar Bakic (a_bakic@yahoo.com)
11    
12     ;;; This library is free software; you can redistribute it and/or
13     ;;; modify it under the terms of the GNU Library General Public
14     ;;; License as published by the Free Software Foundation; either
15     ;;; version 2 of the License, or (at your option) any later version.
16     ;;;
17     ;;; This library is distributed in the hope that it will be useful,
18     ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19     ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20     ;;; Library General Public License for more details.
21     ;;;
22     ;;; You should have received a copy of the GNU Library General Public
23     ;;; License along with this library; if not, write to the
24     ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25     ;;; Boston, MA 02111-1307 USA.
26    
27     ;;; File commands for the Climacs editor.
28    
29     (in-package :climacs-gui)
30    
31     (defun filename-completer (so-far mode)
32     (flet ((remove-trail (s)
33     (subseq s 0 (let ((pos (position #\/ s :from-end t)))
34     (if pos (1+ pos) 0)))))
35     (let* ((directory-prefix
36     (if (and (plusp (length so-far)) (eql (aref so-far 0) #\/))
37     ""
38     (namestring #+sbcl *default-pathname-defaults*
39     #+cmu (ext:default-directory)
40     #-(or sbcl cmu) *default-pathname-defaults*)))
41     (full-so-far (concatenate 'string directory-prefix so-far))
42     (pathnames
43     (loop with length = (length full-so-far)
44     and wildcard = (concatenate 'string (remove-trail so-far) "*.*")
45     for path in
46     #+(or sbcl cmu lispworks) (directory wildcard)
47     #+openmcl (directory wildcard :directories t)
48     #+allegro (directory wildcard :directories-are-files nil)
49     #+cormanlisp (nconc (directory wildcard)
50     (cl::directory-subdirs dirname))
51     #-(or sbcl cmu lispworks openmcl allegro cormanlisp)
52     (directory wildcard)
53     when (let ((mismatch (mismatch (namestring path) full-so-far)))
54     (or (null mismatch) (= mismatch length)))
55     collect path))
56     (strings (mapcar #'namestring pathnames))
57     (first-string (car strings))
58     (length-common-prefix nil)
59     (completed-string nil)
60     (full-completed-string nil))
61     (unless (null pathnames)
62     (setf length-common-prefix
63     (loop with length = (length first-string)
64     for string in (cdr strings)
65     do (setf length (min length (or (mismatch string first-string) length)))
66     finally (return length))))
67     (unless (null pathnames)
68     (setf completed-string
69     (subseq first-string (length directory-prefix)
70     (if (null (cdr pathnames)) nil length-common-prefix)))
71     (setf full-completed-string
72     (concatenate 'string directory-prefix completed-string)))
73     (case mode
74     ((:complete-limited :complete-maximal)
75     (cond ((null pathnames)
76     (values so-far nil nil 0 nil))
77     ((null (cdr pathnames))
78     (values completed-string t (car pathnames) 1 nil))
79     (t
80     (values completed-string nil nil (length pathnames) nil))))
81     (:complete
82     (cond ((null pathnames)
83     (values so-far t so-far 1 nil))
84     ((null (cdr pathnames))
85     (values completed-string t (car pathnames) 1 nil))
86     ((find full-completed-string strings :test #'string-equal)
87     (let ((pos (position full-completed-string strings :test #'string-equal)))
88     (values completed-string
89     t (elt pathnames pos) (length pathnames) nil)))
90     (t
91     (values completed-string nil nil (length pathnames) nil))))
92     (:possibilities
93     (values nil nil nil (length pathnames)
94     (loop with length = (length directory-prefix)
95     for name in pathnames
96     collect (list (subseq (namestring name) length nil)
97     name))))))))
98    
99     (define-presentation-method present (object (type pathname)
100     stream (view climacs-textual-view) &key)
101     (princ (namestring object) stream))
102    
103     (define-presentation-method accept ((type pathname) stream (view climacs-textual-view)
104     &key (default nil defaultp) (default-type type))
105     (multiple-value-bind (pathname success string)
106     (complete-input stream
107     #'filename-completer
108     :allow-any-input t)
109     (cond (success
110 tmoore 1.3 (values (or pathname (parse-namestring string)) type))
111 dmurray 1.1 ((and (zerop (length string))
112     defaultp)
113     (values default default-type))
114     (t (values string 'string)))))
115    
116     (defun filepath-filename (pathname)
117     (if (null (pathname-type pathname))
118     (pathname-name pathname)
119     (concatenate 'string (pathname-name pathname)
120     "." (pathname-type pathname))))
121    
122     (defun syntax-class-name-for-filepath (filepath)
123     (or (climacs-syntax::syntax-description-class-name
124     (find (or (pathname-type filepath)
125     (pathname-name filepath))
126     climacs-syntax::*syntaxes*
127     :test (lambda (x y)
128     (member x y :test #'string-equal))
129     :key #'climacs-syntax::syntax-description-pathname-types))
130     'basic-syntax))
131    
132 thenriksen 1.6 (defun parse-local-options-line (line)
133     "Parse the local options line `line' and return an alist
134     mapping options to values. All option names will be coerced to
135     uppercase. `Line' must be stripped of the leading and
136     terminating -*- tokens."
137     (loop for pair in (split-sequence:split-sequence #\; line)
138     when (find #\: pair)
139     collect (destructuring-bind (key value)
140     (loop for elem in (split-sequence:split-sequence #\: pair)
141     collecting (string-trim " " elem))
142     (list (string-upcase key) value))))
143    
144     (defun evaluate-local-options (buffer options)
145     "Evaluate the local options `options' and modify `buffer' as
146     appropriate. `Options' should be an alist mapping option names
147     to their values."
148     ;; First, check whether we need to change the syntax (via the SYNTAX
149     ;; option). MODE is an alias for SYNTAX for compatibility with
150     ;; Emacs. If there is more than one option with one of these names,
151     ;; only the first will be acted upon.
152     (let ((specified-syntax
153     (syntax-from-name
154     (second (find-if #'(lambda (name)
155     (or (string= name "SYNTAX")
156     (string= name "MODE")))
157     options
158     :key #'first)))))
159     (when specified-syntax
160     (setf (syntax buffer)
161     (make-instance specified-syntax
162     :buffer buffer))))
163     ;; Now we iterate through the options (discarding SYNTAX and MODE
164     ;; options).
165     (loop for (name value) in options
166     unless (or (string= name "SYNTAX")
167     (string= name "MODE"))
168     do (eval-option (syntax buffer) name value)))
169    
170     (defun evaluate-local-options-line (buffer)
171     "Evaluate the local options line of `buffer'. If `buffer' does
172     not have a local options line, this function is a no-op."
173     ;; This could be simplified a bit by using regexps.
174     (let* ((beginning-mark (beginning-of-buffer
175     (clone-mark (point buffer))))
176     (end-mark (end-of-line (clone-mark beginning-mark)))
177     (line (buffer-sequence buffer (offset beginning-mark) (offset end-mark)))
178     (first-occurence (search "-*-" line))
179     (second-occurence
180     (when first-occurence
181     (search "-*-" line :start2 (1+ first-occurence)))))
182     (when (and first-occurence
183     second-occurence)
184     ;; Strip away the -*-s.
185     (let ((cleaned-options-line (coerce (subseq line
186     (+ first-occurence 3)
187     second-occurence)
188     'string)))
189     (evaluate-local-options
190     buffer
191     (parse-local-options-line cleaned-options-line))))))
192    
193 dmurray 1.1 ;; Adapted from cl-fad/PCL
194     (defun directory-pathname-p (pathspec)
195     "Returns NIL if PATHSPEC does not designate a directory."
196     (let ((name (pathname-name pathspec))
197     (type (pathname-type pathspec)))
198     (and (or (null name) (eql name :unspecific))
199     (or (null type) (eql type :unspecific)))))
200    
201     (defun find-file (filepath)
202     (cond ((null filepath)
203     (display-message "No file name given.")
204     (beep))
205     ((directory-pathname-p filepath)
206     (display-message "~A is a directory name." filepath)
207     (beep))
208     (t
209     (let ((existing-buffer (find filepath (buffers *application-frame*)
210     :key #'filepath :test #'equal)))
211     (if existing-buffer
212     (switch-to-buffer existing-buffer)
213     (let ((buffer (make-buffer))
214     (pane (current-window)))
215 dmurray 1.11 ;; Clear the pane's cache; otherwise residue from the
216 thenriksen 1.8 ;; previously displayed buffer may under certain
217     ;; circumstances be displayed.
218 thenriksen 1.9 (clear-cache pane)
219 thenriksen 1.7 (setf (syntax buffer) nil)
220 dmurray 1.1 (setf (offset (point (buffer pane))) (offset (point pane)))
221     (setf (buffer (current-window)) buffer)
222     ;; Don't want to create the file if it doesn't exist.
223     (when (probe-file filepath)
224     (with-open-file (stream filepath :direction :input)
225 thenriksen 1.6 (input-from-stream stream buffer 0))
226 dmurray 1.11 (setf (file-write-time buffer) (file-write-date filepath))
227 thenriksen 1.6 ;; A file! That means we may have a local options
228     ;; line to parse.
229     (evaluate-local-options-line buffer))
230     ;; If the local options line didn't set a syntax, do
231     ;; it now.
232     (when (null (syntax buffer))
233     (setf (syntax buffer)
234     (make-instance (syntax-class-name-for-filepath filepath)
235     :buffer buffer)))
236 dmurray 1.1 (setf (filepath buffer) filepath
237     (name buffer) (filepath-filename filepath)
238     (needs-saving buffer) nil)
239     (beginning-of-buffer (point pane))
240 crhodes 1.5 (update-syntax buffer (syntax buffer))
241     (clear-modify buffer)
242 dmurray 1.1 buffer))))))
243    
244 dmurray 1.2 (defun directory-of-buffer (buffer)
245     "Extract the directory part of the filepath to the file in BUFFER.
246 dmurray 1.11 If BUFFER does not have a filepath, the path to the user's home
247 dmurray 1.2 directory will be returned."
248     (make-pathname
249     :directory
250     (pathname-directory
251     (or (filepath buffer)
252     (user-homedir-pathname)))))
253    
254 dmurray 1.1 (define-command (com-find-file :name t :command-table buffer-table) ()
255 dmurray 1.10 "Prompt for a filename then edit that file.
256     If a buffer is already visiting that file, switch to that buffer. Does not create a file if the filename given does not name an existing file."
257 dmurray 1.2 (let* ((filepath (accept 'pathname :prompt "Find File"
258     :default (directory-of-buffer (buffer (current-window)))
259     :default-type 'pathname
260     :insert-default t)))
261 dmurray 1.1 (find-file filepath)))
262    
263     (set-key 'com-find-file
264     'buffer-table
265     '((#\x :control) (#\f :control)))
266    
267     (defun find-file-read-only (filepath)
268     (cond ((null filepath)
269     (display-message "No file name given.")
270     (beep))
271     ((directory-pathname-p filepath)
272     (display-message "~A is a directory name." filepath)
273     (beep))
274     (t
275     (let ((existing-buffer (find filepath (buffers *application-frame*)
276     :key #'filepath :test #'equal)))
277     (if (and existing-buffer (read-only-p existing-buffer))
278     (switch-to-buffer existing-buffer)
279     (if (probe-file filepath)
280     (let ((buffer (make-buffer))
281     (pane (current-window)))
282     (setf (offset (point (buffer pane))) (offset (point pane)))
283     (setf (buffer (current-window)) buffer)
284     (setf (syntax buffer)
285     (make-instance (syntax-class-name-for-filepath filepath)
286     :buffer (buffer (point pane))))
287     (with-open-file (stream filepath :direction :input)
288     (input-from-stream stream buffer 0))
289     (setf (filepath buffer) filepath
290     (name buffer) (filepath-filename filepath)
291     (needs-saving buffer) nil
292     (read-only-p buffer) t)
293     (beginning-of-buffer (point pane))
294     ;; this one is needed so that the buffer modification protocol
295     ;; resets the low and high marks after redisplay
296     (redisplay-frame-panes *application-frame*)
297     buffer)
298     (progn
299     (display-message "No such file: ~A" filepath)
300     (beep)
301     nil)))))))
302    
303     (define-command (com-find-file-read-only :name t :command-table buffer-table) ()
304 dmurray 1.10 "Prompt for a filename then open that file readonly.
305     If a buffer is already visiting that file, switch to that buffer. If the filename given does not name an existing file, signal an error."
306 dmurray 1.2 (let ((filepath (accept 'pathname :Prompt "Find file read only"
307     :default (directory-of-buffer (buffer (current-window)))
308     :default-type 'pathname
309     :insert-default t)))
310 dmurray 1.1 (find-file-read-only filepath)))
311    
312     (set-key 'com-find-file-read-only
313     'buffer-table
314     '((#\x :control) (#\r :control)))
315    
316     (define-command (com-read-only :name t :command-table buffer-table) ()
317 dmurray 1.10 "Toggle the readonly status of the current buffer.
318     When a buffer is readonly, attempts to change the contents of the buffer signal an error."
319 dmurray 1.1 (let ((buffer (buffer (current-window))))
320     (setf (read-only-p buffer) (not (read-only-p buffer)))))
321    
322     (set-key 'com-read-only
323     'buffer-table
324     '((#\x :control) (#\q :control)))
325    
326     (defun set-visited-file-name (filename buffer)
327     (setf (filepath buffer) filename
328 dmurray 1.11 (file-saved-p buffer) nil
329     (file-write-time buffer) nil
330 dmurray 1.1 (name buffer) (filepath-filename filename)
331     (needs-saving buffer) t))
332    
333     (define-command (com-set-visited-file-name :name t :command-table buffer-table) ()
334 dmurray 1.10 "Prompt for a new filename for the current buffer.
335     The next time the buffer is saved it will be saved to a file with that filename."
336 dmurray 1.2 (let ((filename (accept 'pathname :prompt "New file name"
337     :default (directory-of-buffer (buffer (current-window)))
338     :default-type 'pathname
339     :insert-default t)))
340 dmurray 1.1 (set-visited-file-name filename (buffer (current-window)))))
341    
342     (define-command (com-insert-file :name t :command-table buffer-table) ()
343 dmurray 1.10 "Prompt for a filename and insert its contents at point.
344     Leaves mark after the inserted contents."
345 dmurray 1.2 (let ((filename (accept 'pathname :prompt "Insert File"
346     :default (directory-of-buffer (buffer (current-window)))
347     :default-type 'pathname
348     :insert-default t))
349 dmurray 1.1 (pane (current-window)))
350     (when (probe-file filename)
351     (setf (mark pane) (clone-mark (point pane) :left))
352     (with-open-file (stream filename :direction :input)
353     (input-from-stream stream
354     (buffer pane)
355     (offset (point pane))))
356     (psetf (offset (mark pane)) (offset (point pane))
357     (offset (point pane)) (offset (mark pane))))
358     (redisplay-frame-panes *application-frame*)))
359    
360     (set-key 'com-insert-file
361     'buffer-table
362     '((#\x :control) (#\i :control)))
363    
364     (define-command (com-revert-buffer :name t :command-table buffer-table) ()
365 dmurray 1.10 "Replace the contents of the current buffer with the visited file.
366     Signals an error if the file does not exist."
367 dmurray 1.1 (let* ((pane (current-window))
368     (buffer (buffer pane))
369     (filepath (filepath buffer))
370     (save (offset (point pane))))
371     (when (accept 'boolean :prompt (format nil "Revert buffer from file ~A?"
372     (filepath buffer)))
373     (cond ((directory-pathname-p filepath)
374     (display-message "~A is a directory name." filepath)
375     (beep))
376     ((probe-file filepath)
377 dmurray 1.11 (unless (check-file-times buffer filepath "Revert" "reverted")
378     (return-from com-revert-buffer))
379 dmurray 1.1 (erase-buffer buffer)
380     (with-open-file (stream filepath :direction :input)
381     (input-from-stream stream buffer 0))
382 dmurray 1.11 (setf (offset (point pane)) (min (size buffer) save)
383     (file-saved-p buffer) nil))
384 dmurray 1.1 (t
385     (display-message "No file ~A" filepath)
386     (beep))))))
387    
388 dmurray 1.11 (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 dmurray 1.1 (defun save-buffer (buffer)
423     (let ((filepath (or (filepath buffer)
424     (accept 'pathname :prompt "Save Buffer to File"))))
425     (cond
426     ((directory-pathname-p filepath)
427     (display-message "~A is a directory." filepath)
428     (beep))
429     (t
430 dmurray 1.11 (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 dmurray 1.1 (let ((backup-name (pathname-name filepath))
434 dmurray 1.11 (backup-type (format nil "~A~~~D~~"
435     (pathname-type filepath)
436     (1+ (version-number filepath)))))
437 dmurray 1.1 (rename-file filepath (make-pathname :name backup-name
438 dmurray 1.11 :type backup-type)))
439     (setf (file-saved-p buffer) t))
440 dmurray 1.1 (with-open-file (stream filepath :direction :output :if-exists :supersede)
441     (output-to-stream stream buffer 0 (size buffer)))
442     (setf (filepath buffer) filepath
443 dmurray 1.11 (file-write-time buffer) (file-write-date filepath)
444 dmurray 1.1 (name buffer) (filepath-filename filepath))
445 dmurray 1.11 (display-message "Wrote: ~a" filepath)
446 dmurray 1.1 (setf (needs-saving buffer) nil)))))
447    
448     (define-command (com-save-buffer :name t :command-table buffer-table) ()
449 dmurray 1.10 "Write the contents of the buffer to a file.
450     If there is filename associated with the buffer, write to that file, replacing its contents. If not, prompt for a filename."
451 dmurray 1.1 (let ((buffer (buffer (current-window))))
452     (if (or (null (filepath buffer))
453     (needs-saving buffer))
454     (save-buffer buffer)
455     (display-message "No changes need to be saved from ~a" (name buffer)))))
456    
457     (set-key 'com-save-buffer
458     'buffer-table
459     '((#\x :control) (#\s :control)))
460    
461 tmoore 1.3 (defmethod frame-exit :around ((frame climacs) #-mcclim &key)
462 dmurray 1.1 (loop for buffer in (buffers frame)
463     when (and (needs-saving buffer)
464     (filepath buffer)
465     (handler-case (accept 'boolean
466     :prompt (format nil "Save buffer: ~a ?" (name buffer)))
467     (error () (progn (beep)
468     (display-message "Invalid answer")
469     (return-from frame-exit nil)))))
470     do (save-buffer buffer))
471     (when (or (notany #'(lambda (buffer) (and (needs-saving buffer) (filepath buffer)))
472     (buffers frame))
473     (handler-case (accept 'boolean :prompt "Modified buffers exist. Quit anyway?")
474     (error () (progn (beep)
475     (display-message "Invalid answer")
476     (return-from frame-exit nil)))))
477     (call-next-method)))
478    
479     (define-command (com-write-buffer :name t :command-table buffer-table) ()
480 dmurray 1.10 "Prompt for a filename and write the current buffer to it.
481     Changes the file visted by the buffer to the given file."
482 dmurray 1.2 (let ((filepath (accept 'pathname :prompt "Write Buffer to File"
483     :default (directory-of-buffer (buffer (current-window)))
484     :default-type 'pathname
485     :insert-default t))
486 dmurray 1.1 (buffer (buffer (current-window))))
487     (cond
488     ((directory-pathname-p filepath)
489     (display-message "~A is a directory name." filepath))
490     (t
491     (with-open-file (stream filepath :direction :output :if-exists :supersede)
492     (output-to-stream stream buffer 0 (size buffer)))
493     (setf (filepath buffer) filepath
494     (name buffer) (filepath-filename filepath)
495     (needs-saving buffer) nil)
496     (display-message "Wrote: ~a" (filepath buffer))))))
497    
498     (set-key 'com-write-buffer
499     'buffer-table
500     '((#\x :control) (#\w :control)))
501    

  ViewVC Help
Powered by ViewVC 1.1.5