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

Contents of /climacs/file-commands.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (show annotations)
Sun Apr 23 18:38:03 2006 UTC (7 years, 11 months ago) by thenriksen
Branch: MAIN
Changes since 1.7: +4 -0 lines
Added code to clear the pane before loading the new buffer into it.
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 (values (or pathname (parse-namestring string)) type))
111 ((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 (defun parse-local-options-line (line)
133 "Parse the local options line `line' and return an alist
134 mapping options to values. All option names will be coerced to
135 uppercase. `Line' must be stripped of the leading and
136 terminating -*- tokens."
137 (loop for pair in (split-sequence:split-sequence #\; line)
138 when (find #\: pair)
139 collect (destructuring-bind (key value)
140 (loop for elem in (split-sequence:split-sequence #\: pair)
141 collecting (string-trim " " elem))
142 (list (string-upcase key) value))))
143
144 (defun evaluate-local-options (buffer options)
145 "Evaluate the local options `options' and modify `buffer' as
146 appropriate. `Options' should be an alist mapping option names
147 to their values."
148 ;; First, check whether we need to change the syntax (via the SYNTAX
149 ;; option). MODE is an alias for SYNTAX for compatibility with
150 ;; Emacs. If there is more than one option with one of these names,
151 ;; only the first will be acted upon.
152 (let ((specified-syntax
153 (syntax-from-name
154 (second (find-if #'(lambda (name)
155 (or (string= name "SYNTAX")
156 (string= name "MODE")))
157 options
158 :key #'first)))))
159 (when specified-syntax
160 (setf (syntax buffer)
161 (make-instance specified-syntax
162 :buffer buffer))))
163 ;; Now we iterate through the options (discarding SYNTAX and MODE
164 ;; options).
165 (loop for (name value) in options
166 unless (or (string= name "SYNTAX")
167 (string= name "MODE"))
168 do (eval-option (syntax buffer) name value)))
169
170 (defun evaluate-local-options-line (buffer)
171 "Evaluate the local options line of `buffer'. If `buffer' does
172 not have a local options line, this function is a no-op."
173 ;; This could be simplified a bit by using regexps.
174 (let* ((beginning-mark (beginning-of-buffer
175 (clone-mark (point buffer))))
176 (end-mark (end-of-line (clone-mark beginning-mark)))
177 (line (buffer-sequence buffer (offset beginning-mark) (offset end-mark)))
178 (first-occurence (search "-*-" line))
179 (second-occurence
180 (when first-occurence
181 (search "-*-" line :start2 (1+ first-occurence)))))
182 (when (and first-occurence
183 second-occurence)
184 ;; Strip away the -*-s.
185 (let ((cleaned-options-line (coerce (subseq line
186 (+ first-occurence 3)
187 second-occurence)
188 'string)))
189 (evaluate-local-options
190 buffer
191 (parse-local-options-line cleaned-options-line))))))
192
193 ;; Adapted from cl-fad/PCL
194 (defun directory-pathname-p (pathspec)
195 "Returns NIL if PATHSPEC does not designate a directory."
196 (let ((name (pathname-name pathspec))
197 (type (pathname-type pathspec)))
198 (and (or (null name) (eql name :unspecific))
199 (or (null type) (eql type :unspecific)))))
200
201 (defun find-file (filepath)
202 (cond ((null filepath)
203 (display-message "No file name given.")
204 (beep))
205 ((directory-pathname-p filepath)
206 (display-message "~A is a directory name." filepath)
207 (beep))
208 (t
209 (let ((existing-buffer (find filepath (buffers *application-frame*)
210 :key #'filepath :test #'equal)))
211 (if existing-buffer
212 (switch-to-buffer existing-buffer)
213 (let ((buffer (make-buffer))
214 (pane (current-window)))
215 ;; Clear the pane, otherwise residue from the
216 ;; previously displayed buffer may under certain
217 ;; circumstances be displayed.
218 (window-clear pane)
219 (setf (syntax buffer) nil)
220 (setf (offset (point (buffer pane))) (offset (point pane)))
221 (setf (buffer (current-window)) buffer)
222 ;; Don't want to create the file if it doesn't exist.
223 (when (probe-file filepath)
224 (with-open-file (stream filepath :direction :input)
225 (input-from-stream stream buffer 0))
226 ;; A file! That means we may have a local options
227 ;; line to parse.
228 (evaluate-local-options-line buffer))
229 ;; If the local options line didn't set a syntax, do
230 ;; it now.
231 (when (null (syntax buffer))
232 (setf (syntax buffer)
233 (make-instance (syntax-class-name-for-filepath filepath)
234 :buffer buffer)))
235 (setf (filepath buffer) filepath
236 (name buffer) (filepath-filename filepath)
237 (needs-saving buffer) nil)
238 (beginning-of-buffer (point pane))
239 (update-syntax buffer (syntax buffer))
240 (clear-modify buffer)
241 buffer))))))
242
243 (defun directory-of-buffer (buffer)
244 "Extract the directory part of the filepath to the file in BUFFER.
245 If BUFFER does not have a filepath, the path to the users home
246 directory will be returned."
247 (make-pathname
248 :directory
249 (pathname-directory
250 (or (filepath buffer)
251 (user-homedir-pathname)))))
252
253 (define-command (com-find-file :name t :command-table buffer-table) ()
254 (let* ((filepath (accept 'pathname :prompt "Find File"
255 :default (directory-of-buffer (buffer (current-window)))
256 :default-type 'pathname
257 :insert-default t)))
258 (find-file filepath)))
259
260 (set-key 'com-find-file
261 'buffer-table
262 '((#\x :control) (#\f :control)))
263
264 (defun find-file-read-only (filepath)
265 (cond ((null filepath)
266 (display-message "No file name given.")
267 (beep))
268 ((directory-pathname-p filepath)
269 (display-message "~A is a directory name." filepath)
270 (beep))
271 (t
272 (let ((existing-buffer (find filepath (buffers *application-frame*)
273 :key #'filepath :test #'equal)))
274 (if (and existing-buffer (read-only-p existing-buffer))
275 (switch-to-buffer existing-buffer)
276 (if (probe-file filepath)
277 (let ((buffer (make-buffer))
278 (pane (current-window)))
279 (setf (offset (point (buffer pane))) (offset (point pane)))
280 (setf (buffer (current-window)) buffer)
281 (setf (syntax buffer)
282 (make-instance (syntax-class-name-for-filepath filepath)
283 :buffer (buffer (point pane))))
284 (with-open-file (stream filepath :direction :input)
285 (input-from-stream stream buffer 0))
286 (setf (filepath buffer) filepath
287 (name buffer) (filepath-filename filepath)
288 (needs-saving buffer) nil
289 (read-only-p buffer) t)
290 (beginning-of-buffer (point pane))
291 ;; this one is needed so that the buffer modification protocol
292 ;; resets the low and high marks after redisplay
293 (redisplay-frame-panes *application-frame*)
294 buffer)
295 (progn
296 (display-message "No such file: ~A" filepath)
297 (beep)
298 nil)))))))
299
300 (define-command (com-find-file-read-only :name t :command-table buffer-table) ()
301 (let ((filepath (accept 'pathname :Prompt "Find file read only"
302 :default (directory-of-buffer (buffer (current-window)))
303 :default-type 'pathname
304 :insert-default t)))
305 (find-file-read-only filepath)))
306
307 (set-key 'com-find-file-read-only
308 'buffer-table
309 '((#\x :control) (#\r :control)))
310
311 (define-command (com-read-only :name t :command-table buffer-table) ()
312 (let ((buffer (buffer (current-window))))
313 (setf (read-only-p buffer) (not (read-only-p buffer)))))
314
315 (set-key 'com-read-only
316 'buffer-table
317 '((#\x :control) (#\q :control)))
318
319 (defun set-visited-file-name (filename buffer)
320 (setf (filepath buffer) filename
321 (name buffer) (filepath-filename filename)
322 (needs-saving buffer) t))
323
324 (define-command (com-set-visited-file-name :name t :command-table buffer-table) ()
325 (let ((filename (accept 'pathname :prompt "New file name"
326 :default (directory-of-buffer (buffer (current-window)))
327 :default-type 'pathname
328 :insert-default t)))
329 (set-visited-file-name filename (buffer (current-window)))))
330
331 (define-command (com-insert-file :name t :command-table buffer-table) ()
332 (let ((filename (accept 'pathname :prompt "Insert File"
333 :default (directory-of-buffer (buffer (current-window)))
334 :default-type 'pathname
335 :insert-default t))
336 (pane (current-window)))
337 (when (probe-file filename)
338 (setf (mark pane) (clone-mark (point pane) :left))
339 (with-open-file (stream filename :direction :input)
340 (input-from-stream stream
341 (buffer pane)
342 (offset (point pane))))
343 (psetf (offset (mark pane)) (offset (point pane))
344 (offset (point pane)) (offset (mark pane))))
345 (redisplay-frame-panes *application-frame*)))
346
347 (set-key 'com-insert-file
348 'buffer-table
349 '((#\x :control) (#\i :control)))
350
351 (define-command (com-revert-buffer :name t :command-table buffer-table) ()
352 (let* ((pane (current-window))
353 (buffer (buffer pane))
354 (filepath (filepath buffer))
355 (save (offset (point pane))))
356 (when (accept 'boolean :prompt (format nil "Revert buffer from file ~A?"
357 (filepath buffer)))
358 (cond ((directory-pathname-p filepath)
359 (display-message "~A is a directory name." filepath)
360 (beep))
361 ((probe-file filepath)
362 (erase-buffer buffer)
363 (with-open-file (stream filepath :direction :input)
364 (input-from-stream stream buffer 0))
365 (setf (offset (point pane))
366 (min (size buffer) save)))
367 (t
368 (display-message "No file ~A" filepath)
369 (beep))))))
370
371 (defun save-buffer (buffer)
372 (let ((filepath (or (filepath buffer)
373 (accept 'pathname :prompt "Save Buffer to File"))))
374 (cond
375 ((directory-pathname-p filepath)
376 (display-message "~A is a directory." filepath)
377 (beep))
378 (t
379 (when (probe-file filepath)
380 (let ((backup-name (pathname-name filepath))
381 (backup-type (concatenate 'string (pathname-type filepath) "~")))
382 (rename-file filepath (make-pathname :name backup-name
383 :type backup-type))))
384 (with-open-file (stream filepath :direction :output :if-exists :supersede)
385 (output-to-stream stream buffer 0 (size buffer)))
386 (setf (filepath buffer) filepath
387 (name buffer) (filepath-filename filepath))
388 (display-message "Wrote: ~a" (filepath buffer))
389 (setf (needs-saving buffer) nil)))))
390
391 (define-command (com-save-buffer :name t :command-table buffer-table) ()
392 (let ((buffer (buffer (current-window))))
393 (if (or (null (filepath buffer))
394 (needs-saving buffer))
395 (save-buffer buffer)
396 (display-message "No changes need to be saved from ~a" (name buffer)))))
397
398 (set-key 'com-save-buffer
399 'buffer-table
400 '((#\x :control) (#\s :control)))
401
402 (defmethod frame-exit :around ((frame climacs) #-mcclim &key)
403 (loop for buffer in (buffers frame)
404 when (and (needs-saving buffer)
405 (filepath buffer)
406 (handler-case (accept 'boolean
407 :prompt (format nil "Save buffer: ~a ?" (name buffer)))
408 (error () (progn (beep)
409 (display-message "Invalid answer")
410 (return-from frame-exit nil)))))
411 do (save-buffer buffer))
412 (when (or (notany #'(lambda (buffer) (and (needs-saving buffer) (filepath buffer)))
413 (buffers frame))
414 (handler-case (accept 'boolean :prompt "Modified buffers exist. Quit anyway?")
415 (error () (progn (beep)
416 (display-message "Invalid answer")
417 (return-from frame-exit nil)))))
418 (call-next-method)))
419
420 (define-command (com-write-buffer :name t :command-table buffer-table) ()
421 (let ((filepath (accept 'pathname :prompt "Write Buffer to File"
422 :default (directory-of-buffer (buffer (current-window)))
423 :default-type 'pathname
424 :insert-default t))
425 (buffer (buffer (current-window))))
426 (cond
427 ((directory-pathname-p filepath)
428 (display-message "~A is a directory name." filepath))
429 (t
430 (with-open-file (stream filepath :direction :output :if-exists :supersede)
431 (output-to-stream stream buffer 0 (size buffer)))
432 (setf (filepath buffer) filepath
433 (name buffer) (filepath-filename filepath)
434 (needs-saving buffer) nil)
435 (display-message "Wrote: ~a" (filepath buffer))))))
436
437 (set-key 'com-write-buffer
438 'buffer-table
439 '((#\x :control) (#\w :control)))
440

  ViewVC Help
Powered by ViewVC 1.1.5