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

Contents of /climacs/file-commands.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (show annotations)
Sat May 6 15:38:42 2006 UTC (7 years, 11 months ago) by thenriksen
Branch: MAIN
Changes since 1.12: +2 -2 lines
Made `find-file' use `evaluate-attributes-line' and removed the now
obsolete `com-reload-local-options-line'.
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 evaluate-attributes (buffer options)
133 "Evaluate the attributes `options' and modify `buffer' as
134 appropriate. `Options' should be an alist mapping option names
135 to their values."
136 ;; First, check whether we need to change the syntax (via the SYNTAX
137 ;; option). MODE is an alias for SYNTAX for compatibility with
138 ;; Emacs. If there is more than one option with one of these names,
139 ;; only the first will be acted upon.
140 (let ((specified-syntax
141 (syntax-from-name
142 (second (find-if #'(lambda (name)
143 (or (string-equal name "SYNTAX")
144 (string-equal name "MODE")))
145 options
146 :key #'first)))))
147 (when specified-syntax
148 (setf (syntax buffer)
149 (make-instance specified-syntax
150 :buffer buffer))))
151 ;; Now we iterate through the options (discarding SYNTAX and MODE
152 ;; options).
153 (loop for (name value) in options
154 unless (or (string-equal name "SYNTAX")
155 (string-equal name "MODE"))
156 do (eval-option (syntax buffer) name value)))
157
158 (defun split-attribute (string char)
159 (let (pairs)
160 (loop with start = 0
161 for ch across string
162 for i from 0
163 when (eql ch char)
164 do (push (string-trim '(#\Space #\Tab) (subseq string start i))
165 pairs)
166 (setf start (1+ i))
167 finally (unless (>= start i)
168 (push (string-trim '(#\Space #\Tab) (subseq string start))
169 pairs)))
170 (nreverse pairs)))
171
172 (defun split-attribute-line (line)
173 (mapcar (lambda (pair) (split-attribute pair #\:))
174 (split-attribute line #\;)))
175
176 (defun get-attribute-line (buffer)
177 (let ((scan (beginning-of-buffer (clone-mark (point buffer)))))
178 ;; skip the leading whitespace
179 (loop until (end-of-buffer-p scan)
180 until (not (whitespacep (object-after scan)))
181 do (forward-object scan))
182 ;; stop looking if we're already 1,000 objects into the buffer
183 (unless (> (offset scan) 1000)
184 (let ((start-found
185 (loop with newlines = 0
186 when (end-of-buffer-p scan)
187 do (return nil)
188 when (eql (object-after scan) #\Newline)
189 do (incf newlines)
190 when (> newlines 1)
191 do (return nil)
192 do (forward-object scan)
193 until (looking-at scan "-*-")
194 finally (return t))))
195 (when start-found
196 (let ((line (buffer-substring buffer
197 (offset scan)
198 (offset (end-of-line (clone-mark scan))))))
199 (when (>= (length line) 6)
200 (let ((end (search "-*-" line :from-end t :start2 3)))
201 (when end
202 (string-trim '(#\Space #\Tab) (subseq line 3 end)))))))))))
203
204 (defun evaluate-attributes-line (buffer)
205 (evaluate-attributes
206 buffer
207 (split-attribute-line (get-attribute-line buffer))))
208
209 (define-command (com-reparse-attribute-list :name t :command-table buffer-table) ()
210 "Reparse the current buffer's attribute list.
211 An attribute list is a line of keyword-value pairs, each keyword separated
212 from the corresponding value by a colon. If another keyword-value pair
213 follows, the value should be terminated by a colon. The attribute list
214 is surrounded by '-*-' sequences, but the opening '-*-' need not be at the
215 beginning of the line. Climacs looks for the attribute list
216 on the first or second non-blank line of the file.
217
218 An example attribute-list is:
219
220 ;; -*- Syntax: Lisp; Base: 10 -*- "
221 (evaluate-attributes-line (buffer (current-window))))
222
223 ;; Adapted from cl-fad/PCL
224 (defun directory-pathname-p (pathspec)
225 "Returns NIL if PATHSPEC does not designate a directory."
226 (let ((name (pathname-name pathspec))
227 (type (pathname-type pathspec)))
228 (and (or (null name) (eql name :unspecific))
229 (or (null type) (eql type :unspecific)))))
230
231 (defun find-file (filepath)
232 (cond ((null filepath)
233 (display-message "No file name given.")
234 (beep))
235 ((directory-pathname-p filepath)
236 (display-message "~A is a directory name." filepath)
237 (beep))
238 (t
239 (let ((existing-buffer (find filepath (buffers *application-frame*)
240 :key #'filepath :test #'equal)))
241 (if existing-buffer
242 (switch-to-buffer existing-buffer)
243 (let ((buffer (make-buffer))
244 (pane (current-window)))
245 ;; Clear the pane's cache; otherwise residue from the
246 ;; previously displayed buffer may under certain
247 ;; circumstances be displayed.
248 (clear-cache pane)
249 (setf (syntax buffer) nil)
250 (setf (offset (point (buffer pane))) (offset (point pane)))
251 (setf (buffer (current-window)) buffer)
252 ;; Don't want to create the file if it doesn't exist.
253 (when (probe-file filepath)
254 (with-open-file (stream filepath :direction :input)
255 (input-from-stream stream buffer 0))
256 (setf (file-write-time buffer) (file-write-date filepath))
257 ;; A file! That means we may have a local options
258 ;; line to parse.
259 (evaluate-attributes-line buffer))
260 ;; If the local options line didn't set a syntax, do
261 ;; it now.
262 (when (null (syntax buffer))
263 (setf (syntax buffer)
264 (make-instance (syntax-class-name-for-filepath filepath)
265 :buffer buffer)))
266 (setf (filepath buffer) filepath
267 (name buffer) (filepath-filename filepath)
268 (needs-saving buffer) nil)
269 (beginning-of-buffer (point pane))
270 (update-syntax buffer (syntax buffer))
271 (clear-modify buffer)
272 buffer))))))
273
274 (defun directory-of-buffer (buffer)
275 "Extract the directory part of the filepath to the file in BUFFER.
276 If BUFFER does not have a filepath, the path to the user's home
277 directory will be returned."
278 (make-pathname
279 :directory
280 (pathname-directory
281 (or (filepath buffer)
282 (user-homedir-pathname)))))
283
284 (define-command (com-find-file :name t :command-table buffer-table) ()
285 "Prompt for a filename then edit that file.
286 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."
287 (let* ((filepath (accept 'pathname :prompt "Find File"
288 :default (directory-of-buffer (buffer (current-window)))
289 :default-type 'pathname
290 :insert-default t)))
291 (find-file filepath)))
292
293 (set-key 'com-find-file
294 'buffer-table
295 '((#\x :control) (#\f :control)))
296
297 (defun find-file-read-only (filepath)
298 (cond ((null filepath)
299 (display-message "No file name given.")
300 (beep))
301 ((directory-pathname-p filepath)
302 (display-message "~A is a directory name." filepath)
303 (beep))
304 (t
305 (let ((existing-buffer (find filepath (buffers *application-frame*)
306 :key #'filepath :test #'equal)))
307 (if (and existing-buffer (read-only-p existing-buffer))
308 (switch-to-buffer existing-buffer)
309 (if (probe-file filepath)
310 (let ((buffer (make-buffer))
311 (pane (current-window)))
312 (setf (offset (point (buffer pane))) (offset (point pane)))
313 (setf (buffer (current-window)) buffer)
314 (setf (syntax buffer)
315 (make-instance (syntax-class-name-for-filepath filepath)
316 :buffer (buffer (point pane))))
317 (with-open-file (stream filepath :direction :input)
318 (input-from-stream stream buffer 0))
319 (setf (filepath buffer) filepath
320 (name buffer) (filepath-filename filepath)
321 (needs-saving buffer) nil
322 (read-only-p buffer) t)
323 (beginning-of-buffer (point pane))
324 ;; this one is needed so that the buffer modification protocol
325 ;; resets the low and high marks after redisplay
326 (redisplay-frame-panes *application-frame*)
327 buffer)
328 (progn
329 (display-message "No such file: ~A" filepath)
330 (beep)
331 nil)))))))
332
333 (define-command (com-find-file-read-only :name t :command-table buffer-table) ()
334 "Prompt for a filename then open that file readonly.
335 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."
336 (let ((filepath (accept 'pathname :Prompt "Find file read only"
337 :default (directory-of-buffer (buffer (current-window)))
338 :default-type 'pathname
339 :insert-default t)))
340 (find-file-read-only filepath)))
341
342 (set-key 'com-find-file-read-only
343 'buffer-table
344 '((#\x :control) (#\r :control)))
345
346 (define-command (com-read-only :name t :command-table buffer-table) ()
347 "Toggle the readonly status of the current buffer.
348 When a buffer is readonly, attempts to change the contents of the buffer signal an error."
349 (let ((buffer (buffer (current-window))))
350 (setf (read-only-p buffer) (not (read-only-p buffer)))))
351
352 (set-key 'com-read-only
353 'buffer-table
354 '((#\x :control) (#\q :control)))
355
356 (defun set-visited-file-name (filename buffer)
357 (setf (filepath buffer) filename
358 (file-saved-p buffer) nil
359 (file-write-time buffer) nil
360 (name buffer) (filepath-filename filename)
361 (needs-saving buffer) t))
362
363 (define-command (com-set-visited-file-name :name t :command-table buffer-table) ()
364 "Prompt for a new filename for the current buffer.
365 The next time the buffer is saved it will be saved to a file with that filename."
366 (let ((filename (accept 'pathname :prompt "New file name"
367 :default (directory-of-buffer (buffer (current-window)))
368 :default-type 'pathname
369 :insert-default t)))
370 (set-visited-file-name filename (buffer (current-window)))))
371
372 (define-command (com-insert-file :name t :command-table buffer-table) ()
373 "Prompt for a filename and insert its contents at point.
374 Leaves mark after the inserted contents."
375 (let ((filename (accept 'pathname :prompt "Insert File"
376 :default (directory-of-buffer (buffer (current-window)))
377 :default-type 'pathname
378 :insert-default t))
379 (pane (current-window)))
380 (when (probe-file filename)
381 (setf (mark pane) (clone-mark (point pane) :left))
382 (with-open-file (stream filename :direction :input)
383 (input-from-stream stream
384 (buffer pane)
385 (offset (point pane))))
386 (psetf (offset (mark pane)) (offset (point pane))
387 (offset (point pane)) (offset (mark pane))))
388 (redisplay-frame-panes *application-frame*)))
389
390 (set-key 'com-insert-file
391 'buffer-table
392 '((#\x :control) (#\i :control)))
393
394 (define-command (com-revert-buffer :name t :command-table buffer-table) ()
395 "Replace the contents of the current buffer with the visited file.
396 Signals an error if the file does not exist."
397 (let* ((pane (current-window))
398 (buffer (buffer pane))
399 (filepath (filepath buffer))
400 (save (offset (point pane))))
401 (when (accept 'boolean :prompt (format nil "Revert buffer from file ~A?"
402 (filepath buffer)))
403 (cond ((directory-pathname-p filepath)
404 (display-message "~A is a directory name." filepath)
405 (beep))
406 ((probe-file filepath)
407 (unless (check-file-times buffer filepath "Revert" "reverted")
408 (return-from com-revert-buffer))
409 (erase-buffer buffer)
410 (with-open-file (stream filepath :direction :input)
411 (input-from-stream stream buffer 0))
412 (setf (offset (point pane)) (min (size buffer) save)
413 (file-saved-p buffer) nil))
414 (t
415 (display-message "No file ~A" filepath)
416 (beep))))))
417
418 (defun extract-version-number (pathname)
419 "Extracts the emacs-style version-number from a pathname."
420 (let* ((type (pathname-type pathname))
421 (length (length type)))
422 (when (and (> length 2) (char= (char type (1- length)) #\~))
423 (let ((tilde (position #\~ type :from-end t :end (- length 2))))
424 (when tilde
425 (parse-integer type :start (1+ tilde) :junk-allowed t))))))
426
427 (defun version-number (pathname)
428 "Return the number of the highest versioned backup of PATHNAME
429 or 0 if there is no versioned backup. Looks for name.type~X~,
430 returns highest X."
431 (let* ((wildpath (merge-pathnames (make-pathname :type :wild) pathname))
432 (possibilities (directory wildpath)))
433 (loop for possibility in possibilities
434 for version = (extract-version-number possibility)
435 if (numberp version)
436 maximize version into max
437 finally (return max))))
438
439 (defun check-file-times (buffer filepath question answer)
440 "Return NIL if filepath newer than buffer and user doesn't want to overwrite"
441 (let ((f-w-d (file-write-date filepath))
442 (f-w-t (file-write-time buffer)))
443 (if (and f-w-d f-w-t (> f-w-d f-w-t))
444 (if (accept 'boolean
445 :prompt (format nil "File has changed on disk. ~a anyway?"
446 question))
447 t
448 (progn (display-message "~a not ~a" filepath answer)
449 nil))
450 t)))
451
452 (defun save-buffer (buffer)
453 (let ((filepath (or (filepath buffer)
454 (accept 'pathname :prompt "Save Buffer to File"))))
455 (cond
456 ((directory-pathname-p filepath)
457 (display-message "~A is a directory." filepath)
458 (beep))
459 (t
460 (unless (check-file-times buffer filepath "Overwrite" "written")
461 (return-from save-buffer))
462 (when (and (probe-file filepath) (not (file-saved-p buffer)))
463 (let ((backup-name (pathname-name filepath))
464 (backup-type (format nil "~A~~~D~~"
465 (pathname-type filepath)
466 (1+ (version-number filepath)))))
467 (rename-file filepath (make-pathname :name backup-name
468 :type backup-type)))
469 (setf (file-saved-p buffer) t))
470 (with-open-file (stream filepath :direction :output :if-exists :supersede)
471 (output-to-stream stream buffer 0 (size buffer)))
472 (setf (filepath buffer) filepath
473 (file-write-time buffer) (file-write-date filepath)
474 (name buffer) (filepath-filename filepath))
475 (display-message "Wrote: ~a" filepath)
476 (setf (needs-saving buffer) nil)))))
477
478 (define-command (com-save-buffer :name t :command-table buffer-table) ()
479 "Write the contents of the buffer to a file.
480 If there is filename associated with the buffer, write to that file, replacing its contents. If not, prompt for a filename."
481 (let ((buffer (buffer (current-window))))
482 (if (or (null (filepath buffer))
483 (needs-saving buffer))
484 (save-buffer buffer)
485 (display-message "No changes need to be saved from ~a" (name buffer)))))
486
487 (set-key 'com-save-buffer
488 'buffer-table
489 n '((#\x :control) (#\s :control)))
490
491 (defmethod frame-exit :around ((frame climacs) #-mcclim &key)
492 (loop for buffer in (buffers frame)
493 when (and (needs-saving buffer)
494 (filepath buffer)
495 (handler-case (accept 'boolean
496 :prompt (format nil "Save buffer: ~a ?" (name buffer)))
497 (error () (progn (beep)
498 (display-message "Invalid answer")
499 (return-from frame-exit nil)))))
500 do (save-buffer buffer))
501 (when (or (notany #'(lambda (buffer) (and (needs-saving buffer) (filepath buffer)))
502 (buffers frame))
503 (handler-case (accept 'boolean :prompt "Modified buffers exist. Quit anyway?")
504 (error () (progn (beep)
505 (display-message "Invalid answer")
506 (return-from frame-exit nil)))))
507 (call-next-method)))
508
509 (define-command (com-write-buffer :name t :command-table buffer-table) ()
510 "Prompt for a filename and write the current buffer to it.
511 Changes the file visted by the buffer to the given file."
512 (let ((filepath (accept 'pathname :prompt "Write Buffer to File"
513 :default (directory-of-buffer (buffer (current-window)))
514 :default-type 'pathname
515 :insert-default t))
516 (buffer (buffer (current-window))))
517 (cond
518 ((directory-pathname-p filepath)
519 (display-message "~A is a directory name." filepath))
520 (t
521 (with-open-file (stream filepath :direction :output :if-exists :supersede)
522 (output-to-stream stream buffer 0 (size buffer)))
523 (setf (filepath buffer) filepath
524 (name buffer) (filepath-filename filepath)
525 (needs-saving buffer) nil)
526 (display-message "Wrote: ~a" (filepath buffer))))))
527
528 (set-key 'com-write-buffer
529 'buffer-table
530 '((#\x :control) (#\w :control)))
531

  ViewVC Help
Powered by ViewVC 1.1.5