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

Contents of /climacs/core.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (show annotations)
Fri Nov 16 09:25:03 2007 UTC (6 years, 5 months ago) by thenriksen
Branch: MAIN
Changes since 1.12: +1 -10 lines
Made code for buffer switching in Climacs a bit more centralised, you
no longer have to use `switch-to-buffer' or experience pain.
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 (let ((buffer (make-instance 'climacs-buffer :name name)))
23 (push buffer (buffers application-frame))
24 buffer))
25
26 (defgeneric erase-buffer (buffer))
27
28 (defmethod erase-buffer ((buffer string))
29 (let ((b (find buffer (buffers *application-frame*)
30 :key #'name :test #'string=)))
31 (when b (erase-buffer b))))
32
33 (defmethod erase-buffer ((buffer drei-buffer))
34 (let* ((point (point buffer))
35 (mark (clone-mark point)))
36 (beginning-of-buffer mark)
37 (end-of-buffer point)
38 (delete-region mark point)))
39
40 (define-presentation-method present (object (type buffer)
41 stream
42 (view textual-view)
43 &key acceptably for-context-type)
44 (declare (ignore acceptably for-context-type))
45 (princ (name object) stream))
46
47 (define-presentation-method accept
48 ((type buffer) stream (view textual-view) &key (default nil defaultp)
49 (default-type type))
50 (multiple-value-bind (object success string)
51 (complete-input stream
52 (lambda (so-far action)
53 (complete-from-possibilities
54 so-far (buffers *application-frame*) '() :action action
55 :name-key #'name
56 :value-key #'identity))
57 :partial-completers '(#\Space)
58 :allow-any-input t)
59 (cond ((and success (plusp (length string)))
60 (if object
61 (values object type)
62 (values string 'string)))
63 ((and (zerop (length string)) defaultp)
64 (values default default-type))
65 (t
66 (values string 'string)))))
67
68 (defgeneric switch-to-buffer (pane buffer))
69
70 (defmethod switch-to-buffer ((pane drei) (buffer drei-buffer))
71 (setf (buffer pane) buffer))
72
73 (defmethod switch-to-buffer ((pane typeout-pane) (buffer drei-buffer))
74 (let ((usable-pane (or (find-if #'(lambda (pane)
75 (typep pane 'drei))
76 (windows *application-frame*))
77 (split-window t))))
78 (switch-to-buffer usable-pane buffer)))
79
80 (defmethod switch-to-buffer (pane (name string))
81 (let ((buffer (find name (buffers *application-frame*)
82 :key #'name :test #'string=)))
83 (switch-to-buffer pane
84 (or buffer
85 (make-new-buffer :name name)))))
86
87 ;; ;;; FIXME: see the comment by (SETF SYNTAX) :AROUND. -- CSR,
88 ;; ;;; 2005-10-31.
89 ;; (defmethod (setf buffer) :around (buffer (pane drei))
90 ;; (call-next-method)
91 ;; (note-pane-syntax-changed pane (syntax buffer)))
92
93 (defgeneric kill-buffer (buffer))
94
95 (defmethod kill-buffer ((buffer drei-buffer))
96 (with-accessors ((buffers buffers)) *application-frame*
97 (when (and (needs-saving buffer)
98 (handler-case (accept 'boolean :prompt "Save buffer first?")
99 (error () (progn (beep)
100 (display-message "Invalid answer")
101 (return-from kill-buffer nil)))))
102 (save-buffer buffer))
103 (setf buffers (remove buffer buffers))
104 ;; Always need one buffer.
105 (when (null buffers)
106 (make-new-buffer :name "*scratch*"))
107 (setf (buffer (current-window)) (car buffers))
108 (full-redisplay (current-window))
109 (buffer (current-window))))
110
111 (defmethod kill-buffer ((name string))
112 (let ((buffer (find name (buffers *application-frame*)
113 :key #'name :test #'string=)))
114 (when buffer (kill-buffer buffer))))
115
116 (defmethod kill-buffer ((symbol (eql 'nil)))
117 (kill-buffer (buffer (current-window))))
118
119 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
120 ;;;
121 ;;; File handling
122
123 (defun filepath-filename (pathname)
124 (if (null (pathname-type pathname))
125 (pathname-name pathname)
126 (concatenate 'string (pathname-name pathname)
127 "." (pathname-type pathname))))
128
129 (defun syntax-class-name-for-filepath (filepath)
130 (let ((syntax-description
131 (find (or (pathname-type filepath)
132 (pathname-name filepath))
133 drei-syntax::*syntaxes*
134 :test (lambda (x y)
135 (member x y :test #'string-equal))
136 :key #'drei-syntax::syntax-description-pathname-types)))
137 (if syntax-description
138 (drei-syntax::syntax-description-class-name
139 syntax-description)
140 *default-syntax*)))
141
142 (defun evaluate-attributes (buffer options)
143 "Evaluate the attributes `options' and modify `buffer' as
144 appropriate. `Options' should be an alist mapping option names
145 to their values."
146 ;; First, check whether we need to change the syntax (via the SYNTAX
147 ;; option). MODE is an alias for SYNTAX for compatibility with
148 ;; Emacs. If there is more than one option with one of these names,
149 ;; only the first will be acted upon.
150 (let ((specified-syntax
151 (syntax-from-name
152 (second (find-if #'(lambda (name)
153 (or (string-equal name "SYNTAX")
154 (string-equal name "MODE")))
155 options
156 :key #'first)))))
157 (when (and specified-syntax
158 (not (eq (class-of (syntax buffer))
159 specified-syntax)))
160 (setf (syntax buffer)
161 (make-instance specified-syntax
162 :buffer buffer))))
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 buffer) 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 (beginning-of-buffer (clone-mark (point buffer)))))
191 ;; skip the leading whitespace
192 (loop until (end-of-buffer-p scan)
193 until (not (whitespacep (syntax buffer) (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 (buffer 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)
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 buffer)
248 new-line-start
249 start-mark)))
250 (t
251 ;; Create a new attribute line at beginning of buffer.
252 (let* ((mark1 (beginning-of-buffer (clone-mark (point buffer) :left)))
253 (mark2 (clone-mark mark1 :right)))
254 (insert-sequence mark2 full-attribute-line)
255 (insert-object mark2 #\Newline)
256 (comment-region (syntax buffer)
257 mark1
258 mark2)))))))
259
260 (defun update-attribute-line (buffer)
261 (replace-attribute-line buffer
262 (make-attribute-line (syntax buffer))))
263
264 (defun evaluate-attribute-line (buffer)
265 (evaluate-attributes
266 buffer
267 (split-attribute-line (get-attribute-line buffer))))
268
269 ;; Adapted from cl-fad/PCL
270 (defun directory-pathname-p (pathspec)
271 "Returns NIL if PATHSPEC does not designate a directory."
272 (let ((name (pathname-name pathspec))
273 (type (pathname-type pathspec)))
274 (and (or (null name) (eql name :unspecific))
275 (or (null type) (eql type :unspecific)))))
276
277 (defun findablep (pathname)
278 "Return non-NIL if `pathname' can be opened by Climacs. That
279 is, check whether the file exists and is not a directory."
280 (and (probe-file pathname)
281 (not (directory-pathname-p pathname))))
282
283 (defun find-buffer-with-pathname (pathname)
284 "Return the (first) buffer associated with the file designated
285 by `pathname'. Returns NIL if no buffer can be found."
286 (flet ((usable-pathname (pathname)
287 (if (probe-file pathname)
288 (truename pathname)
289 pathname)))
290 (find pathname (buffers *application-frame*)
291 :key #'filepath
292 :test #'(lambda (fp1 fp2)
293 (and fp1 fp2
294 (equal (usable-pathname fp1)
295 (usable-pathname fp2)))))))
296
297 (defun ensure-open-file (pathname)
298 "Make sure a buffer opened on `pathname' exists, finding the
299 file if necessary."
300 (when (and (findablep pathname)
301 (not (find-buffer-with-pathname pathname)))
302 (find-file pathname)))
303
304 (defun find-file-impl (filepath &optional readonlyp)
305 (cond ((null filepath)
306 (display-message "No file name given.")
307 (beep))
308 ((directory-pathname-p filepath)
309 (display-message "~A is a directory name." filepath)
310 (beep))
311 (t
312 (let ((existing-buffer (find-buffer-with-pathname filepath)))
313 (if (and existing-buffer (if readonlyp (read-only-p existing-buffer) t))
314 (switch-to-buffer *current-window* existing-buffer)
315 (progn
316 (when readonlyp
317 (unless (probe-file filepath)
318 (beep)
319 (display-message "No such file: ~A" filepath)
320 (return-from find-file-impl nil)))
321 (let ((buffer (if (probe-file filepath)
322 (with-open-file (stream filepath :direction :input)
323 (make-buffer-from-stream stream))
324 (make-new-buffer)))
325 (pane (current-window)))
326 (setf (offset (point (buffer pane))) (offset (point pane))
327 (buffer (current-window)) buffer
328 (syntax buffer) (make-instance (syntax-class-name-for-filepath filepath)
329 :buffer buffer)
330 (file-write-time buffer) (file-write-date filepath))
331 (evaluate-attribute-line buffer)
332 (setf (filepath buffer) filepath
333 (name buffer) (filepath-filename filepath)
334 (read-only-p buffer) readonlyp)
335 (beginning-of-buffer (point pane))
336 (update-syntax buffer (syntax buffer))
337 (clear-modify buffer)
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 (loop for buffer in (buffers frame)
379 when (and (needs-saving buffer)
380 (filepath buffer)
381 (handler-case (accept 'boolean
382 :prompt (format nil "Save buffer: ~a ?" (name buffer)))
383 (error () (progn (beep)
384 (display-message "Invalid answer")
385 (return-from frame-exit nil)))))
386 do (save-buffer buffer))
387 (when (or (notany #'(lambda (buffer) (and (needs-saving buffer) (filepath buffer)))
388 (buffers frame))
389 (handler-case (accept 'boolean :prompt "Modified buffers exist. Quit anyway?")
390 (error () (progn (beep)
391 (display-message "Invalid answer")
392 (return-from frame-exit nil)))))
393 (call-next-method)))

  ViewVC Help
Powered by ViewVC 1.1.5