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

Contents of /climacs/core.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.23 - (show annotations)
Fri Jan 18 07:44:56 2008 UTC (6 years, 3 months ago) by thenriksen
Branch: MAIN
Changes since 1.22: +9 -0 lines
Added `switch-or-move-to-view' function.
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 ((drei typeout-pane) (view drei-view))
60 (let ((usable-pane (or (find-if #'(lambda (pane)
61 (typep pane 'drei))
62 (windows *application-frame*))
63 (split-window t))))
64 (switch-to-view usable-pane view)))
65
66 (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 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 (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 (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 (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 ;; 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 (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
136 (defmethod kill-view ((symbol null))
137 (kill-view (current-view)))
138
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 (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
162 (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 ;; 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 (when (and specified-syntax
178 (not (eq (class-of (syntax view))
179 specified-syntax)))
180 (setf (syntax view)
181 (make-syntax-for-view view specified-syntax))))
182 ;; 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 do (eval-option (syntax view) name value)))
188
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 (when line
205 (mapcar (lambda (pair) (split-attribute pair #\:))
206 (split-attribute line #\;))))
207
208 (defun find-attribute-line-position (buffer)
209 (let ((scan (make-buffer-mark buffer 0)))
210 ;; skip the leading whitespace
211 (loop until (end-of-buffer-p scan)
212 until (not (buffer-whitespacep (object-after scan)))
213 do (forward-object scan))
214 ;; 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 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 (when start-found
228 (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 (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
254 (defun replace-attribute-line (view new-attribute-line)
255 (let ((full-attribute-line (concatenate 'string
256 "-*- "
257 new-attribute-line
258 "-*-")))
259 (multiple-value-bind (start-mark end-mark)
260 (find-attribute-line-position (buffer view))
261 (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 (comment-region (syntax view)
267 new-line-start
268 start-mark)))
269 (t
270 ;; Create a new attribute line at beginning of buffer.
271 (let* ((mark1 (make-buffer-mark (buffer view) 0 :left))
272 (mark2 (clone-mark mark1 :right)))
273 (insert-sequence mark2 full-attribute-line)
274 (insert-object mark2 #\Newline)
275 (comment-region (syntax view)
276 mark1
277 mark2)))))))
278
279 (defun update-attribute-line (view)
280 (replace-attribute-line
281 view (make-attribute-line (syntax view))))
282
283 (defun evaluate-attribute-line (view)
284 (evaluate-attributes
285 view (split-attribute-line (get-attribute-line (buffer view)))))
286
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 (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 (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 (flet ((usable-pathname (pathname)
305 (if (probe-file pathname)
306 (truename pathname)
307 pathname)))
308 (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
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 (find-file pathname)))
323
324 (defun find-file-impl (filepath &optional readonlyp)
325 (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 (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 (let* ((newp (not (probe-file filepath)))
342 (buffer (if newp
343 (make-new-buffer)
344 (with-open-file (stream filepath :direction :input)
345 (make-buffer-from-stream stream))))
346 (view (make-new-view-for-climacs
347 *esa-instance* 'textual-drei-syntax-view
348 :name (filepath-filename filepath)
349 :buffer buffer)))
350 (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 (setf (offset (point buffer)) (offset (point view))
356 (syntax view) (make-syntax-for-view view (syntax-class-name-for-filepath filepath))
357 (file-write-time buffer) (if newp (get-universal-time) (file-write-date filepath))
358 (needs-saving buffer) nil
359 (name buffer) (filepath-filename filepath))
360 (setf (current-view (current-window)) view)
361 (evaluate-attribute-line view)
362 (setf (filepath buffer) filepath
363 (read-only-p buffer) readonlyp)
364 (beginning-of-buffer (point view))
365 buffer)))))))
366
367 (defmethod frame-find-file ((application-frame climacs) filepath)
368 (find-file-impl filepath nil))
369
370 (defmethod frame-find-file-read-only ((application-frame climacs) filepath)
371 (find-file-impl filepath t))
372
373 (defun directory-of-buffer (buffer)
374 "Extract the directory part of the filepath to the file in BUFFER.
375 If BUFFER does not have a filepath, the path to the user's home
376 directory will be returned."
377 (make-pathname
378 :directory
379 (pathname-directory
380 (or (filepath buffer)
381 (user-homedir-pathname)))))
382
383 (defmethod frame-set-visited-filename ((application-frame climacs) filepath buffer)
384 (setf (filepath buffer) filepath
385 (file-saved-p buffer) nil
386 (file-write-time buffer) nil
387 (name buffer) (filepath-filename filepath)
388 (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 (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 (error () (progn (beep)
416 (display-message "Invalid answer")
417 (return-from frame-exit nil)))))
418 (call-next-method)))

  ViewVC Help
Powered by ViewVC 1.1.5