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

Contents of /climacs/file-commands.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.24 - (show annotations)
Sun Aug 20 13:06:39 2006 UTC (7 years, 8 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 ;;; -*- 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 (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
31 (in-package :climacs-commands)
32
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 (values (or pathname (parse-namestring string)) type))
113 ((and (zerop (length string))
114 defaultp)
115 (values default default-type))
116 (t (values string 'string)))))
117
118 (define-command (com-reparse-attribute-list :name t :command-table buffer-table)
119 ()
120 "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 (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
156 (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 "Prompt for a filename and insert its contents at point.
162 Leaves mark after the inserted contents."
163 (let ((pane (current-window)))
164 (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 (set-key `(com-insert-file ,*unsupplied-argument-marker*)
175 'buffer-table
176 '((#\x :control) (#\i :control)))
177
178 (define-command (com-revert-buffer :name t :command-table buffer-table) ()
179 "Replace the contents of the current buffer with the visited file.
180 Signals an error if the file does not exist."
181 (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 (unless (check-file-times buffer filepath "Revert" "reverted")
192 (return-from com-revert-buffer))
193 (erase-buffer buffer)
194 (with-open-file (stream filepath :direction :input)
195 (input-from-stream stream buffer 0))
196 (setf (offset (point pane)) (min (size buffer) save)
197 (file-saved-p buffer) nil))
198 (t
199 (display-message "No file ~A" filepath)
200 (beep))))))
201
202 (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 ((buffer 'buffer :default (current-buffer *application-frame*)))
258 (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 ((buffer 'buffer :default (current-buffer *application-frame*)))
268 (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