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

Contents of /climacs/core.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (hide annotations)
Sun Aug 20 13:06:39 2006 UTC (7 years, 8 months ago) by thenriksen
Branch: MAIN
Changes since 1.4: +33 -76 lines
Changed Climacs to use the ESA-IO and ESA-BUFFER functionality instead
of duplicating essentially the same code across multiple
projects. This is rather invasive as some of the ESA functions have a
subtly different signature.
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     ;;; Misc stuff
19    
20 thenriksen 1.2 (defun display-string (string)
21     (with-output-to-string (result)
22     (loop for char across string
23     do (cond ((graphic-char-p char) (princ char result))
24     ((char= char #\Space) (princ char result))
25     (t (prin1 char result))))))
26    
27     (defun object-equal (x y)
28     "Case insensitive equality that doesn't require characters"
29     (if (characterp x)
30     (and (characterp y) (char-equal x y))
31     (eql x y)))
32    
33     (defun object= (x y)
34     "Case sensitive equality that doesn't require characters"
35     (if (characterp x)
36     (and (characterp y) (char= x y))
37     (eql x y)))
38    
39     (defun no-upper-p (string)
40     "Does STRING contain no uppercase characters"
41     (notany #'upper-case-p string))
42    
43     (defun case-relevant-test (string)
44     "Returns a test function based on the search-string STRING.
45     If STRING contains no uppercase characters the test is case-insensitive,
46     otherwise it is case-sensitive."
47     (if (no-upper-p string)
48     #'object-equal
49     #'object=))
50    
51 thenriksen 1.1 (defun possibly-fill-line ()
52     (let* ((pane (current-window))
53     (buffer (buffer pane)))
54     (when (auto-fill-mode pane)
55     (let* ((fill-column (auto-fill-column pane))
56     (point (point pane))
57     (offset (offset point))
58     (tab-width (tab-space-count (stream-default-view pane)))
59     (syntax (syntax buffer)))
60     (when (>= (buffer-display-column buffer offset tab-width)
61     (1- fill-column))
62     (fill-line point
63     (lambda (mark)
64     (syntax-line-indentation mark tab-width syntax))
65     fill-column
66     tab-width
67     (syntax buffer)))))))
68    
69     (defun insert-character (char)
70     (let* ((window (current-window))
71     (point (point window)))
72     (unless (constituentp char)
73     (possibly-expand-abbrev point))
74     (when (whitespacep (syntax (buffer window)) char)
75     (possibly-fill-line))
76     (if (and (slot-value window 'overwrite-mode) (not (end-of-line-p point)))
77     (progn
78     (delete-range point)
79     (insert-object point char))
80     (insert-object point char))))
81    
82     (defun back-to-indentation (mark syntax)
83     (beginning-of-line mark)
84     (loop until (end-of-line-p mark)
85     while (whitespacep syntax (object-after mark))
86     do (forward-object mark)))
87    
88     (defun delete-horizontal-space (mark syntax &optional (backward-only-p nil))
89     (let ((mark2 (clone-mark mark)))
90     (loop until (beginning-of-line-p mark)
91     while (whitespacep syntax (object-before mark))
92     do (backward-object mark))
93     (unless backward-only-p
94     (loop until (end-of-line-p mark2)
95     while (whitespacep syntax (object-after mark2))
96     do (forward-object mark2)))
97     (delete-region mark mark2)))
98    
99     (defun goto-position (mark pos)
100     (setf (offset mark) pos))
101    
102     (defun goto-line (mark line-number)
103     (loop with m = (clone-mark (low-mark (buffer mark))
104     :right)
105     initially (beginning-of-buffer m)
106     do (end-of-line m)
107     until (end-of-buffer-p m)
108     repeat (1- line-number)
109     do (incf (offset m))
110     (end-of-line m)
111     finally (beginning-of-line m)
112     (setf (offset mark) (offset m))))
113    
114     (defun indent-current-line (pane point)
115     (let* ((buffer (buffer pane))
116     (view (stream-default-view pane))
117     (tab-space-count (tab-space-count view))
118     (indentation (syntax-line-indentation point
119     tab-space-count
120     (syntax buffer))))
121     (indent-line point indentation (and (indent-tabs-mode buffer)
122     tab-space-count))))
123    
124     (defun insert-pair (mark syntax &optional (count 0) (open #\() (close #\)))
125     (cond ((> count 0)
126     (loop while (and (not (end-of-buffer-p mark))
127     (whitespacep syntax (object-after mark)))
128     do (forward-object mark)))
129     ((< count 0)
130     (setf count (- count))
131     (loop repeat count do (backward-expression mark syntax))))
132     (unless (or (beginning-of-buffer-p mark)
133     (whitespacep syntax (object-before mark)))
134     (insert-object mark #\Space))
135     (insert-object mark open)
136     (let ((here (clone-mark mark)))
137     (loop repeat count
138     do (forward-expression here syntax))
139     (insert-object here close)
140     (unless (or (end-of-buffer-p here)
141     (whitespacep syntax (object-after here)))
142     (insert-object here #\Space))))
143    
144     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
145     ;;;
146     ;;; Character case
147    
148     (defun downcase-word (mark &optional (n 1))
149     "Convert the next N words to lowercase, leaving mark after the last word."
150     (let ((syntax (syntax (buffer mark))))
151     (loop repeat n
152     do (forward-to-word-boundary mark syntax)
153     (let ((offset (offset mark)))
154     (forward-word mark syntax 1 nil)
155     (downcase-region offset mark)))))
156    
157     (defun upcase-word (mark syntax &optional (n 1))
158     "Convert the next N words to uppercase, leaving mark after the last word."
159     (loop repeat n
160     do (forward-to-word-boundary mark syntax)
161     (let ((offset (offset mark)))
162     (forward-word mark syntax 1 nil)
163     (upcase-region offset mark))))
164    
165     (defun capitalize-word (mark &optional (n 1))
166     "Capitalize the next N words, leaving mark after the last word."
167     (let ((syntax (syntax (buffer mark))))
168     (loop repeat n
169     do (forward-to-word-boundary mark syntax)
170     (let ((offset (offset mark)))
171     (forward-word mark syntax 1 nil)
172     (capitalize-region offset mark)))))
173    
174     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
175     ;;;
176     ;;; Indentation
177    
178     (defun indent-region (pane mark1 mark2)
179     "Indent all lines in the region delimited by `mark1' and `mark2'
180     according to the rules of the active syntax in `pane'."
181     (let* ((buffer (buffer pane))
182     (view (clim:stream-default-view pane))
183     (tab-space-count (tab-space-count view))
184     (tab-width (and (indent-tabs-mode buffer)
185     tab-space-count))
186     (syntax (syntax buffer)))
187     (do-buffer-region-lines (line mark1 mark2)
188     (let ((indentation (syntax-line-indentation
189     line
190     tab-space-count
191     syntax)))
192     (indent-line line indentation tab-width))
193     ;; We need to update the syntax every time we perform an
194     ;; indentation, so that subsequent indentations will be
195     ;; correctly indented (this matters in list forms). FIXME: This
196     ;; should probably happen automatically.
197     (update-syntax buffer syntax))))
198    
199     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
200     ;;;
201     ;;; Auto fill
202    
203     (defun fill-line (mark syntax-line-indentation-function fill-column tab-width syntax
204     &optional (compress-whitespaces t))
205     "Breaks the contents of line pointed to by MARK up to MARK into
206     multiple lines such that none of them is longer than FILL-COLUMN. If
207     COMPRESS-WHITESPACES is non-nil, whitespaces are compressed after the
208     decision is made to break the line at a point. For now, the
209     compression means just the deletion of trailing whitespaces."
210     (let ((begin-mark (clone-mark mark)))
211     (beginning-of-line begin-mark)
212     (loop with column = 0
213     with line-beginning-offset = (offset begin-mark)
214     with walking-mark = (clone-mark begin-mark)
215     while (mark< walking-mark mark)
216     as object = (object-after walking-mark)
217     do (case object
218     (#\Space
219     (setf (offset begin-mark) (offset walking-mark))
220     (incf column))
221     (#\Tab
222     (setf (offset begin-mark) (offset walking-mark))
223     (incf column (- tab-width (mod column tab-width))))
224     (t
225     (incf column)))
226     (when (and (>= column fill-column)
227     (/= (offset begin-mark) line-beginning-offset))
228     (when compress-whitespaces
229     (let ((offset (buffer-search-backward
230     (buffer begin-mark)
231     (offset begin-mark)
232     #(nil)
233     :test #'(lambda (o1 o2)
234     (declare (ignore o2))
235     (not (whitespacep syntax o1))))))
236     (when offset
237     (delete-region begin-mark (1+ offset)))))
238     (insert-object begin-mark #\Newline)
239     (incf (offset begin-mark))
240     (let ((indentation
241     (funcall syntax-line-indentation-function begin-mark)))
242     (indent-line begin-mark indentation tab-width))
243     (beginning-of-line begin-mark)
244     (setf line-beginning-offset (offset begin-mark))
245     (setf (offset walking-mark) (offset begin-mark))
246     (setf column 0))
247     (incf (offset walking-mark)))))
248    
249     (defun fill-region (mark1 mark2 syntax-line-indentation-function fill-column tab-width syntax
250     &optional (compress-whitespaces t))
251     "Fill the region delimited by `mark1' and `mark2'. `Mark1' must be
252     mark<= `mark2.'"
253     (let* ((buffer (buffer mark1)))
254     (do-buffer-region (object offset buffer
255     (offset mark1) (offset mark2))
256     (when (eql object #\Newline)
257     (setf object #\Space)))
258     (when (>= (buffer-display-column buffer (offset mark2) tab-width)
259     (1- fill-column))
260     (fill-line mark2
261     syntax-line-indentation-function
262     fill-column
263     tab-width
264     compress-whitespaces
265     syntax))))
266    
267     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
268     ;;;
269     ;;; Indentation
270    
271     (defgeneric indent-line (mark indentation tab-width)
272     (:documentation "Indent the line containing mark with indentation
273     spaces. Use tabs and spaces if tab-width is not nil, otherwise use
274     spaces only."))
275    
276     (defun indent-line* (mark indentation tab-width left)
277     (let ((mark2 (clone-mark mark)))
278     (beginning-of-line mark2)
279     (loop until (end-of-buffer-p mark2)
280     as object = (object-after mark2)
281     while (or (eql object #\Space) (eql object #\Tab))
282     do (delete-range mark2 1))
283     (loop until (zerop indentation)
284     do (cond ((and tab-width (>= indentation tab-width))
285     (insert-object mark2 #\Tab)
286     (when left ; spaces must follow tabs
287     (forward-object mark2))
288     (decf indentation tab-width))
289     (t
290     (insert-object mark2 #\Space)
291     (decf indentation))))))
292    
293     (defmethod indent-line ((mark left-sticky-mark) indentation tab-width)
294     (indent-line* mark indentation tab-width t))
295    
296     (defmethod indent-line ((mark right-sticky-mark) indentation tab-width)
297     (indent-line* mark indentation tab-width nil))
298    
299     (defun delete-indentation (mark)
300     (beginning-of-line mark)
301     (unless (beginning-of-buffer-p mark)
302     (delete-range mark -1)
303     (loop until (end-of-buffer-p mark)
304     while (buffer-whitespacep (object-after mark))
305     do (delete-range mark 1))
306     (loop until (beginning-of-buffer-p mark)
307     while (buffer-whitespacep (object-before mark))
308     do (delete-range mark -1))
309     (when (and (not (beginning-of-buffer-p mark))
310     (constituentp (object-before mark)))
311     (insert-object mark #\Space))))
312 thenriksen 1.2
313     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
314     ;;;
315     ;;; Syntax handling
316    
317     (defgeneric set-syntax (buffer syntax))
318    
319     (defmethod set-syntax ((buffer climacs-buffer) (syntax syntax))
320     (setf (syntax buffer) syntax))
321    
322     ;;FIXME - what should this specialise on?
323     (defmethod set-syntax ((buffer climacs-buffer) syntax)
324     (set-syntax buffer (make-instance syntax :buffer buffer)))
325    
326     (defmethod set-syntax ((buffer climacs-buffer) (syntax string))
327     (let ((syntax-class (syntax-from-name syntax)))
328     (cond (syntax-class
329     (set-syntax buffer (make-instance syntax-class
330     :buffer buffer)))
331     (t
332     (beep)
333     (display-message "No such syntax: ~A." syntax)))))
334    
335     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
336     ;;;
337     ;;; Buffer handling
338    
339 thenriksen 1.5 (defmethod make-new-buffer ((application-frame climacs))
340 thenriksen 1.2 (let ((buffer (make-instance 'climacs-buffer)))
341 thenriksen 1.5 (push buffer (buffers application-frame))
342     buffer))
343    
344     (defun make-new-named-buffer (&optional name)
345     (let ((buffer (make-new-buffer *application-frame*)))
346 thenriksen 1.2 (when name (setf (name buffer) name))
347     buffer))
348    
349     (defgeneric erase-buffer (buffer))
350    
351     (defmethod erase-buffer ((buffer string))
352     (let ((b (find buffer (buffers *application-frame*)
353     :key #'name :test #'string=)))
354     (when b (erase-buffer b))))
355    
356     (defmethod erase-buffer ((buffer climacs-buffer))
357     (let* ((point (point buffer))
358     (mark (clone-mark point)))
359     (beginning-of-buffer mark)
360     (end-of-buffer point)
361     (delete-region mark point)))
362    
363     (define-presentation-method present (object (type buffer)
364     stream
365     (view textual-view)
366     &key acceptably for-context-type)
367     (declare (ignore acceptably for-context-type))
368     (princ (name object) stream))
369    
370     (define-presentation-method accept
371     ((type buffer) stream (view textual-view) &key (default nil defaultp)
372     (default-type type))
373     (multiple-value-bind (object success string)
374     (complete-input stream
375     (lambda (so-far action)
376     (complete-from-possibilities
377     so-far (buffers *application-frame*) '() :action action
378     :name-key #'name
379     :value-key #'identity))
380     :partial-completers '(#\Space)
381     :allow-any-input t)
382     (cond (success
383     (values object type))
384     ((and (zerop (length string)) defaultp)
385     (values default default-type))
386     (t (values string 'string)))))
387    
388     (defgeneric switch-to-buffer (buffer))
389    
390     (defmethod switch-to-buffer ((buffer climacs-buffer))
391     (let* ((buffers (buffers *application-frame*))
392     (position (position buffer buffers))
393     (pane (current-window)))
394     (when position
395     (setf buffers (delete buffer buffers)))
396     (push buffer (buffers *application-frame*))
397     (setf (offset (point (buffer pane))) (offset (point pane)))
398     (setf (buffer pane) buffer)
399     (full-redisplay pane)
400     buffer))
401    
402     (defmethod switch-to-buffer ((name string))
403     (let ((buffer (find name (buffers *application-frame*)
404     :key #'name :test #'string=)))
405     (switch-to-buffer (or buffer
406 thenriksen 1.5 (make-new-named-buffer name)))))
407 thenriksen 1.2
408     ;;placeholder
409     (defmethod switch-to-buffer ((symbol (eql 'nil)))
410     (let ((default (second (buffers *application-frame*))))
411     (when default
412     (switch-to-buffer default))))
413    
414     ;; ;;; FIXME: see the comment by (SETF SYNTAX) :AROUND. -- CSR,
415     ;; ;;; 2005-10-31.
416     ;; (defmethod (setf buffer) :around (buffer (pane extended-pane))
417     ;; (call-next-method)
418     ;; (note-pane-syntax-changed pane (syntax buffer)))
419    
420     (defgeneric kill-buffer (buffer))
421    
422     (defmethod kill-buffer ((buffer climacs-buffer))
423     (with-slots (buffers) *application-frame*
424     (when (and (needs-saving buffer)
425     (handler-case (accept 'boolean :prompt "Save buffer first?")
426     (error () (progn (beep)
427     (display-message "Invalid answer")
428     (return-from kill-buffer nil)))))
429 thenriksen 1.5 (save-buffer buffer *application-frame*))
430 thenriksen 1.2 (setf buffers (remove buffer buffers))
431     ;; Always need one buffer.
432     (when (null buffers)
433 thenriksen 1.5 (make-new-named-buffer "*scratch*"))
434 thenriksen 1.2 (setf (buffer (current-window)) (car buffers))
435     (full-redisplay (current-window))
436     (buffer (current-window))))
437    
438     (defmethod kill-buffer ((name string))
439     (let ((buffer (find name (buffers *application-frame*)
440     :key #'name :test #'string=)))
441     (when buffer (kill-buffer buffer))))
442    
443     (defmethod kill-buffer ((symbol (eql 'nil)))
444     (kill-buffer (buffer (current-window))))
445    
446     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
447     ;;;
448     ;;; File handling
449    
450     (defun filepath-filename (pathname)
451     (if (null (pathname-type pathname))
452     (pathname-name pathname)
453     (concatenate 'string (pathname-name pathname)
454     "." (pathname-type pathname))))
455    
456     (defun syntax-class-name-for-filepath (filepath)
457     (or (climacs-syntax::syntax-description-class-name
458     (find (or (pathname-type filepath)
459     (pathname-name filepath))
460     climacs-syntax::*syntaxes*
461     :test (lambda (x y)
462     (member x y :test #'string-equal))
463     :key #'climacs-syntax::syntax-description-pathname-types))
464     'basic-syntax))
465    
466     (defun evaluate-attributes (buffer options)
467     "Evaluate the attributes `options' and modify `buffer' as
468     appropriate. `Options' should be an alist mapping option names
469     to their values."
470     ;; First, check whether we need to change the syntax (via the SYNTAX
471     ;; option). MODE is an alias for SYNTAX for compatibility with
472     ;; Emacs. If there is more than one option with one of these names,
473     ;; only the first will be acted upon.
474     (let ((specified-syntax
475     (syntax-from-name
476     (second (find-if #'(lambda (name)
477     (or (string-equal name "SYNTAX")
478     (string-equal name "MODE")))
479     options
480     :key #'first)))))
481 thenriksen 1.3 (when (and specified-syntax
482     (not (eq (class-of (syntax buffer))
483     specified-syntax)))
484 thenriksen 1.2 (setf (syntax buffer)
485     (make-instance specified-syntax
486     :buffer buffer))))
487     ;; Now we iterate through the options (discarding SYNTAX and MODE
488     ;; options).
489     (loop for (name value) in options
490     unless (or (string-equal name "SYNTAX")
491     (string-equal name "MODE"))
492     do (eval-option (syntax buffer) name value)))
493    
494     (defun split-attribute (string char)
495     (let (pairs)
496     (loop with start = 0
497     for ch across string
498     for i from 0
499     when (eql ch char)
500     do (push (string-trim '(#\Space #\Tab) (subseq string start i))
501     pairs)
502     (setf start (1+ i))
503     finally (unless (>= start i)
504     (push (string-trim '(#\Space #\Tab) (subseq string start))
505     pairs)))
506     (nreverse pairs)))
507    
508     (defun split-attribute-line (line)
509 dmurray 1.4 (when line
510     (mapcar (lambda (pair) (split-attribute pair #\:))
511     (split-attribute line #\;))))
512 thenriksen 1.2
513 thenriksen 1.3 (defun find-attribute-line-position (buffer)
514 thenriksen 1.2 (let ((scan (beginning-of-buffer (clone-mark (point buffer)))))
515     ;; skip the leading whitespace
516     (loop until (end-of-buffer-p scan)
517 thenriksen 1.3 until (not (whitespacep (syntax buffer) (object-after scan)))
518     do (forward-object scan))
519 thenriksen 1.2 ;; stop looking if we're already 1,000 objects into the buffer
520     (unless (> (offset scan) 1000)
521     (let ((start-found
522     (loop with newlines = 0
523 thenriksen 1.3 when (end-of-buffer-p scan)
524     do (return nil)
525     when (eql (object-after scan) #\Newline)
526     do (incf newlines)
527     when (> newlines 1)
528     do (return nil)
529     until (looking-at scan "-*-")
530     do (forward-object scan)
531     finally (return t))))
532 thenriksen 1.2 (when start-found
533 thenriksen 1.3 (let* ((end-scan (clone-mark scan))
534     (end-found
535     (loop when (end-of-buffer-p end-scan)
536     do (return nil)
537     when (eql (object-after end-scan) #\Newline)
538     do (return nil)
539     do (forward-object end-scan)
540     until (looking-at end-scan "-*-")
541     finally (return t))))
542     (when end-found
543     (values scan
544     (progn (forward-object end-scan 3)
545     end-scan)))))))))
546    
547     (defun get-attribute-line (buffer)
548 dmurray 1.4 (multiple-value-bind (start-mark end-mark)
549     (find-attribute-line-position buffer)
550     (when (and start-mark end-mark)
551     (let ((line (buffer-substring buffer
552     (offset start-mark)
553     (offset end-mark))))
554     (when (>= (length line) 6)
555     (let ((end (search "-*-" line :from-end t :start2 3)))
556     (when end
557     (string-trim '(#\Space #\Tab) (subseq line 3 end)))))))))
558 thenriksen 1.3
559     (defun replace-attribute-line (buffer new-attribute-line)
560     (let ((full-attribute-line (concatenate 'string
561     "-*- "
562     new-attribute-line
563     "-*-")))
564 dmurray 1.4 (multiple-value-bind (start-mark end-mark)
565     (find-attribute-line-position buffer)
566 thenriksen 1.3 (cond ((not (null end-mark))
567     ;; We have an existing attribute line.
568     (delete-region start-mark end-mark)
569     (let ((new-line-start (clone-mark start-mark :left)))
570     (insert-sequence start-mark full-attribute-line)
571     (comment-region (syntax buffer)
572     new-line-start
573     start-mark)))
574     (t
575     ;; Create a new attribute line at beginning of buffer.
576     (let* ((mark1 (beginning-of-buffer (clone-mark (point buffer) :left)))
577     (mark2 (clone-mark mark1 :right)))
578     (insert-sequence mark2 full-attribute-line)
579     (insert-object mark2 #\Newline)
580     (comment-region (syntax buffer)
581     mark1
582     mark2)))))))
583    
584     (defun update-attribute-line (buffer)
585     (replace-attribute-line buffer
586     (make-attribute-line (syntax buffer))))
587 thenriksen 1.2
588 thenriksen 1.3 (defun evaluate-attribute-line (buffer)
589 thenriksen 1.2 (evaluate-attributes
590     buffer
591     (split-attribute-line (get-attribute-line buffer))))
592    
593     ;; Adapted from cl-fad/PCL
594     (defun directory-pathname-p (pathspec)
595     "Returns NIL if PATHSPEC does not designate a directory."
596     (let ((name (pathname-name pathspec))
597     (type (pathname-type pathspec)))
598     (and (or (null name) (eql name :unspecific))
599     (or (null type) (eql type :unspecific)))))
600    
601 thenriksen 1.5 (defun find-file-impl (filepath &optional readonlyp)
602 thenriksen 1.2 (cond ((null filepath)
603     (display-message "No file name given.")
604     (beep))
605     ((directory-pathname-p filepath)
606     (display-message "~A is a directory name." filepath)
607     (beep))
608     (t
609     (flet ((usable-pathname (pathname)
610 thenriksen 1.5 (if (probe-file pathname)
611     (truename pathname)
612     pathname)))
613 thenriksen 1.2 (let ((existing-buffer (find filepath (buffers *application-frame*)
614     :key #'filepath
615     :test #'(lambda (fp1 fp2)
616     (and fp1 fp2
617     (equal (usable-pathname fp1)
618     (usable-pathname fp2)))))))
619     (if (and existing-buffer (if readonlyp (read-only-p existing-buffer) t))
620     (switch-to-buffer existing-buffer)
621     (progn
622     (when readonlyp
623     (unless (probe-file filepath)
624     (beep)
625     (display-message "No such file: ~A" filepath)
626 thenriksen 1.5 (return-from find-file-impl nil)))
627     (let ((buffer (if (probe-file filepath)
628     (with-open-file (stream filepath :direction :input)
629     (make-buffer-from-stream stream *application-frame*))
630     (make-new-buffer *application-frame*)))
631 thenriksen 1.2 (pane (current-window)))
632     ;; Clear the pane's cache; otherwise residue from the
633     ;; previously displayed buffer may under certain
634     ;; circumstances be displayed.
635     (clear-cache pane)
636 thenriksen 1.5 (setf (offset (point (buffer pane))) (offset (point pane))
637     (buffer (current-window)) buffer
638     (syntax buffer) (make-instance (syntax-class-name-for-filepath filepath)
639     :buffer buffer)
640     (file-write-time buffer) (file-write-date filepath))
641     (evaluate-attribute-line buffer)
642 thenriksen 1.2 (setf (filepath buffer) filepath
643     (name buffer) (filepath-filename filepath)
644     (read-only-p buffer) readonlyp)
645     (beginning-of-buffer (point pane))
646     (update-syntax buffer (syntax buffer))
647     (clear-modify buffer)
648     buffer))))))))
649    
650 thenriksen 1.5 (defmethod find-file (filepath (application-frame climacs))
651     (find-file-impl filepath nil))
652    
653     (defmethod find-file-read-only (filepath (application-frame climacs))
654     (find-file-impl filepath t))
655    
656 thenriksen 1.2 (defun directory-of-buffer (buffer)
657     "Extract the directory part of the filepath to the file in BUFFER.
658     If BUFFER does not have a filepath, the path to the user's home
659     directory will be returned."
660     (make-pathname
661     :directory
662     (pathname-directory
663     (or (filepath buffer)
664     (user-homedir-pathname)))))
665    
666 thenriksen 1.5 (defmethod set-visited-filename (filepath buffer (application-frame climacs))
667     (setf (filepath buffer) filepath
668 thenriksen 1.2 (file-saved-p buffer) nil
669     (file-write-time buffer) nil
670 thenriksen 1.5 (name buffer) (filepath-filename filepath)
671 thenriksen 1.2 (needs-saving buffer) t))
672    
673     (defun check-file-times (buffer filepath question answer)
674     "Return NIL if filepath newer than buffer and user doesn't want
675     to overwrite."
676     (let ((f-w-d (file-write-date filepath))
677     (f-w-t (file-write-time buffer)))
678     (if (and f-w-d f-w-t (> f-w-d f-w-t))
679     (if (accept 'boolean
680     :prompt (format nil "File has changed on disk. ~a anyway?"
681     question))
682     t
683     (progn (display-message "~a not ~a" filepath answer)
684     nil))
685     t)))
686    
687     (defmethod frame-exit :around ((frame climacs) #-mcclim &key)
688     (loop for buffer in (buffers frame)
689     when (and (needs-saving buffer)
690     (filepath buffer)
691     (handler-case (accept 'boolean
692     :prompt (format nil "Save buffer: ~a ?" (name buffer)))
693     (error () (progn (beep)
694     (display-message "Invalid answer")
695     (return-from frame-exit nil)))))
696     do (save-buffer buffer))
697     (when (or (notany #'(lambda (buffer) (and (needs-saving buffer) (filepath buffer)))
698     (buffers frame))
699     (handler-case (accept 'boolean :prompt "Modified buffers exist. Quit anyway?")
700     (error () (progn (beep)
701     (display-message "Invalid answer")
702     (return-from frame-exit nil)))))
703     (call-next-method)))

  ViewVC Help
Powered by ViewVC 1.1.5