core.lisp 16.1 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
;;; -*- Mode: Lisp; Package: CLIMACS-CORE -*-

;;;  (c) copyright 2004-2005 by
;;;           Robert Strandh (strandh@labri.fr)
;;;  (c) copyright 2004-2005 by
;;;           Elliott Johnson (ejohnson@fasl.info)
;;;  (c) copyright 2005 by
;;;           Matthieu Villeneuve (matthieu.villeneuve@free.fr)
;;;  (c) copyright 2005 by
;;;           Aleksandar Bakic (a_bakic@yahoo.com)
;;;  (c) copyright 2006 by
;;;           Troels Henriksen (athas@sigkill.dk)

(in-package :climacs-core)

16 17 18 19
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Buffer handling

20 21
(defmethod frame-make-new-buffer ((application-frame climacs)
                                  &key (name "*scratch*"))
22 23 24 25 26
  (make-instance 'climacs-buffer :name name))

(define-presentation-method present ((object drei-view) (type view)
                                     stream (view textual-view)
                                     &key acceptably for-context-type)
27
  (declare (ignore acceptably for-context-type))
28
  (princ (subscripted-name object) stream))
29

30 31 32
(define-presentation-method accept ((type view) stream (view textual-view)
                                    &key (default nil defaultp)
                                    (default-type type))
33 34 35 36
  (multiple-value-bind (object success string)
      (complete-input stream
		      (lambda (so-far action)
			(complete-from-possibilities
37 38 39
			 so-far (views *esa-instance*) '()
                         :action action
			 :name-key #'subscripted-name
40 41 42
			 :value-key #'identity))
		      :partial-completers '(#\Space)
		      :allow-any-input t)
43 44 45 46
    (cond ((and success (plusp (length string)))
           (if object
               (values object type)
               (values string 'string)))
47
	  ((and (zerop (length string)) defaultp)
48 49 50 51
           (values default default-type))
	  (t
           (values string 'string)))))

52 53 54
(defgeneric switch-to-view (drei view)
  (:documentation "High-level function for changing the view
displayed by a Drei instance."))
55

56 57
(defmethod switch-to-view ((drei climacs-pane) (view drei-view))
  (setf (view drei) view))
58

59 60 61 62 63 64 65 66
(defmethod switch-to-view (pane (name string))
  (let ((view (find name (views (pane-frame pane))
               :key #'subscripted-name :test #'string=)))
    (switch-to-view
     pane (or view (make-new-view-for-climacs
                    (pane-frame pane) 'textual-drei-syntax-view
                    :name name)))))

67 68 69 70 71 72 73 74 75
(defun switch-or-move-to-view (pane view)
  "Switch `pane' to show `view'. If `view' is already on display
in some other pane, switch that pane to be the active one."
  (handler-bind ((view-already-displayed
                  #'(lambda (c)
                      (declare (ignore c))
                      (invoke-restart 'switch-to-pane))))
    (switch-to-view pane view)))

76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91
(defun views-having-buffer (climacs buffer)
  "Return a list of the buffer-views of `climacs' showing
`buffer'."
  (loop for view in (views climacs)
     when (and (typep view 'drei-buffer-view)
               (eq (buffer view) buffer))
     collect view))

(defun buffer-of-view-needs-saving (view)
  "Return true if `view' is a `drei-buffer-view' and it needs to
be saved (that is, it is related to a file and it has changed
since it was last saved)."
  (and (typep view 'drei-buffer-view)
       (filepath (buffer view))
       (needs-saving (buffer view))))

92 93 94 95 96
(defun dummy-buffer ()
  "Create a dummy buffer object for use when killing views, to
prevent increasing memory usage."
  (make-instance 'drei-buffer))

97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115
(defgeneric kill-view (view)
  (:documentation "Remove `view' from the Climacs specified in
`*esa-instance*'. If `view' is currently displayed in a window,
it will be replaced by some other view."))

(defmethod kill-view ((view view))
  (with-accessors ((views views)) *esa-instance*
    ;; It might be the case that this view is the only view remaining
    ;; of some particular buffer, in that case, the user might want to
    ;; save it.
    (when (and (buffer-of-view-needs-saving view)
               (= (length (views-having-buffer *esa-instance* (buffer view)))
                  1)
               (handler-case (accept 'boolean :prompt "Save buffer first?")
                 (error () (progn (beep)
                                  (display-message "Invalid answer")
                                  (return-from kill-view nil)))))
      (save-buffer (buffer view)))
    (setf views (remove view views))
116 117 118 119
    ;; If we don't change the buffer of the view, a reference to the
    ;; view will be kept in the buffer, and the view will thus not be
    ;; garbage-collected. So create a circular reference structure
    ;; that can be garbage-collected instead.
120 121
    (when (buffer-view-p view)
      (setf (buffer view) (dummy-buffer)))
122 123 124 125 126 127 128 129 130 131
    (full-redisplay (current-window))
    (current-view)))

(defmethod kill-view ((name string))
  (let ((view (find name (views *application-frame*)
                 :key #'subscripted-name :test #'string=)))
    (when view (kill-view view))))

(defmethod kill-view ((symbol null))
  (kill-view (current-view)))
132 133 134 135 136 137 138 139 140 141 142 143

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; File handling

(defun filepath-filename (pathname)
  (if (null (pathname-type pathname))
      (pathname-name pathname)
      (concatenate 'string (pathname-name pathname)
		   "." (pathname-type pathname))))

(defun syntax-class-name-for-filepath (filepath)
144 145 146 147 148 149 150 151 152 153 154
  (let ((syntax-description
         (find (or (pathname-type filepath)
                   (pathname-name filepath))
               drei-syntax::*syntaxes*
               :test (lambda (x y)
                       (member x y :test #'string-equal))
               :key #'drei-syntax::syntax-description-pathname-types)))
    (if syntax-description
        (drei-syntax::syntax-description-class-name
         syntax-description)
        *default-syntax*)))
155

156 157 158 159
(defun evaluate-attributes (view options)
  "Evaluate the attributes `options' and modify `view' as
appropriate. `Options' should be an alist mapping option names to
their values."
160 161 162 163 164 165 166 167 168 169 170
  ;; First, check whether we need to change the syntax (via the SYNTAX
  ;; option). MODE is an alias for SYNTAX for compatibility with
  ;; Emacs. If there is more than one option with one of these names,
  ;; only the first will be acted upon.
  (let ((specified-syntax
         (syntax-from-name
          (second (find-if #'(lambda (name)
                               (or (string-equal name "SYNTAX")
                                   (string-equal name "MODE")))
                           options
                           :key #'first)))))
171
    (when (and specified-syntax
172
               (not (eq (class-of (syntax view))
173
                        specified-syntax)))
174 175
      (setf (syntax view)
            (make-syntax-for-view view specified-syntax))))
176 177 178 179 180
  ;; Now we iterate through the options (discarding SYNTAX and MODE
  ;; options).
  (loop for (name value) in options
     unless (or (string-equal name "SYNTAX")
                (string-equal name "MODE"))
181
     do (eval-option (syntax view) name value)))
182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197

(defun split-attribute (string char)
  (let (pairs)
    (loop with start = 0
	  for ch across string
	  for i from 0
	  when (eql ch char)
	    do (push (string-trim '(#\Space #\Tab) (subseq string start i))
		     pairs)
	       (setf start (1+ i))
	  finally (unless (>= start i)
		    (push (string-trim '(#\Space #\Tab) (subseq string start))
			  pairs)))
    (nreverse pairs)))

(defun split-attribute-line (line)
198 199 200
  (when line
    (mapcar (lambda (pair) (split-attribute pair #\:))
	    (split-attribute line #\;))))
201

202
(defun find-attribute-line-position (buffer)
203
  (let ((scan (make-buffer-mark buffer 0)))
204 205
    ;; skip the leading whitespace
    (loop until (end-of-buffer-p scan)
206
       until (not (buffer-whitespacep (object-after scan)))
207
       do (forward-object scan))
208 209 210 211
    ;; stop looking if we're already 1,000 objects into the buffer
    (unless (> (offset scan) 1000)
      (let ((start-found
	     (loop with newlines = 0
212 213 214 215 216 217 218 219 220
                when (end-of-buffer-p scan)
                do (return nil)
                when (eql (object-after scan) #\Newline)
                do (incf newlines)
                when (> newlines 1)
                do (return nil)
                until (looking-at scan "-*-")
                do (forward-object scan)
                finally (return t))))
221
	(when start-found
222 223 224 225 226 227 228 229 230 231 232 233 234 235 236
          (let* ((end-scan (clone-mark scan))
                 (end-found
                  (loop when (end-of-buffer-p end-scan)
                     do (return nil)
                     when (eql (object-after end-scan) #\Newline)
                     do (return nil)
                     do (forward-object end-scan)
                     until (looking-at end-scan "-*-")
                     finally (return t))))
            (when end-found
              (values scan
                      (progn (forward-object end-scan 3)
                             end-scan)))))))))

(defun get-attribute-line (buffer)
237 238 239 240 241 242 243 244 245 246
  (multiple-value-bind (start-mark end-mark)
      (find-attribute-line-position buffer)
   (when (and start-mark end-mark)
     (let ((line (buffer-substring buffer
				   (offset start-mark)
				   (offset end-mark))))
       (when (>= (length line) 6)
	 (let ((end (search "-*-" line :from-end t :start2 3)))
	   (when end
	     (string-trim '(#\Space #\Tab) (subseq line 3 end)))))))))
247

248
(defun replace-attribute-line (view new-attribute-line)
249 250 251 252
  (let ((full-attribute-line (concatenate 'string
                                          "-*- "
                                          new-attribute-line
                                          "-*-")))
253
   (multiple-value-bind (start-mark end-mark)
254
       (find-attribute-line-position (buffer view))
255 256 257 258 259
     (cond ((not (null end-mark))
            ;; We have an existing attribute line.
            (delete-region start-mark end-mark)
            (let ((new-line-start (clone-mark start-mark :left)))
              (insert-sequence start-mark full-attribute-line)
260
              (comment-region (syntax view)
261 262 263 264
                              new-line-start
                              start-mark)))
           (t
            ;; Create a new attribute line at beginning of buffer.
265
            (let* ((mark1 (make-buffer-mark (buffer view) 0 :left))
266 267 268
                   (mark2 (clone-mark mark1 :right)))
              (insert-sequence mark2 full-attribute-line)
              (insert-object mark2 #\Newline)
269
              (comment-region (syntax view)
270 271 272
                              mark1
                              mark2)))))))

273 274 275
(defun update-attribute-line (view)
  (replace-attribute-line
   view (make-attribute-line (syntax view))))
276

277
(defun evaluate-attribute-line (view)
278
  (evaluate-attributes
279
   view (split-attribute-line (get-attribute-line (buffer view)))))
280 281 282 283 284 285 286 287 288

;; Adapted from cl-fad/PCL
(defun directory-pathname-p (pathspec)
  "Returns NIL if PATHSPEC does not designate a directory."
  (let ((name (pathname-name pathspec))
	(type (pathname-type pathspec)))
    (and (or (null name) (eql name :unspecific))
	 (or (null type) (eql type :unspecific)))))

289 290 291 292 293 294
(defun findablep (pathname)
  "Return non-NIL if `pathname' can be opened by Climacs. That
  is, check whether the file exists and is not a directory."
  (and (probe-file pathname)
       (not (directory-pathname-p pathname))))

295 296 297
(defun find-view-with-pathname (pathname)
  "Return the (first) with associated with the file designated by
`pathname'. Returns NIL if no buffer can be found."
298 299 300 301
  (flet ((usable-pathname (pathname)
           (if (probe-file pathname)
               (truename pathname)
               pathname)))
302 303 304 305 306 307 308 309
    (find pathname (remove-if-not #'(lambda (view)
                                      (typep view 'drei-buffer-view))
                                  (views *application-frame*))
     :key #'(lambda (view) (filepath (buffer view)))
     :test #'(lambda (fp1 fp2)
               (and fp1 fp2
                    (equal (usable-pathname fp1)
                           (usable-pathname fp2)))))))
310 311 312 313 314 315

(defun ensure-open-file (pathname)
  "Make sure a buffer opened on `pathname' exists, finding the
file if necessary."
  (when (and (findablep pathname)
             (not (find-buffer-with-pathname pathname)))
316
    (find-file pathname)))
317

318
(defun find-file-impl (filepath &optional readonlyp)
319 320 321 322 323 324 325
  (cond ((null filepath)
	 (display-message "No file name given.")
	 (beep))
	((directory-pathname-p filepath)
	 (display-message "~A is a directory name." filepath)
	 (beep))
        (t
326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353
         (let ((existing-view (find-view-with-pathname filepath)))
           (if (and existing-view (if readonlyp (read-only-p (buffer existing-view)) t))
               (switch-to-view (current-window) existing-view)
               (let* ((newp (not (probe-file filepath)))
                      (buffer (if (and newp (not readonlyp))
                                  (make-new-buffer)
                                  (with-open-file (stream filepath :direction :input)
                                    (make-buffer-from-stream stream))))
                      (view (make-new-view-for-climacs
                             *esa-instance* 'textual-drei-syntax-view
                             :name (filepath-filename filepath)
                             :buffer buffer)))
                 (unless (buffer-pane-p (current-window))
                   (other-window (or (find-if #'(lambda (window)
                                                  (typep window 'climacs-pane))
                                              (windows *esa-instance*))
                                     (split-window t))))
                 (setf (offset (point buffer)) (offset (point view))
                       (syntax view) (make-syntax-for-view view (syntax-class-name-for-filepath filepath))
                       (file-write-time buffer) (if newp (get-universal-time) (file-write-date filepath))
                       (needs-saving buffer) nil
                       (name buffer) (filepath-filename filepath))
                 (setf (current-view (current-window)) view)
                 (evaluate-attribute-line view)
                 (setf (filepath buffer) (pathname filepath)
                       (read-only-p buffer) readonlyp)
                 (beginning-of-buffer (point view))
                 buffer))))))
354

355
(defmethod frame-find-file ((application-frame climacs) filepath)
356 357
  (find-file-impl filepath nil))

358
(defmethod frame-find-file-read-only ((application-frame climacs) filepath)
359 360
  (find-file-impl filepath t))

361 362
(defun directory-of-buffer (buffer)
  "Extract the directory part of the filepath to the file in BUFFER.
363 364
If BUFFER does not have a filepath, the path to the user's home
directory will be returned."
365 366 367 368 369 370
  (make-pathname
   :directory
   (pathname-directory
    (or (filepath buffer)
	(user-homedir-pathname)))))

371
(defmethod frame-set-visited-filename ((application-frame climacs) filepath buffer)
372
  (setf (filepath buffer) (pathname filepath)
373 374
	(file-saved-p buffer) nil
	(file-write-time buffer) nil
375
	(name buffer) (filepath-filename filepath)
376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392
	(needs-saving buffer) t))

(defun check-file-times (buffer filepath question answer)
  "Return NIL if filepath newer than buffer and user doesn't want
to overwrite."
  (let ((f-w-d (file-write-date filepath))
	(f-w-t (file-write-time buffer)))
    (if (and f-w-d f-w-t (> f-w-d f-w-t))
	(if (accept 'boolean
		    :prompt (format nil "File has changed on disk. ~a anyway?"
				    question))
	    t
	    (progn (display-message "~a not ~a" filepath answer)
		   nil))
	t)))

(defmethod frame-exit :around ((frame climacs) #-mcclim &key)
393
  (dolist (view (views frame))
394 395 396 397 398 399 400 401 402 403 404
    (handler-case
        (when (and (buffer-of-view-needs-saving view)
                   (handler-case (accept 'boolean
                                  :prompt (format nil "Save buffer of view: ~a ?" (name view)))
                     (error () (progn (beep)
                                      (display-message "Invalid answer")
                                      (return-from frame-exit nil)))))
          (save-buffer (buffer view)))
      (file-error (e)
        (display-message "~A (hit a key to continue)" e)
        (read-gesture))))
405 406
  (when (or (notany #'buffer-of-view-needs-saving (views frame))
	    (handler-case (accept 'boolean :prompt "Modified buffers of views exist.  Quit anyway?")
407 408 409
	      (error () (progn (beep)
			       (display-message "Invalid answer")
			       (return-from frame-exit nil)))))
410
    (call-next-method)))