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

Contents of /climacs/core.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5