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

Contents of /climacs/core.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5