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

Contents of /climacs/file-commands.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (hide annotations)
Mon Mar 27 15:43:17 2006 UTC (8 years ago) by crhodes
Branch: MAIN
Changes since 1.4: +2 -3 lines
The order of events when executing a command must go:

1. execute the command
2. (a) update-syntax;
   (b) update needs-saving;
3. redisplay panes
4. clear-modify

Put 1. and 2. in execute-frame-command :after and 4. in
execute-frame-command :around; 3. happens in execute-frame-command
:around ESA.  It's not the tidiest implementation right now but it sort
of works.

Make sure that a loaded file has an up-to-date syntax and a cleared
modified flag.
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     ;; Adapted from cl-fad/PCL
133     (defun directory-pathname-p (pathspec)
134     "Returns NIL if PATHSPEC does not designate a directory."
135     (let ((name (pathname-name pathspec))
136     (type (pathname-type pathspec)))
137     (and (or (null name) (eql name :unspecific))
138     (or (null type) (eql type :unspecific)))))
139    
140     (defun find-file (filepath)
141     (cond ((null filepath)
142     (display-message "No file name given.")
143     (beep))
144     ((directory-pathname-p filepath)
145     (display-message "~A is a directory name." filepath)
146     (beep))
147     (t
148     (let ((existing-buffer (find filepath (buffers *application-frame*)
149     :key #'filepath :test #'equal)))
150     (if existing-buffer
151     (switch-to-buffer existing-buffer)
152     (let ((buffer (make-buffer))
153     (pane (current-window)))
154     (setf (offset (point (buffer pane))) (offset (point pane)))
155     (setf (buffer (current-window)) buffer)
156     (setf (syntax buffer)
157     (make-instance (syntax-class-name-for-filepath filepath)
158 crhodes 1.4 :buffer buffer))
159 dmurray 1.1 ;; Don't want to create the file if it doesn't exist.
160     (when (probe-file filepath)
161     (with-open-file (stream filepath :direction :input)
162     (input-from-stream stream buffer 0)))
163     (setf (filepath buffer) filepath
164     (name buffer) (filepath-filename filepath)
165     (needs-saving buffer) nil)
166     (beginning-of-buffer (point pane))
167 crhodes 1.5 (update-syntax buffer (syntax buffer))
168     (clear-modify buffer)
169 dmurray 1.1 buffer))))))
170    
171 dmurray 1.2 (defun directory-of-buffer (buffer)
172     "Extract the directory part of the filepath to the file in BUFFER.
173     If BUFFER does not have a filepath, the path to the users home
174     directory will be returned."
175     (make-pathname
176     :directory
177     (pathname-directory
178     (or (filepath buffer)
179     (user-homedir-pathname)))))
180    
181 dmurray 1.1 (define-command (com-find-file :name t :command-table buffer-table) ()
182 dmurray 1.2 (let* ((filepath (accept 'pathname :prompt "Find File"
183     :default (directory-of-buffer (buffer (current-window)))
184     :default-type 'pathname
185     :insert-default t)))
186 dmurray 1.1 (find-file filepath)))
187    
188     (set-key 'com-find-file
189     'buffer-table
190     '((#\x :control) (#\f :control)))
191    
192     (defun find-file-read-only (filepath)
193     (cond ((null filepath)
194     (display-message "No file name given.")
195     (beep))
196     ((directory-pathname-p filepath)
197     (display-message "~A is a directory name." filepath)
198     (beep))
199     (t
200     (let ((existing-buffer (find filepath (buffers *application-frame*)
201     :key #'filepath :test #'equal)))
202     (if (and existing-buffer (read-only-p existing-buffer))
203     (switch-to-buffer existing-buffer)
204     (if (probe-file filepath)
205     (let ((buffer (make-buffer))
206     (pane (current-window)))
207     (setf (offset (point (buffer pane))) (offset (point pane)))
208     (setf (buffer (current-window)) buffer)
209     (setf (syntax buffer)
210     (make-instance (syntax-class-name-for-filepath filepath)
211     :buffer (buffer (point pane))))
212     (with-open-file (stream filepath :direction :input)
213     (input-from-stream stream buffer 0))
214     (setf (filepath buffer) filepath
215     (name buffer) (filepath-filename filepath)
216     (needs-saving buffer) nil
217     (read-only-p buffer) t)
218     (beginning-of-buffer (point pane))
219     ;; this one is needed so that the buffer modification protocol
220     ;; resets the low and high marks after redisplay
221     (redisplay-frame-panes *application-frame*)
222     buffer)
223     (progn
224     (display-message "No such file: ~A" filepath)
225     (beep)
226     nil)))))))
227    
228     (define-command (com-find-file-read-only :name t :command-table buffer-table) ()
229 dmurray 1.2 (let ((filepath (accept 'pathname :Prompt "Find file read only"
230     :default (directory-of-buffer (buffer (current-window)))
231     :default-type 'pathname
232     :insert-default t)))
233 dmurray 1.1 (find-file-read-only filepath)))
234    
235     (set-key 'com-find-file-read-only
236     'buffer-table
237     '((#\x :control) (#\r :control)))
238    
239     (define-command (com-read-only :name t :command-table buffer-table) ()
240     (let ((buffer (buffer (current-window))))
241     (setf (read-only-p buffer) (not (read-only-p buffer)))))
242    
243     (set-key 'com-read-only
244     'buffer-table
245     '((#\x :control) (#\q :control)))
246    
247     (defun set-visited-file-name (filename buffer)
248     (setf (filepath buffer) filename
249     (name buffer) (filepath-filename filename)
250     (needs-saving buffer) t))
251    
252     (define-command (com-set-visited-file-name :name t :command-table buffer-table) ()
253 dmurray 1.2 (let ((filename (accept 'pathname :prompt "New file name"
254     :default (directory-of-buffer (buffer (current-window)))
255     :default-type 'pathname
256     :insert-default t)))
257 dmurray 1.1 (set-visited-file-name filename (buffer (current-window)))))
258    
259     (define-command (com-insert-file :name t :command-table buffer-table) ()
260 dmurray 1.2 (let ((filename (accept 'pathname :prompt "Insert File"
261     :default (directory-of-buffer (buffer (current-window)))
262     :default-type 'pathname
263     :insert-default t))
264 dmurray 1.1 (pane (current-window)))
265     (when (probe-file filename)
266     (setf (mark pane) (clone-mark (point pane) :left))
267     (with-open-file (stream filename :direction :input)
268     (input-from-stream stream
269     (buffer pane)
270     (offset (point pane))))
271     (psetf (offset (mark pane)) (offset (point pane))
272     (offset (point pane)) (offset (mark pane))))
273     (redisplay-frame-panes *application-frame*)))
274    
275     (set-key 'com-insert-file
276     'buffer-table
277     '((#\x :control) (#\i :control)))
278    
279     (define-command (com-revert-buffer :name t :command-table buffer-table) ()
280     (let* ((pane (current-window))
281     (buffer (buffer pane))
282     (filepath (filepath buffer))
283     (save (offset (point pane))))
284     (when (accept 'boolean :prompt (format nil "Revert buffer from file ~A?"
285     (filepath buffer)))
286     (cond ((directory-pathname-p filepath)
287     (display-message "~A is a directory name." filepath)
288     (beep))
289     ((probe-file filepath)
290     (erase-buffer buffer)
291     (with-open-file (stream filepath :direction :input)
292     (input-from-stream stream buffer 0))
293     (setf (offset (point pane))
294     (min (size buffer) save)))
295     (t
296     (display-message "No file ~A" filepath)
297     (beep))))))
298    
299     (defun save-buffer (buffer)
300     (let ((filepath (or (filepath buffer)
301     (accept 'pathname :prompt "Save Buffer to File"))))
302     (cond
303     ((directory-pathname-p filepath)
304     (display-message "~A is a directory." filepath)
305     (beep))
306     (t
307     (when (probe-file filepath)
308     (let ((backup-name (pathname-name filepath))
309     (backup-type (concatenate 'string (pathname-type filepath) "~")))
310     (rename-file filepath (make-pathname :name backup-name
311     :type backup-type))))
312     (with-open-file (stream filepath :direction :output :if-exists :supersede)
313     (output-to-stream stream buffer 0 (size buffer)))
314     (setf (filepath buffer) filepath
315     (name buffer) (filepath-filename filepath))
316     (display-message "Wrote: ~a" (filepath buffer))
317     (setf (needs-saving buffer) nil)))))
318    
319     (define-command (com-save-buffer :name t :command-table buffer-table) ()
320     (let ((buffer (buffer (current-window))))
321     (if (or (null (filepath buffer))
322     (needs-saving buffer))
323     (save-buffer buffer)
324     (display-message "No changes need to be saved from ~a" (name buffer)))))
325    
326     (set-key 'com-save-buffer
327     'buffer-table
328     '((#\x :control) (#\s :control)))
329    
330 tmoore 1.3 (defmethod frame-exit :around ((frame climacs) #-mcclim &key)
331 dmurray 1.1 (loop for buffer in (buffers frame)
332     when (and (needs-saving buffer)
333     (filepath buffer)
334     (handler-case (accept 'boolean
335     :prompt (format nil "Save buffer: ~a ?" (name buffer)))
336     (error () (progn (beep)
337     (display-message "Invalid answer")
338     (return-from frame-exit nil)))))
339     do (save-buffer buffer))
340     (when (or (notany #'(lambda (buffer) (and (needs-saving buffer) (filepath buffer)))
341     (buffers frame))
342     (handler-case (accept 'boolean :prompt "Modified buffers exist. Quit anyway?")
343     (error () (progn (beep)
344     (display-message "Invalid answer")
345     (return-from frame-exit nil)))))
346     (call-next-method)))
347    
348     (define-command (com-write-buffer :name t :command-table buffer-table) ()
349 dmurray 1.2 (let ((filepath (accept 'pathname :prompt "Write Buffer to File"
350     :default (directory-of-buffer (buffer (current-window)))
351     :default-type 'pathname
352     :insert-default t))
353 dmurray 1.1 (buffer (buffer (current-window))))
354     (cond
355     ((directory-pathname-p filepath)
356     (display-message "~A is a directory name." filepath))
357     (t
358     (with-open-file (stream filepath :direction :output :if-exists :supersede)
359     (output-to-stream stream buffer 0 (size buffer)))
360     (setf (filepath buffer) filepath
361     (name buffer) (filepath-filename filepath)
362     (needs-saving buffer) nil)
363     (display-message "Wrote: ~a" (filepath buffer))))))
364    
365     (set-key 'com-write-buffer
366     'buffer-table
367     '((#\x :control) (#\w :control)))
368    

  ViewVC Help
Powered by ViewVC 1.1.5