/[climacs]/climacs/core.lisp
ViewVC logotype

Contents of /climacs/core.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.27 - (show annotations)
Sun May 18 09:20:42 2008 UTC (5 years, 10 months ago) by thenriksen
Branch: MAIN
CVS Tags: HEAD
Changes since 1.26: +39 -38 lines
Error handling now done by commands, handle errors when exiting in a
better way.
1 ;;; -*- Mode: Lisp; Package: CLIMACS-CORE -*-
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 ;;; (c) copyright 2006 by
12 ;;; Troels Henriksen (athas@sigkill.dk)
13
14 (in-package :climacs-core)
15
16 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
17 ;;;
18 ;;; Buffer handling
19
20 (defmethod frame-make-new-buffer ((application-frame climacs)
21 &key (name "*scratch*"))
22 (make-instance 'climacs-buffer :name name))
23
24 (define-presentation-method present ((object drei-view) (type view)
25 stream (view textual-view)
26 &key acceptably for-context-type)
27 (declare (ignore acceptably for-context-type))
28 (princ (subscripted-name object) stream))
29
30 (define-presentation-method accept ((type view) stream (view textual-view)
31 &key (default nil defaultp)
32 (default-type type))
33 (multiple-value-bind (object success string)
34 (complete-input stream
35 (lambda (so-far action)
36 (complete-from-possibilities
37 so-far (views *esa-instance*) '()
38 :action action
39 :name-key #'subscripted-name
40 :value-key #'identity))
41 :partial-completers '(#\Space)
42 :allow-any-input t)
43 (cond ((and success (plusp (length string)))
44 (if object
45 (values object type)
46 (values string 'string)))
47 ((and (zerop (length string)) defaultp)
48 (values default default-type))
49 (t
50 (values string 'string)))))
51
52 (defgeneric switch-to-view (drei view)
53 (:documentation "High-level function for changing the view
54 displayed by a Drei instance."))
55
56 (defmethod switch-to-view ((drei climacs-pane) (view drei-view))
57 (setf (view drei) view))
58
59 (defmethod switch-to-view (pane (name string))
60 (let ((view (find name (views (pane-frame pane))
61 :key #'subscripted-name :test #'string=)))
62 (switch-to-view
63 pane (or view (make-new-view-for-climacs
64 (pane-frame pane) 'textual-drei-syntax-view
65 :name name)))))
66
67 (defun switch-or-move-to-view (pane view)
68 "Switch `pane' to show `view'. If `view' is already on display
69 in some other pane, switch that pane to be the active one."
70 (handler-bind ((view-already-displayed
71 #'(lambda (c)
72 (declare (ignore c))
73 (invoke-restart 'switch-to-pane))))
74 (switch-to-view pane view)))
75
76 (defun views-having-buffer (climacs buffer)
77 "Return a list of the buffer-views of `climacs' showing
78 `buffer'."
79 (loop for view in (views climacs)
80 when (and (typep view 'drei-buffer-view)
81 (eq (buffer view) buffer))
82 collect view))
83
84 (defun buffer-of-view-needs-saving (view)
85 "Return true if `view' is a `drei-buffer-view' and it needs to
86 be saved (that is, it is related to a file and it has changed
87 since it was last saved)."
88 (and (typep view 'drei-buffer-view)
89 (filepath (buffer view))
90 (needs-saving (buffer view))))
91
92 (defun dummy-buffer ()
93 "Create a dummy buffer object for use when killing views, to
94 prevent increasing memory usage."
95 (make-instance 'drei-buffer))
96
97 (defgeneric kill-view (view)
98 (:documentation "Remove `view' from the Climacs specified in
99 `*esa-instance*'. If `view' is currently displayed in a window,
100 it will be replaced by some other view."))
101
102 (defmethod kill-view ((view view))
103 (with-accessors ((views views)) *esa-instance*
104 ;; It might be the case that this view is the only view remaining
105 ;; of some particular buffer, in that case, the user might want to
106 ;; save it.
107 (when (and (buffer-of-view-needs-saving view)
108 (= (length (views-having-buffer *esa-instance* (buffer view)))
109 1)
110 (handler-case (accept 'boolean :prompt "Save buffer first?")
111 (error () (progn (beep)
112 (display-message "Invalid answer")
113 (return-from kill-view nil)))))
114 (save-buffer (buffer view)))
115 (setf views (remove view views))
116 ;; If we don't change the buffer of the view, a reference to the
117 ;; view will be kept in the buffer, and the view will thus not be
118 ;; garbage-collected. So create a circular reference structure
119 ;; that can be garbage-collected instead.
120 (when (buffer-view-p view)
121 (setf (buffer view) (dummy-buffer)))
122 (full-redisplay (current-window))
123 (current-view)))
124
125 (defmethod kill-view ((name string))
126 (let ((view (find name (views *application-frame*)
127 :key #'subscripted-name :test #'string=)))
128 (when view (kill-view view))))
129
130 (defmethod kill-view ((symbol null))
131 (kill-view (current-view)))
132
133 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
134 ;;;
135 ;;; File handling
136
137 (defun filepath-filename (pathname)
138 (if (null (pathname-type pathname))
139 (pathname-name pathname)
140 (concatenate 'string (pathname-name pathname)
141 "." (pathname-type pathname))))
142
143 (defun syntax-class-name-for-filepath (filepath)
144 (let ((syntax-description
145 (find (or (pathname-type filepath)
146 (pathname-name filepath))
147 drei-syntax::*syntaxes*
148 :test (lambda (x y)
149 (member x y :test #'string-equal))
150 :key #'drei-syntax::syntax-description-pathname-types)))
151 (if syntax-description
152 (drei-syntax::syntax-description-class-name
153 syntax-description)
154 *default-syntax*)))
155
156 (defun evaluate-attributes (view options)
157 "Evaluate the attributes `options' and modify `view' as
158 appropriate. `Options' should be an alist mapping option names to
159 their values."
160 ;; First, check whether we need to change the syntax (via the SYNTAX
161 ;; option). MODE is an alias for SYNTAX for compatibility with
162 ;; Emacs. If there is more than one option with one of these names,
163 ;; only the first will be acted upon.
164 (let ((specified-syntax
165 (syntax-from-name
166 (second (find-if #'(lambda (name)
167 (or (string-equal name "SYNTAX")
168 (string-equal name "MODE")))
169 options
170 :key #'first)))))
171 (when (and specified-syntax
172 (not (eq (class-of (syntax view))
173 specified-syntax)))
174 (setf (syntax view)
175 (make-syntax-for-view view specified-syntax))))
176 ;; Now we iterate through the options (discarding SYNTAX and MODE
177 ;; options).
178 (loop for (name value) in options
179 unless (or (string-equal name "SYNTAX")
180 (string-equal name "MODE"))
181 do (eval-option (syntax view) name value)))
182
183 (defun split-attribute (string char)
184 (let (pairs)
185 (loop with start = 0
186 for ch across string
187 for i from 0
188 when (eql ch char)
189 do (push (string-trim '(#\Space #\Tab) (subseq string start i))
190 pairs)
191 (setf start (1+ i))
192 finally (unless (>= start i)
193 (push (string-trim '(#\Space #\Tab) (subseq string start))
194 pairs)))
195 (nreverse pairs)))
196
197 (defun split-attribute-line (line)
198 (when line
199 (mapcar (lambda (pair) (split-attribute pair #\:))
200 (split-attribute line #\;))))
201
202 (defun find-attribute-line-position (buffer)
203 (let ((scan (make-buffer-mark buffer 0)))
204 ;; skip the leading whitespace
205 (loop until (end-of-buffer-p scan)
206 until (not (buffer-whitespacep (object-after scan)))
207 do (forward-object scan))
208 ;; stop looking if we're already 1,000 objects into the buffer
209 (unless (> (offset scan) 1000)
210 (let ((start-found
211 (loop with newlines = 0
212 when (end-of-buffer-p scan)
213 do (return nil)
214 when (eql (object-after scan) #\Newline)
215 do (incf newlines)
216 when (> newlines 1)
217 do (return nil)
218 until (looking-at scan "-*-")
219 do (forward-object scan)
220 finally (return t))))
221 (when start-found
222 (let* ((end-scan (clone-mark scan))
223 (end-found
224 (loop when (end-of-buffer-p end-scan)
225 do (return nil)
226 when (eql (object-after end-scan) #\Newline)
227 do (return nil)
228 do (forward-object end-scan)
229 until (looking-at end-scan "-*-")
230 finally (return t))))
231 (when end-found
232 (values scan
233 (progn (forward-object end-scan 3)
234 end-scan)))))))))
235
236 (defun get-attribute-line (buffer)
237 (multiple-value-bind (start-mark end-mark)
238 (find-attribute-line-position buffer)
239 (when (and start-mark end-mark)
240 (let ((line (buffer-substring buffer
241 (offset start-mark)
242 (offset end-mark))))
243 (when (>= (length line) 6)
244 (let ((end (search "-*-" line :from-end t :start2 3)))
245 (when end
246 (string-trim '(#\Space #\Tab) (subseq line 3 end)))))))))
247
248 (defun replace-attribute-line (view new-attribute-line)
249 (let ((full-attribute-line (concatenate 'string
250 "-*- "
251 new-attribute-line
252 "-*-")))
253 (multiple-value-bind (start-mark end-mark)
254 (find-attribute-line-position (buffer view))
255 (cond ((not (null end-mark))
256 ;; We have an existing attribute line.
257 (delete-region start-mark end-mark)
258 (let ((new-line-start (clone-mark start-mark :left)))
259 (insert-sequence start-mark full-attribute-line)
260 (comment-region (syntax view)
261 new-line-start
262 start-mark)))
263 (t
264 ;; Create a new attribute line at beginning of buffer.
265 (let* ((mark1 (make-buffer-mark (buffer view) 0 :left))
266 (mark2 (clone-mark mark1 :right)))
267 (insert-sequence mark2 full-attribute-line)
268 (insert-object mark2 #\Newline)
269 (comment-region (syntax view)
270 mark1
271 mark2)))))))
272
273 (defun update-attribute-line (view)
274 (replace-attribute-line
275 view (make-attribute-line (syntax view))))
276
277 (defun evaluate-attribute-line (view)
278 (evaluate-attributes
279 view (split-attribute-line (get-attribute-line (buffer view)))))
280
281 ;; Adapted from cl-fad/PCL
282 (defun directory-pathname-p (pathspec)
283 "Returns NIL if PATHSPEC does not designate a directory."
284 (let ((name (pathname-name pathspec))
285 (type (pathname-type pathspec)))
286 (and (or (null name) (eql name :unspecific))
287 (or (null type) (eql type :unspecific)))))
288
289 (defun findablep (pathname)
290 "Return non-NIL if `pathname' can be opened by Climacs. That
291 is, check whether the file exists and is not a directory."
292 (and (probe-file pathname)
293 (not (directory-pathname-p pathname))))
294
295 (defun find-view-with-pathname (pathname)
296 "Return the (first) with associated with the file designated by
297 `pathname'. Returns NIL if no buffer can be found."
298 (flet ((usable-pathname (pathname)
299 (if (probe-file pathname)
300 (truename pathname)
301 pathname)))
302 (find pathname (remove-if-not #'(lambda (view)
303 (typep view 'drei-buffer-view))
304 (views *application-frame*))
305 :key #'(lambda (view) (filepath (buffer view)))
306 :test #'(lambda (fp1 fp2)
307 (and fp1 fp2
308 (equal (usable-pathname fp1)
309 (usable-pathname fp2)))))))
310
311 (defun ensure-open-file (pathname)
312 "Make sure a buffer opened on `pathname' exists, finding the
313 file if necessary."
314 (when (and (findablep pathname)
315 (not (find-buffer-with-pathname pathname)))
316 (find-file pathname)))
317
318 (defun find-file-impl (filepath &optional readonlyp)
319 (cond ((null filepath)
320 (display-message "No file name given.")
321 (beep))
322 ((directory-pathname-p filepath)
323 (display-message "~A is a directory name." filepath)
324 (beep))
325 (t
326 (let ((existing-view (find-view-with-pathname filepath)))
327 (if (and existing-view (if readonlyp (read-only-p (buffer existing-view)) t))
328 (switch-to-view (current-window) existing-view)
329 (let* ((newp (not (probe-file filepath)))
330 (buffer (if (and newp (not readonlyp))
331 (make-new-buffer)
332 (with-open-file (stream filepath :direction :input)
333 (make-buffer-from-stream stream))))
334 (view (make-new-view-for-climacs
335 *esa-instance* 'textual-drei-syntax-view
336 :name (filepath-filename filepath)
337 :buffer buffer)))
338 (unless (buffer-pane-p (current-window))
339 (other-window (or (find-if #'(lambda (window)
340 (typep window 'climacs-pane))
341 (windows *esa-instance*))
342 (split-window t))))
343 (setf (offset (point buffer)) (offset (point view))
344 (syntax view) (make-syntax-for-view view (syntax-class-name-for-filepath filepath))
345 (file-write-time buffer) (if newp (get-universal-time) (file-write-date filepath))
346 (needs-saving buffer) nil
347 (name buffer) (filepath-filename filepath))
348 (setf (current-view (current-window)) view)
349 (evaluate-attribute-line view)
350 (setf (filepath buffer) (pathname filepath)
351 (read-only-p buffer) readonlyp)
352 (beginning-of-buffer (point view))
353 buffer))))))
354
355 (defmethod frame-find-file ((application-frame climacs) filepath)
356 (find-file-impl filepath nil))
357
358 (defmethod frame-find-file-read-only ((application-frame climacs) filepath)
359 (find-file-impl filepath t))
360
361 (defun directory-of-buffer (buffer)
362 "Extract the directory part of the filepath to the file in BUFFER.
363 If BUFFER does not have a filepath, the path to the user's home
364 directory will be returned."
365 (make-pathname
366 :directory
367 (pathname-directory
368 (or (filepath buffer)
369 (user-homedir-pathname)))))
370
371 (defmethod frame-set-visited-filename ((application-frame climacs) filepath buffer)
372 (setf (filepath buffer) (pathname filepath)
373 (file-saved-p buffer) nil
374 (file-write-time buffer) nil
375 (name buffer) (filepath-filename filepath)
376 (needs-saving buffer) t))
377
378 (defun check-file-times (buffer filepath question answer)
379 "Return NIL if filepath newer than buffer and user doesn't want
380 to overwrite."
381 (let ((f-w-d (file-write-date filepath))
382 (f-w-t (file-write-time buffer)))
383 (if (and f-w-d f-w-t (> f-w-d f-w-t))
384 (if (accept 'boolean
385 :prompt (format nil "File has changed on disk. ~a anyway?"
386 question))
387 t
388 (progn (display-message "~a not ~a" filepath answer)
389 nil))
390 t)))
391
392 (defmethod frame-exit :around ((frame climacs) #-mcclim &key)
393 (dolist (view (views frame))
394 (handler-case
395 (when (and (buffer-of-view-needs-saving view)
396 (handler-case (accept 'boolean
397 :prompt (format nil "Save buffer of view: ~a ?" (name view)))
398 (error () (progn (beep)
399 (display-message "Invalid answer")
400 (return-from frame-exit nil)))))
401 (save-buffer (buffer view)))
402 (file-error (e)
403 (display-message "~A (hit a key to continue)" e)
404 (read-gesture))))
405 (when (or (notany #'buffer-of-view-needs-saving (views frame))
406 (handler-case (accept 'boolean :prompt "Modified buffers of views exist. Quit anyway?")
407 (error () (progn (beep)
408 (display-message "Invalid answer")
409 (return-from frame-exit nil)))))
410 (call-next-method)))

  ViewVC Help
Powered by ViewVC 1.1.5