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

Contents of /climacs/core.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.27 - (hide annotations)
Sun May 18 09:20:42 2008 UTC (5 years, 11 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 thenriksen 1.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 thenriksen 1.2 ;;; Buffer handling
19    
20 thenriksen 1.9 (defmethod frame-make-new-buffer ((application-frame climacs)
21     &key (name "*scratch*"))
22 thenriksen 1.16 (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 thenriksen 1.2 (declare (ignore acceptably for-context-type))
28 thenriksen 1.16 (princ (subscripted-name object) stream))
29 thenriksen 1.2
30 thenriksen 1.16 (define-presentation-method accept ((type view) stream (view textual-view)
31     &key (default nil defaultp)
32     (default-type type))
33 thenriksen 1.2 (multiple-value-bind (object success string)
34     (complete-input stream
35     (lambda (so-far action)
36     (complete-from-possibilities
37 thenriksen 1.16 so-far (views *esa-instance*) '()
38     :action action
39     :name-key #'subscripted-name
40 thenriksen 1.2 :value-key #'identity))
41     :partial-completers '(#\Space)
42     :allow-any-input t)
43 thenriksen 1.10 (cond ((and success (plusp (length string)))
44     (if object
45     (values object type)
46     (values string 'string)))
47 thenriksen 1.2 ((and (zerop (length string)) defaultp)
48 thenriksen 1.10 (values default default-type))
49     (t
50     (values string 'string)))))
51    
52 thenriksen 1.16 (defgeneric switch-to-view (drei view)
53     (:documentation "High-level function for changing the view
54     displayed by a Drei instance."))
55 thenriksen 1.10
56 thenriksen 1.16 (defmethod switch-to-view ((drei climacs-pane) (view drei-view))
57     (setf (view drei) view))
58 thenriksen 1.10
59 thenriksen 1.16 (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 thenriksen 1.23 (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 thenriksen 1.16 (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 thenriksen 1.19 (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 thenriksen 1.16 (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 thenriksen 1.19 ;; 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 thenriksen 1.24 (when (buffer-view-p view)
121     (setf (buffer view) (dummy-buffer)))
122 thenriksen 1.16 (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 thenriksen 1.2
130 thenriksen 1.16 (defmethod kill-view ((symbol null))
131     (kill-view (current-view)))
132 thenriksen 1.2
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 thenriksen 1.12 (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 thenriksen 1.2
156 thenriksen 1.16 (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 thenriksen 1.2 ;; 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 thenriksen 1.3 (when (and specified-syntax
172 thenriksen 1.16 (not (eq (class-of (syntax view))
173 thenriksen 1.3 specified-syntax)))
174 thenriksen 1.16 (setf (syntax view)
175     (make-syntax-for-view view specified-syntax))))
176 thenriksen 1.2 ;; 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 thenriksen 1.16 do (eval-option (syntax view) name value)))
182 thenriksen 1.2
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 dmurray 1.4 (when line
199     (mapcar (lambda (pair) (split-attribute pair #\:))
200     (split-attribute line #\;))))
201 thenriksen 1.2
202 thenriksen 1.3 (defun find-attribute-line-position (buffer)
203 thenriksen 1.16 (let ((scan (make-buffer-mark buffer 0)))
204 thenriksen 1.2 ;; skip the leading whitespace
205     (loop until (end-of-buffer-p scan)
206 thenriksen 1.16 until (not (buffer-whitespacep (object-after scan)))
207 thenriksen 1.3 do (forward-object scan))
208 thenriksen 1.2 ;; 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 thenriksen 1.3 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 thenriksen 1.2 (when start-found
222 thenriksen 1.3 (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 dmurray 1.4 (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 thenriksen 1.3
248 thenriksen 1.16 (defun replace-attribute-line (view new-attribute-line)
249 thenriksen 1.3 (let ((full-attribute-line (concatenate 'string
250     "-*- "
251     new-attribute-line
252     "-*-")))
253 dmurray 1.4 (multiple-value-bind (start-mark end-mark)
254 thenriksen 1.16 (find-attribute-line-position (buffer view))
255 thenriksen 1.3 (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 thenriksen 1.16 (comment-region (syntax view)
261 thenriksen 1.3 new-line-start
262     start-mark)))
263     (t
264     ;; Create a new attribute line at beginning of buffer.
265 thenriksen 1.16 (let* ((mark1 (make-buffer-mark (buffer view) 0 :left))
266 thenriksen 1.3 (mark2 (clone-mark mark1 :right)))
267     (insert-sequence mark2 full-attribute-line)
268     (insert-object mark2 #\Newline)
269 thenriksen 1.16 (comment-region (syntax view)
270 thenriksen 1.3 mark1
271     mark2)))))))
272    
273 thenriksen 1.16 (defun update-attribute-line (view)
274     (replace-attribute-line
275     view (make-attribute-line (syntax view))))
276 thenriksen 1.2
277 thenriksen 1.16 (defun evaluate-attribute-line (view)
278 thenriksen 1.2 (evaluate-attributes
279 thenriksen 1.16 view (split-attribute-line (get-attribute-line (buffer view)))))
280 thenriksen 1.2
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 thenriksen 1.8 (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 thenriksen 1.16 (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 thenriksen 1.8 (flet ((usable-pathname (pathname)
299     (if (probe-file pathname)
300     (truename pathname)
301     pathname)))
302 thenriksen 1.16 (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 thenriksen 1.8
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 thenriksen 1.9 (find-file pathname)))
317 thenriksen 1.8
318 thenriksen 1.5 (defun find-file-impl (filepath &optional readonlyp)
319 thenriksen 1.2 (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 thenriksen 1.27 (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 thenriksen 1.2
355 thenriksen 1.9 (defmethod frame-find-file ((application-frame climacs) filepath)
356 thenriksen 1.5 (find-file-impl filepath nil))
357    
358 thenriksen 1.9 (defmethod frame-find-file-read-only ((application-frame climacs) filepath)
359 thenriksen 1.5 (find-file-impl filepath t))
360    
361 thenriksen 1.2 (defun directory-of-buffer (buffer)
362     "Extract the directory part of the filepath to the file in BUFFER.
363 thenriksen 1.16 If BUFFER does not have a filepath, the path to the user's home
364     directory will be returned."
365 thenriksen 1.2 (make-pathname
366     :directory
367     (pathname-directory
368     (or (filepath buffer)
369     (user-homedir-pathname)))))
370    
371 thenriksen 1.9 (defmethod frame-set-visited-filename ((application-frame climacs) filepath buffer)
372 thenriksen 1.25 (setf (filepath buffer) (pathname filepath)
373 thenriksen 1.2 (file-saved-p buffer) nil
374     (file-write-time buffer) nil
375 thenriksen 1.5 (name buffer) (filepath-filename filepath)
376 thenriksen 1.2 (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 thenriksen 1.16 (dolist (view (views frame))
394 thenriksen 1.27 (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 thenriksen 1.16 (when (or (notany #'buffer-of-view-needs-saving (views frame))
406     (handler-case (accept 'boolean :prompt "Modified buffers of views exist. Quit anyway?")
407 thenriksen 1.2 (error () (progn (beep)
408     (display-message "Invalid answer")
409     (return-from frame-exit nil)))))
410 thenriksen 1.17 (call-next-method)))

  ViewVC Help
Powered by ViewVC 1.1.5