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

Contents of /climacs/file-commands.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.22 - (hide annotations)
Tue Jul 25 11:38:05 2006 UTC (7 years, 8 months ago) by thenriksen
Branch: MAIN
Changes since 1.21: +74 -255 lines
More refactoring of stuff out from CLIMACS-GUI to CLIMACS-CORE and
CLIMACS-COMMANDS. More reusable functions have been moved from the
*-commands.lisp files to core.lisp.
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 thenriksen 1.22 ;;; File (and buffer) commands for the Climacs editor.
28 dmurray 1.1
29 thenriksen 1.21 (in-package :climacs-commands)
30 dmurray 1.1
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 dmurray 1.12 (define-command (com-reparse-attribute-list :name t :command-table buffer-table) ()
117     "Reparse the current buffer's attribute list.
118     An attribute list is a line of keyword-value pairs, each keyword separated
119     from the corresponding value by a colon. If another keyword-value pair
120     follows, the value should be terminated by a colon. The attribute list
121     is surrounded by '-*-' sequences, but the opening '-*-' need not be at the
122     beginning of the line. Climacs looks for the attribute list
123     on the first or second non-blank line of the file.
124    
125     An example attribute-list is:
126    
127     ;; -*- Syntax: Lisp; Base: 10 -*- "
128     (evaluate-attributes-line (buffer (current-window))))
129 thenriksen 1.6
130 dmurray 1.16 (define-command (com-find-file :name t :command-table buffer-table)
131     ((filepath 'pathname
132     :prompt "Find File"
133     :default (directory-of-buffer (buffer (current-window)))
134     :default-type 'pathname
135     :insert-default t))
136 dmurray 1.10 "Prompt for a filename then edit that file.
137     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."
138 dmurray 1.16 (find-file filepath))
139 dmurray 1.1
140 dmurray 1.16 (set-key `(com-find-file ,*unsupplied-argument-marker*)
141 dmurray 1.1 'buffer-table
142     '((#\x :control) (#\f :control)))
143    
144 dmurray 1.16 (define-command (com-find-file-read-only :name t :command-table buffer-table)
145     ((filepath 'pathname :Prompt "Find file read only"
146     :default (directory-of-buffer (buffer (current-window)))
147     :default-type 'pathname
148     :insert-default t))
149 dmurray 1.10 "Prompt for a filename then open that file readonly.
150     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."
151 dmurray 1.16 (find-file filepath t))
152 dmurray 1.1
153 dmurray 1.16 (set-key `(com-find-file-read-only ,*unsupplied-argument-marker*)
154 dmurray 1.1 'buffer-table
155     '((#\x :control) (#\r :control)))
156    
157     (define-command (com-read-only :name t :command-table buffer-table) ()
158 dmurray 1.10 "Toggle the readonly status of the current buffer.
159     When a buffer is readonly, attempts to change the contents of the buffer signal an error."
160 dmurray 1.1 (let ((buffer (buffer (current-window))))
161     (setf (read-only-p buffer) (not (read-only-p buffer)))))
162    
163     (set-key 'com-read-only
164     'buffer-table
165     '((#\x :control) (#\q :control)))
166    
167 dmurray 1.16 (define-command (com-set-visited-file-name :name t :command-table buffer-table)
168     ((filename 'pathname :prompt "New file name"
169     :default (directory-of-buffer (buffer (current-window)))
170     :default-type 'pathname
171     :insert-default t))
172 dmurray 1.10 "Prompt for a new filename for the current buffer.
173     The next time the buffer is saved it will be saved to a file with that filename."
174 dmurray 1.16 (set-visited-file-name filename (buffer (current-window))))
175 dmurray 1.1
176 dmurray 1.16 (define-command (com-insert-file :name t :command-table buffer-table)
177     ((filename 'pathname :prompt "Insert File"
178     :default (directory-of-buffer (buffer (current-window)))
179     :default-type 'pathname
180     :insert-default t))
181 dmurray 1.10 "Prompt for a filename and insert its contents at point.
182     Leaves mark after the inserted contents."
183 dmurray 1.16 (let ((pane (current-window)))
184 dmurray 1.1 (when (probe-file filename)
185     (setf (mark pane) (clone-mark (point pane) :left))
186     (with-open-file (stream filename :direction :input)
187     (input-from-stream stream
188     (buffer pane)
189     (offset (point pane))))
190     (psetf (offset (mark pane)) (offset (point pane))
191     (offset (point pane)) (offset (mark pane))))
192     (redisplay-frame-panes *application-frame*)))
193    
194 dmurray 1.16 (set-key `(com-insert-file ,*unsupplied-argument-marker*)
195 dmurray 1.1 'buffer-table
196     '((#\x :control) (#\i :control)))
197    
198     (define-command (com-revert-buffer :name t :command-table buffer-table) ()
199 dmurray 1.10 "Replace the contents of the current buffer with the visited file.
200     Signals an error if the file does not exist."
201 dmurray 1.1 (let* ((pane (current-window))
202     (buffer (buffer pane))
203     (filepath (filepath buffer))
204     (save (offset (point pane))))
205     (when (accept 'boolean :prompt (format nil "Revert buffer from file ~A?"
206     (filepath buffer)))
207     (cond ((directory-pathname-p filepath)
208     (display-message "~A is a directory name." filepath)
209     (beep))
210     ((probe-file filepath)
211 dmurray 1.11 (unless (check-file-times buffer filepath "Revert" "reverted")
212     (return-from com-revert-buffer))
213 dmurray 1.1 (erase-buffer buffer)
214     (with-open-file (stream filepath :direction :input)
215     (input-from-stream stream buffer 0))
216 dmurray 1.11 (setf (offset (point pane)) (min (size buffer) save)
217     (file-saved-p buffer) nil))
218 dmurray 1.1 (t
219     (display-message "No file ~A" filepath)
220     (beep))))))
221    
222     (define-command (com-save-buffer :name t :command-table buffer-table) ()
223 dmurray 1.10 "Write the contents of the buffer to a file.
224     If there is filename associated with the buffer, write to that file, replacing its contents. If not, prompt for a filename."
225 dmurray 1.1 (let ((buffer (buffer (current-window))))
226     (if (or (null (filepath buffer))
227     (needs-saving buffer))
228     (save-buffer buffer)
229     (display-message "No changes need to be saved from ~a" (name buffer)))))
230    
231     (set-key 'com-save-buffer
232     'buffer-table
233 thenriksen 1.14 '((#\x :control) (#\s :control)))
234 dmurray 1.1
235 dmurray 1.16 (define-command (com-write-buffer :name t :command-table buffer-table)
236     ((filepath 'pathname :prompt "Write Buffer to File"
237     :default (directory-of-buffer (buffer (current-window)))
238     :default-type 'pathname
239     :insert-default t))
240 dmurray 1.10 "Prompt for a filename and write the current buffer to it.
241     Changes the file visted by the buffer to the given file."
242 dmurray 1.16 (let ((buffer (buffer (current-window))))
243 dmurray 1.1 (cond
244     ((directory-pathname-p filepath)
245     (display-message "~A is a directory name." filepath))
246     (t
247     (with-open-file (stream filepath :direction :output :if-exists :supersede)
248     (output-to-stream stream buffer 0 (size buffer)))
249     (setf (filepath buffer) filepath
250     (name buffer) (filepath-filename filepath)
251     (needs-saving buffer) nil)
252     (display-message "Wrote: ~a" (filepath buffer))))))
253    
254 dmurray 1.16 (set-key `(com-write-buffer ,*unsupplied-argument-marker*)
255 dmurray 1.1 'buffer-table
256     '((#\x :control) (#\w :control)))
257    
258 thenriksen 1.22 (defun load-file (file-name)
259     (cond ((directory-pathname-p file-name)
260     (display-message "~A is a directory name." file-name)
261     (beep))
262     (t
263     (cond ((probe-file file-name)
264     (load file-name))
265     (t
266     (display-message "No such file: ~A" file-name)
267     (beep))))))
268    
269     (define-command (com-load-file :name t :command-table base-table) ()
270     "Prompt for a filename and CL:LOAD that file.
271     Signals and error if the file does not exist."
272     (let ((filepath (accept 'pathname :prompt "Load File")))
273     (load-file filepath)))
274    
275     (set-key 'com-load-file
276     'base-table
277     '((#\c :control) (#\l :control)))
278    
279     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
280     ;;;
281     ;;; Buffer commands
282    
283     (define-command (com-switch-to-buffer :name t :command-table pane-table) ()
284     "Prompt for a buffer name and switch to that buffer.
285     If the a buffer with that name does not exist, create it. Uses the name of the next buffer (if any) as a default."
286     (let* ((default (second (buffers *application-frame*)))
287     (buffer (if default
288     (accept 'buffer
289     :prompt "Switch to buffer"
290     :default default)
291     (accept 'buffer
292     :prompt "Switch to buffer"))))
293     (switch-to-buffer buffer)))
294    
295     (set-key 'com-switch-to-buffer
296     'pane-table
297     '((#\x :control) (#\b)))
298    
299     (define-command (com-kill-buffer :name t :command-table pane-table)
300     ((buffer 'buffer
301     :prompt "Kill buffer"
302     :default (buffer (current-window))
303     :default-type 'buffer))
304     "Prompt for a buffer name and kill that buffer.
305     If the buffer needs saving, will prompt you to do so before killing it. Uses the current buffer as a default."
306     (kill-buffer buffer))
307    
308     (set-key `(com-kill-buffer ,*unsupplied-argument-marker*)
309     'pane-table
310     '((#\x :control) (#\k)))
311    
312     (define-command (com-toggle-read-only :name t :command-table base-table)
313     ((buffer 'buffer :default (current-buffer)))
314     (setf (read-only-p buffer) (not (read-only-p buffer))))
315    
316     (define-presentation-to-command-translator toggle-read-only
317     (read-only com-toggle-read-only base-table
318     :gesture :menu)
319     (object)
320     (list object))
321    
322     (define-command (com-toggle-modified :name t :command-table base-table)
323     ((buffer 'buffer :default (current-buffer)))
324     (setf (needs-saving buffer) (not (needs-saving buffer))))
325    
326     (define-presentation-to-command-translator toggle-modified
327     (modified com-toggle-modified base-table
328     :gesture :menu)
329     (object)
330     (list object))

  ViewVC Help
Powered by ViewVC 1.1.5