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

Contents of /climacs/core.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5