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

Contents of /climacs/file-commands.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (hide annotations)
Sun May 14 07:13:43 2006 UTC (7 years, 11 months ago) by dmurray
Branch: MAIN
Changes since 1.16: +1 -1 lines
Banish Basic syntax in favour of Fundamental (and some
region highlighting fiddling).
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 dmurray 1.17 'fundamental-syntax))
131 dmurray 1.1
132 dmurray 1.12 (defun evaluate-attributes (buffer options)
133     "Evaluate the attributes `options' and modify `buffer' as
134 thenriksen 1.6 appropriate. `Options' should be an alist mapping option names
135     to their values."
136     ;; First, check whether we need to change the syntax (via the SYNTAX
137     ;; option). MODE is an alias for SYNTAX for compatibility with
138     ;; Emacs. If there is more than one option with one of these names,
139     ;; only the first will be acted upon.
140     (let ((specified-syntax
141     (syntax-from-name
142     (second (find-if #'(lambda (name)
143 dmurray 1.12 (or (string-equal name "SYNTAX")
144     (string-equal name "MODE")))
145 thenriksen 1.6 options
146     :key #'first)))))
147     (when specified-syntax
148     (setf (syntax buffer)
149     (make-instance specified-syntax
150     :buffer buffer))))
151     ;; Now we iterate through the options (discarding SYNTAX and MODE
152     ;; options).
153     (loop for (name value) in options
154 dmurray 1.12 unless (or (string-equal name "SYNTAX")
155     (string-equal name "MODE"))
156 thenriksen 1.6 do (eval-option (syntax buffer) name value)))
157    
158 dmurray 1.12 (defun split-attribute (string char)
159     (let (pairs)
160     (loop with start = 0
161     for ch across string
162     for i from 0
163     when (eql ch char)
164     do (push (string-trim '(#\Space #\Tab) (subseq string start i))
165     pairs)
166     (setf start (1+ i))
167     finally (unless (>= start i)
168     (push (string-trim '(#\Space #\Tab) (subseq string start))
169     pairs)))
170     (nreverse pairs)))
171    
172     (defun split-attribute-line (line)
173     (mapcar (lambda (pair) (split-attribute pair #\:))
174     (split-attribute line #\;)))
175    
176     (defun get-attribute-line (buffer)
177     (let ((scan (beginning-of-buffer (clone-mark (point buffer)))))
178     ;; skip the leading whitespace
179     (loop until (end-of-buffer-p scan)
180     until (not (whitespacep (object-after scan)))
181     do (forward-object scan))
182     ;; stop looking if we're already 1,000 objects into the buffer
183     (unless (> (offset scan) 1000)
184     (let ((start-found
185     (loop with newlines = 0
186     when (end-of-buffer-p scan)
187     do (return nil)
188     when (eql (object-after scan) #\Newline)
189     do (incf newlines)
190     when (> newlines 1)
191     do (return nil)
192     do (forward-object scan)
193     until (looking-at scan "-*-")
194     finally (return t))))
195     (when start-found
196     (let ((line (buffer-substring buffer
197     (offset scan)
198     (offset (end-of-line (clone-mark scan))))))
199     (when (>= (length line) 6)
200     (let ((end (search "-*-" line :from-end t :start2 3)))
201     (when end
202     (string-trim '(#\Space #\Tab) (subseq line 3 end)))))))))))
203    
204     (defun evaluate-attributes-line (buffer)
205     (evaluate-attributes
206     buffer
207     (split-attribute-line (get-attribute-line buffer))))
208    
209     (define-command (com-reparse-attribute-list :name t :command-table buffer-table) ()
210     "Reparse the current buffer's attribute list.
211     An attribute list is a line of keyword-value pairs, each keyword separated
212     from the corresponding value by a colon. If another keyword-value pair
213     follows, the value should be terminated by a colon. The attribute list
214     is surrounded by '-*-' sequences, but the opening '-*-' need not be at the
215     beginning of the line. Climacs looks for the attribute list
216     on the first or second non-blank line of the file.
217    
218     An example attribute-list is:
219    
220     ;; -*- Syntax: Lisp; Base: 10 -*- "
221     (evaluate-attributes-line (buffer (current-window))))
222 thenriksen 1.6
223 dmurray 1.1 ;; Adapted from cl-fad/PCL
224     (defun directory-pathname-p (pathspec)
225     "Returns NIL if PATHSPEC does not designate a directory."
226     (let ((name (pathname-name pathspec))
227     (type (pathname-type pathspec)))
228     (and (or (null name) (eql name :unspecific))
229     (or (null type) (eql type :unspecific)))))
230    
231 dmurray 1.15 (defun find-file (filepath &optional readonlyp)
232 dmurray 1.1 (cond ((null filepath)
233     (display-message "No file name given.")
234     (beep))
235     ((directory-pathname-p filepath)
236     (display-message "~A is a directory name." filepath)
237     (beep))
238     (t
239     (let ((existing-buffer (find filepath (buffers *application-frame*)
240     :key #'filepath :test #'equal)))
241 dmurray 1.15 (if (and existing-buffer (if readonlyp (read-only-p existing-buffer) t))
242 dmurray 1.1 (switch-to-buffer existing-buffer)
243 dmurray 1.15 (progn
244     (when readonlyp
245     (unless (probe-file filepath)
246     (beep)
247     (display-message "No such file: ~A" filepath)
248     (return-from find-file nil)))
249     (let ((buffer (make-buffer))
250     (pane (current-window)))
251     ;; Clear the pane's cache; otherwise residue from the
252     ;; previously displayed buffer may under certain
253     ;; circumstances be displayed.
254     (clear-cache pane)
255     (setf (syntax buffer) nil)
256     (setf (offset (point (buffer pane))) (offset (point pane)))
257     (setf (buffer (current-window)) buffer)
258     ;; Don't want to create the file if it doesn't exist.
259     (when (probe-file filepath)
260     (with-open-file (stream filepath :direction :input)
261     (input-from-stream stream buffer 0))
262     (setf (file-write-time buffer) (file-write-date filepath))
263     ;; A file! That means we may have a local options
264     ;; line to parse.
265     (evaluate-attributes-line buffer))
266     ;; If the local options line didn't set a syntax, do
267     ;; it now.
268     (when (null (syntax buffer))
269     (setf (syntax buffer)
270     (make-instance (syntax-class-name-for-filepath filepath)
271     :buffer buffer)))
272     (setf (filepath buffer) filepath
273     (name buffer) (filepath-filename filepath)
274     (needs-saving buffer) nil
275     (read-only-p buffer) readonlyp)
276     (beginning-of-buffer (point pane))
277     (update-syntax buffer (syntax buffer))
278     (clear-modify buffer)
279     buffer)))))))
280 dmurray 1.1
281 dmurray 1.2 (defun directory-of-buffer (buffer)
282     "Extract the directory part of the filepath to the file in BUFFER.
283 dmurray 1.11 If BUFFER does not have a filepath, the path to the user's home
284 dmurray 1.2 directory will be returned."
285     (make-pathname
286     :directory
287     (pathname-directory
288     (or (filepath buffer)
289     (user-homedir-pathname)))))
290    
291 dmurray 1.16 (define-command (com-find-file :name t :command-table buffer-table)
292     ((filepath 'pathname
293     :prompt "Find File"
294     :default (directory-of-buffer (buffer (current-window)))
295     :default-type 'pathname
296     :insert-default t))
297 dmurray 1.10 "Prompt for a filename then edit that file.
298     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."
299 dmurray 1.16 (find-file filepath))
300 dmurray 1.1
301 dmurray 1.16 (set-key `(com-find-file ,*unsupplied-argument-marker*)
302 dmurray 1.1 'buffer-table
303     '((#\x :control) (#\f :control)))
304    
305 dmurray 1.16 (define-command (com-find-file-read-only :name t :command-table buffer-table)
306     ((filepath '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.10 "Prompt for a filename then open that file readonly.
311     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."
312 dmurray 1.16 (find-file filepath t))
313 dmurray 1.1
314 dmurray 1.16 (set-key `(com-find-file-read-only ,*unsupplied-argument-marker*)
315 dmurray 1.1 'buffer-table
316     '((#\x :control) (#\r :control)))
317    
318     (define-command (com-read-only :name t :command-table buffer-table) ()
319 dmurray 1.10 "Toggle the readonly status of the current buffer.
320     When a buffer is readonly, attempts to change the contents of the buffer signal an error."
321 dmurray 1.1 (let ((buffer (buffer (current-window))))
322     (setf (read-only-p buffer) (not (read-only-p buffer)))))
323    
324     (set-key 'com-read-only
325     'buffer-table
326     '((#\x :control) (#\q :control)))
327    
328     (defun set-visited-file-name (filename buffer)
329     (setf (filepath buffer) filename
330 dmurray 1.11 (file-saved-p buffer) nil
331     (file-write-time buffer) nil
332 dmurray 1.1 (name buffer) (filepath-filename filename)
333     (needs-saving buffer) t))
334    
335 dmurray 1.16 (define-command (com-set-visited-file-name :name t :command-table buffer-table)
336     ((filename 'pathname :prompt "New file name"
337     :default (directory-of-buffer (buffer (current-window)))
338     :default-type 'pathname
339     :insert-default t))
340 dmurray 1.10 "Prompt for a new filename for the current buffer.
341     The next time the buffer is saved it will be saved to a file with that filename."
342 dmurray 1.16 (set-visited-file-name filename (buffer (current-window))))
343 dmurray 1.1
344 dmurray 1.16 (define-command (com-insert-file :name t :command-table buffer-table)
345     ((filename 'pathname :prompt "Insert File"
346     :default (directory-of-buffer (buffer (current-window)))
347     :default-type 'pathname
348     :insert-default t))
349 dmurray 1.10 "Prompt for a filename and insert its contents at point.
350     Leaves mark after the inserted contents."
351 dmurray 1.16 (let ((pane (current-window)))
352 dmurray 1.1 (when (probe-file filename)
353     (setf (mark pane) (clone-mark (point pane) :left))
354     (with-open-file (stream filename :direction :input)
355     (input-from-stream stream
356     (buffer pane)
357     (offset (point pane))))
358     (psetf (offset (mark pane)) (offset (point pane))
359     (offset (point pane)) (offset (mark pane))))
360     (redisplay-frame-panes *application-frame*)))
361    
362 dmurray 1.16 (set-key `(com-insert-file ,*unsupplied-argument-marker*)
363 dmurray 1.1 'buffer-table
364     '((#\x :control) (#\i :control)))
365    
366     (define-command (com-revert-buffer :name t :command-table buffer-table) ()
367 dmurray 1.10 "Replace the contents of the current buffer with the visited file.
368     Signals an error if the file does not exist."
369 dmurray 1.1 (let* ((pane (current-window))
370     (buffer (buffer pane))
371     (filepath (filepath buffer))
372     (save (offset (point pane))))
373     (when (accept 'boolean :prompt (format nil "Revert buffer from file ~A?"
374     (filepath buffer)))
375     (cond ((directory-pathname-p filepath)
376     (display-message "~A is a directory name." filepath)
377     (beep))
378     ((probe-file filepath)
379 dmurray 1.11 (unless (check-file-times buffer filepath "Revert" "reverted")
380     (return-from com-revert-buffer))
381 dmurray 1.1 (erase-buffer buffer)
382     (with-open-file (stream filepath :direction :input)
383     (input-from-stream stream buffer 0))
384 dmurray 1.11 (setf (offset (point pane)) (min (size buffer) save)
385     (file-saved-p buffer) nil))
386 dmurray 1.1 (t
387     (display-message "No file ~A" filepath)
388     (beep))))))
389    
390 dmurray 1.11 (defun extract-version-number (pathname)
391     "Extracts the emacs-style version-number from a pathname."
392     (let* ((type (pathname-type pathname))
393     (length (length type)))
394     (when (and (> length 2) (char= (char type (1- length)) #\~))
395     (let ((tilde (position #\~ type :from-end t :end (- length 2))))
396     (when tilde
397     (parse-integer type :start (1+ tilde) :junk-allowed t))))))
398    
399     (defun version-number (pathname)
400     "Return the number of the highest versioned backup of PATHNAME
401     or 0 if there is no versioned backup. Looks for name.type~X~,
402     returns highest X."
403     (let* ((wildpath (merge-pathnames (make-pathname :type :wild) pathname))
404     (possibilities (directory wildpath)))
405     (loop for possibility in possibilities
406     for version = (extract-version-number possibility)
407     if (numberp version)
408     maximize version into max
409     finally (return max))))
410    
411     (defun check-file-times (buffer filepath question answer)
412     "Return NIL if filepath newer than buffer and user doesn't want to overwrite"
413     (let ((f-w-d (file-write-date filepath))
414     (f-w-t (file-write-time buffer)))
415     (if (and f-w-d f-w-t (> f-w-d f-w-t))
416     (if (accept 'boolean
417     :prompt (format nil "File has changed on disk. ~a anyway?"
418     question))
419     t
420     (progn (display-message "~a not ~a" filepath answer)
421     nil))
422     t)))
423    
424 dmurray 1.1 (defun save-buffer (buffer)
425     (let ((filepath (or (filepath buffer)
426     (accept 'pathname :prompt "Save Buffer to File"))))
427     (cond
428     ((directory-pathname-p filepath)
429     (display-message "~A is a directory." filepath)
430     (beep))
431     (t
432 dmurray 1.11 (unless (check-file-times buffer filepath "Overwrite" "written")
433     (return-from save-buffer))
434     (when (and (probe-file filepath) (not (file-saved-p buffer)))
435 dmurray 1.1 (let ((backup-name (pathname-name filepath))
436 dmurray 1.11 (backup-type (format nil "~A~~~D~~"
437     (pathname-type filepath)
438     (1+ (version-number filepath)))))
439 dmurray 1.1 (rename-file filepath (make-pathname :name backup-name
440 dmurray 1.11 :type backup-type)))
441     (setf (file-saved-p buffer) t))
442 dmurray 1.1 (with-open-file (stream filepath :direction :output :if-exists :supersede)
443     (output-to-stream stream buffer 0 (size buffer)))
444     (setf (filepath buffer) filepath
445 dmurray 1.11 (file-write-time buffer) (file-write-date filepath)
446 dmurray 1.1 (name buffer) (filepath-filename filepath))
447 dmurray 1.11 (display-message "Wrote: ~a" filepath)
448 dmurray 1.1 (setf (needs-saving buffer) nil)))))
449    
450     (define-command (com-save-buffer :name t :command-table buffer-table) ()
451 dmurray 1.10 "Write the contents of the buffer to a file.
452     If there is filename associated with the buffer, write to that file, replacing its contents. If not, prompt for a filename."
453 dmurray 1.1 (let ((buffer (buffer (current-window))))
454     (if (or (null (filepath buffer))
455     (needs-saving buffer))
456     (save-buffer buffer)
457     (display-message "No changes need to be saved from ~a" (name buffer)))))
458    
459     (set-key 'com-save-buffer
460     'buffer-table
461 thenriksen 1.14 '((#\x :control) (#\s :control)))
462 dmurray 1.1
463 tmoore 1.3 (defmethod frame-exit :around ((frame climacs) #-mcclim &key)
464 dmurray 1.1 (loop for buffer in (buffers frame)
465     when (and (needs-saving buffer)
466     (filepath buffer)
467     (handler-case (accept 'boolean
468     :prompt (format nil "Save buffer: ~a ?" (name buffer)))
469     (error () (progn (beep)
470     (display-message "Invalid answer")
471     (return-from frame-exit nil)))))
472     do (save-buffer buffer))
473     (when (or (notany #'(lambda (buffer) (and (needs-saving buffer) (filepath buffer)))
474     (buffers frame))
475     (handler-case (accept 'boolean :prompt "Modified buffers exist. Quit anyway?")
476     (error () (progn (beep)
477     (display-message "Invalid answer")
478     (return-from frame-exit nil)))))
479     (call-next-method)))
480    
481 dmurray 1.16 (define-command (com-write-buffer :name t :command-table buffer-table)
482     ((filepath '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.10 "Prompt for a filename and write the current buffer to it.
487     Changes the file visted by the buffer to the given file."
488 dmurray 1.16 (let ((buffer (buffer (current-window))))
489 dmurray 1.1 (cond
490     ((directory-pathname-p filepath)
491     (display-message "~A is a directory name." filepath))
492     (t
493     (with-open-file (stream filepath :direction :output :if-exists :supersede)
494     (output-to-stream stream buffer 0 (size buffer)))
495     (setf (filepath buffer) filepath
496     (name buffer) (filepath-filename filepath)
497     (needs-saving buffer) nil)
498     (display-message "Wrote: ~a" (filepath buffer))))))
499    
500 dmurray 1.16 (set-key `(com-write-buffer ,*unsupplied-argument-marker*)
501 dmurray 1.1 'buffer-table
502     '((#\x :control) (#\w :control)))
503    

  ViewVC Help
Powered by ViewVC 1.1.5