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

Contents of /climacs/file-commands.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.24 - (hide annotations)
Sun Aug 20 13:06:39 2006 UTC (7 years, 7 months ago) by thenriksen
Branch: MAIN
Changes since 1.23: +5 -85 lines
Changed Climacs to use the ESA-IO and ESA-BUFFER functionality instead
of duplicating essentially the same code across multiple
projects. This is rather invasive as some of the ESA functions have a
subtly different signature.
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.24 ;;; File (and buffer) commands for the Climacs editor. Note that many
28     ;;; basic commands (such as Find File) are defined in ESA and made
29     ;;; available to Climacs via the ESA-IO-TABLE command table.
30 dmurray 1.1
31 thenriksen 1.21 (in-package :climacs-commands)
32 dmurray 1.1
33     (defun filename-completer (so-far mode)
34     (flet ((remove-trail (s)
35     (subseq s 0 (let ((pos (position #\/ s :from-end t)))
36     (if pos (1+ pos) 0)))))
37     (let* ((directory-prefix
38     (if (and (plusp (length so-far)) (eql (aref so-far 0) #\/))
39     ""
40     (namestring #+sbcl *default-pathname-defaults*
41     #+cmu (ext:default-directory)
42     #-(or sbcl cmu) *default-pathname-defaults*)))
43     (full-so-far (concatenate 'string directory-prefix so-far))
44     (pathnames
45     (loop with length = (length full-so-far)
46     and wildcard = (concatenate 'string (remove-trail so-far) "*.*")
47     for path in
48     #+(or sbcl cmu lispworks) (directory wildcard)
49     #+openmcl (directory wildcard :directories t)
50     #+allegro (directory wildcard :directories-are-files nil)
51     #+cormanlisp (nconc (directory wildcard)
52     (cl::directory-subdirs dirname))
53     #-(or sbcl cmu lispworks openmcl allegro cormanlisp)
54     (directory wildcard)
55     when (let ((mismatch (mismatch (namestring path) full-so-far)))
56     (or (null mismatch) (= mismatch length)))
57     collect path))
58     (strings (mapcar #'namestring pathnames))
59     (first-string (car strings))
60     (length-common-prefix nil)
61     (completed-string nil)
62     (full-completed-string nil))
63     (unless (null pathnames)
64     (setf length-common-prefix
65     (loop with length = (length first-string)
66     for string in (cdr strings)
67     do (setf length (min length (or (mismatch string first-string) length)))
68     finally (return length))))
69     (unless (null pathnames)
70     (setf completed-string
71     (subseq first-string (length directory-prefix)
72     (if (null (cdr pathnames)) nil length-common-prefix)))
73     (setf full-completed-string
74     (concatenate 'string directory-prefix completed-string)))
75     (case mode
76     ((:complete-limited :complete-maximal)
77     (cond ((null pathnames)
78     (values so-far nil nil 0 nil))
79     ((null (cdr pathnames))
80     (values completed-string t (car pathnames) 1 nil))
81     (t
82     (values completed-string nil nil (length pathnames) nil))))
83     (:complete
84     (cond ((null pathnames)
85     (values so-far t so-far 1 nil))
86     ((null (cdr pathnames))
87     (values completed-string t (car pathnames) 1 nil))
88     ((find full-completed-string strings :test #'string-equal)
89     (let ((pos (position full-completed-string strings :test #'string-equal)))
90     (values completed-string
91     t (elt pathnames pos) (length pathnames) nil)))
92     (t
93     (values completed-string nil nil (length pathnames) nil))))
94     (:possibilities
95     (values nil nil nil (length pathnames)
96     (loop with length = (length directory-prefix)
97     for name in pathnames
98     collect (list (subseq (namestring name) length nil)
99     name))))))))
100    
101     (define-presentation-method present (object (type pathname)
102     stream (view climacs-textual-view) &key)
103     (princ (namestring object) stream))
104    
105     (define-presentation-method accept ((type pathname) stream (view climacs-textual-view)
106     &key (default nil defaultp) (default-type type))
107     (multiple-value-bind (pathname success string)
108     (complete-input stream
109     #'filename-completer
110     :allow-any-input t)
111     (cond (success
112 tmoore 1.3 (values (or pathname (parse-namestring string)) type))
113 dmurray 1.1 ((and (zerop (length string))
114     defaultp)
115     (values default default-type))
116     (t (values string 'string)))))
117    
118 thenriksen 1.23 (define-command (com-reparse-attribute-list :name t :command-table buffer-table)
119     ()
120 dmurray 1.12 "Reparse the current buffer's attribute list.
121     An attribute list is a line of keyword-value pairs, each keyword separated
122     from the corresponding value by a colon. If another keyword-value pair
123     follows, the value should be terminated by a colon. The attribute list
124     is surrounded by '-*-' sequences, but the opening '-*-' need not be at the
125     beginning of the line. Climacs looks for the attribute list
126     on the first or second non-blank line of the file.
127    
128     An example attribute-list is:
129    
130     ;; -*- Syntax: Lisp; Base: 10 -*- "
131 thenriksen 1.23 (evaluate-attribute-line (buffer (current-window))))
132    
133     (define-command (com-update-attribute-list :name t :command-table buffer-table)
134     ()
135     "Update the current buffers attribute list to reflect the
136     settings of the syntax of the buffer.
137    
138     After the attribute list has been updated, it will also be
139     re-evaluated. An attribute list is a line of keyword-value pairs,
140     each keyword separated from the corresponding value by a
141     colon. If another keyword-value pair follows, the value should be
142     terminated by a colon. The attribute list is surrounded by '-*-'
143     sequences, but the opening '-*-' need not be at the beginning of
144     the line. Climacs looks for the attribute list on the first or
145     second non-blank line of the file.
146    
147     An example attribute-list is:
148    
149     ;; -*- Syntax: Lisp; Base: 10 -*-
150    
151     This command automatically comments the attribute line as
152     appropriate for the syntax of the buffer."
153     (update-attribute-line (buffer (current-window)))
154     (evaluate-attribute-line (buffer (current-window))))
155 thenriksen 1.6
156 dmurray 1.16 (define-command (com-insert-file :name t :command-table buffer-table)
157     ((filename 'pathname :prompt "Insert File"
158     :default (directory-of-buffer (buffer (current-window)))
159     :default-type 'pathname
160     :insert-default t))
161 dmurray 1.10 "Prompt for a filename and insert its contents at point.
162     Leaves mark after the inserted contents."
163 dmurray 1.16 (let ((pane (current-window)))
164 dmurray 1.1 (when (probe-file filename)
165     (setf (mark pane) (clone-mark (point pane) :left))
166     (with-open-file (stream filename :direction :input)
167     (input-from-stream stream
168     (buffer pane)
169     (offset (point pane))))
170     (psetf (offset (mark pane)) (offset (point pane))
171     (offset (point pane)) (offset (mark pane))))
172     (redisplay-frame-panes *application-frame*)))
173    
174 dmurray 1.16 (set-key `(com-insert-file ,*unsupplied-argument-marker*)
175 dmurray 1.1 'buffer-table
176     '((#\x :control) (#\i :control)))
177    
178     (define-command (com-revert-buffer :name t :command-table buffer-table) ()
179 dmurray 1.10 "Replace the contents of the current buffer with the visited file.
180     Signals an error if the file does not exist."
181 dmurray 1.1 (let* ((pane (current-window))
182     (buffer (buffer pane))
183     (filepath (filepath buffer))
184     (save (offset (point pane))))
185     (when (accept 'boolean :prompt (format nil "Revert buffer from file ~A?"
186     (filepath buffer)))
187     (cond ((directory-pathname-p filepath)
188     (display-message "~A is a directory name." filepath)
189     (beep))
190     ((probe-file filepath)
191 dmurray 1.11 (unless (check-file-times buffer filepath "Revert" "reverted")
192     (return-from com-revert-buffer))
193 dmurray 1.1 (erase-buffer buffer)
194     (with-open-file (stream filepath :direction :input)
195     (input-from-stream stream buffer 0))
196 dmurray 1.11 (setf (offset (point pane)) (min (size buffer) save)
197     (file-saved-p buffer) nil))
198 dmurray 1.1 (t
199     (display-message "No file ~A" filepath)
200     (beep))))))
201    
202 thenriksen 1.22 (defun load-file (file-name)
203     (cond ((directory-pathname-p file-name)
204     (display-message "~A is a directory name." file-name)
205     (beep))
206     (t
207     (cond ((probe-file file-name)
208     (load file-name))
209     (t
210     (display-message "No such file: ~A" file-name)
211     (beep))))))
212    
213     (define-command (com-load-file :name t :command-table base-table) ()
214     "Prompt for a filename and CL:LOAD that file.
215     Signals and error if the file does not exist."
216     (let ((filepath (accept 'pathname :prompt "Load File")))
217     (load-file filepath)))
218    
219     (set-key 'com-load-file
220     'base-table
221     '((#\c :control) (#\l :control)))
222    
223     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
224     ;;;
225     ;;; Buffer commands
226    
227     (define-command (com-switch-to-buffer :name t :command-table pane-table) ()
228     "Prompt for a buffer name and switch to that buffer.
229     If the a buffer with that name does not exist, create it. Uses the name of the next buffer (if any) as a default."
230     (let* ((default (second (buffers *application-frame*)))
231     (buffer (if default
232     (accept 'buffer
233     :prompt "Switch to buffer"
234     :default default)
235     (accept 'buffer
236     :prompt "Switch to buffer"))))
237     (switch-to-buffer buffer)))
238    
239     (set-key 'com-switch-to-buffer
240     'pane-table
241     '((#\x :control) (#\b)))
242    
243     (define-command (com-kill-buffer :name t :command-table pane-table)
244     ((buffer 'buffer
245     :prompt "Kill buffer"
246     :default (buffer (current-window))
247     :default-type 'buffer))
248     "Prompt for a buffer name and kill that buffer.
249     If the buffer needs saving, will prompt you to do so before killing it. Uses the current buffer as a default."
250     (kill-buffer buffer))
251    
252     (set-key `(com-kill-buffer ,*unsupplied-argument-marker*)
253     'pane-table
254     '((#\x :control) (#\k)))
255    
256     (define-command (com-toggle-read-only :name t :command-table base-table)
257 thenriksen 1.24 ((buffer 'buffer :default (current-buffer *application-frame*)))
258 thenriksen 1.22 (setf (read-only-p buffer) (not (read-only-p buffer))))
259    
260     (define-presentation-to-command-translator toggle-read-only
261     (read-only com-toggle-read-only base-table
262     :gesture :menu)
263     (object)
264     (list object))
265    
266     (define-command (com-toggle-modified :name t :command-table base-table)
267 thenriksen 1.24 ((buffer 'buffer :default (current-buffer *application-frame*)))
268 thenriksen 1.22 (setf (needs-saving buffer) (not (needs-saving buffer))))
269    
270     (define-presentation-to-command-translator toggle-modified
271     (modified com-toggle-modified base-table
272     :gesture :menu)
273     (object)
274     (list object))

  ViewVC Help
Powered by ViewVC 1.1.5