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

Contents of /climacs/core.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.21 - (show 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 ;;; -*- 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 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 (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 (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 ;; 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 (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
127 (defmethod kill-view ((symbol null))
128 (kill-view (current-view)))
129
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 (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
153 (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 ;; 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 (when (and specified-syntax
169 (not (eq (class-of (syntax view))
170 specified-syntax)))
171 (setf (syntax view)
172 (make-syntax-for-view view specified-syntax))))
173 ;; 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 do (eval-option (syntax view) name value)))
179
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 (when line
196 (mapcar (lambda (pair) (split-attribute pair #\:))
197 (split-attribute line #\;))))
198
199 (defun find-attribute-line-position (buffer)
200 (let ((scan (make-buffer-mark buffer 0)))
201 ;; skip the leading whitespace
202 (loop until (end-of-buffer-p scan)
203 until (not (buffer-whitespacep (object-after scan)))
204 do (forward-object scan))
205 ;; 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 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 (when start-found
219 (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 (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
245 (defun replace-attribute-line (view new-attribute-line)
246 (let ((full-attribute-line (concatenate 'string
247 "-*- "
248 new-attribute-line
249 "-*-")))
250 (multiple-value-bind (start-mark end-mark)
251 (find-attribute-line-position (buffer view))
252 (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 (comment-region (syntax view)
258 new-line-start
259 start-mark)))
260 (t
261 ;; Create a new attribute line at beginning of buffer.
262 (let* ((mark1 (make-buffer-mark (buffer view) 0 :left))
263 (mark2 (clone-mark mark1 :right)))
264 (insert-sequence mark2 full-attribute-line)
265 (insert-object mark2 #\Newline)
266 (comment-region (syntax view)
267 mark1
268 mark2)))))))
269
270 (defun update-attribute-line (view)
271 (replace-attribute-line
272 view (make-attribute-line (syntax view))))
273
274 (defun evaluate-attribute-line (view)
275 (evaluate-attributes
276 view (split-attribute-line (get-attribute-line (buffer view)))))
277
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 (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 (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 (flet ((usable-pathname (pathname)
296 (if (probe-file pathname)
297 (truename pathname)
298 pathname)))
299 (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
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 (find-file pathname)))
314
315 (defun find-file-impl (filepath &optional readonlyp)
316 (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 (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 (make-buffer-from-stream stream))
335 (make-new-buffer)))
336 (view (make-new-view-for-climacs
337 *esa-instance* 'textual-drei-syntax-view
338 :name (filepath-filename filepath)
339 :buffer buffer)))
340 (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 (setf (offset (point buffer)) (offset (point view))
346 (syntax view) (make-syntax-for-view view (syntax-class-name-for-filepath filepath))
347 (file-write-time buffer) (file-write-date filepath)
348 (needs-saving buffer) nil
349 (name buffer) (filepath-filename filepath))
350 (setf (current-view (current-window)) view)
351 (evaluate-attribute-line view)
352 (setf (filepath buffer) filepath
353 (read-only-p buffer) readonlyp)
354 (beginning-of-buffer (point view))
355 buffer)))))))
356
357 (defmethod frame-find-file ((application-frame climacs) filepath)
358 (find-file-impl filepath nil))
359
360 (defmethod frame-find-file-read-only ((application-frame climacs) filepath)
361 (find-file-impl filepath t))
362
363 (defun directory-of-buffer (buffer)
364 "Extract the directory part of the filepath to the file in BUFFER.
365 If BUFFER does not have a filepath, the path to the user's home
366 directory will be returned."
367 (make-pathname
368 :directory
369 (pathname-directory
370 (or (filepath buffer)
371 (user-homedir-pathname)))))
372
373 (defmethod frame-set-visited-filename ((application-frame climacs) filepath buffer)
374 (setf (filepath buffer) filepath
375 (file-saved-p buffer) nil
376 (file-write-time buffer) nil
377 (name buffer) (filepath-filename filepath)
378 (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 (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 (error () (progn (beep)
406 (display-message "Invalid answer")
407 (return-from frame-exit nil)))))
408 (call-next-method)))

  ViewVC Help
Powered by ViewVC 1.1.5