| 1 | ;;; -*- Log: hemlock.log; Package: Hemlock -*-
|
|---|
| 2 | ;;;
|
|---|
| 3 | ;;; **********************************************************************
|
|---|
| 4 | ;;; This code was written as part of the CMU Common Lisp project at
|
|---|
| 5 | ;;; Carnegie Mellon University, and has been placed in the public domain.
|
|---|
| 6 | ;;;
|
|---|
| 7 | #+CMU (ext:file-comment
|
|---|
| 8 | "$Header$")
|
|---|
| 9 | ;;;
|
|---|
| 10 | ;;; **********************************************************************
|
|---|
| 11 | ;;;
|
|---|
| 12 | ;;; Simple directory editing support.
|
|---|
| 13 | ;;; This file contains site dependent calls.
|
|---|
| 14 | ;;;
|
|---|
| 15 | ;;; Written by Blaine Burks and Bill Chiles.
|
|---|
| 16 | ;;;
|
|---|
| 17 |
|
|---|
| 18 | (in-package :hemlock)
|
|---|
| 19 |
|
|---|
| 20 |
|
|---|
| 21 | (defmode "Dired" :major-p t
|
|---|
| 22 | :documentation
|
|---|
| 23 | "Dired permits convenient directory browsing and file operations including
|
|---|
| 24 | viewing, deleting, copying, renaming, and wildcard specifications.")
|
|---|
| 25 |
|
|---|
| 26 |
|
|---|
| 27 | (defstruct (dired-information (:print-function print-dired-information)
|
|---|
| 28 | (:conc-name dired-info-))
|
|---|
| 29 | pathname ; Pathname of directory.
|
|---|
| 30 | pattern ; FILE-NAMESTRING with wildcard possibly.
|
|---|
| 31 | dot-files-p ; Whether to include UNIX dot files.
|
|---|
| 32 | write-date ; Write date of directory.
|
|---|
| 33 | files ; Simple-vector of dired-file structures.
|
|---|
| 34 | file-list) ; List of pathnames for files, excluding directories.
|
|---|
| 35 |
|
|---|
| 36 | (defun print-dired-information (obj str n)
|
|---|
| 37 | (declare (ignore n))
|
|---|
| 38 | (format str "#<Dired Info ~S>" (namestring (dired-info-pathname obj))))
|
|---|
| 39 |
|
|---|
| 40 |
|
|---|
| 41 | (defstruct (dired-file (:print-function print-dired-file)
|
|---|
| 42 | (:constructor make-dired-file (pathname)))
|
|---|
| 43 | pathname
|
|---|
| 44 | (deleted-p nil)
|
|---|
| 45 | (write-date nil))
|
|---|
| 46 |
|
|---|
| 47 | (defun print-dired-file (obj str n)
|
|---|
| 48 | (declare (ignore n))
|
|---|
| 49 | (format str "#<Dired-file ~A>" (namestring (dired-file-pathname obj))))
|
|---|
| 50 |
|
|---|
| 51 |
|
|---|
| 52 | |
|---|
| 53 |
|
|---|
| 54 | ;;;; "Dired" command.
|
|---|
| 55 |
|
|---|
| 56 | ;;; *pathnames-to-dired-buffers* is an a-list mapping directory namestrings to
|
|---|
| 57 | ;;; buffers that display their contents.
|
|---|
| 58 | ;;;
|
|---|
| 59 | (defvar *pathnames-to-dired-buffers* ())
|
|---|
| 60 |
|
|---|
| 61 | (make-modeline-field
|
|---|
| 62 | :name :dired-cmds :width 20
|
|---|
| 63 | :function
|
|---|
| 64 | #'(lambda (buffer window)
|
|---|
| 65 | (declare (ignore buffer window))
|
|---|
| 66 | " Type ? for help. "))
|
|---|
| 67 |
|
|---|
| 68 | (defcommand "Dired" (p &optional directory)
|
|---|
| 69 | "Prompts for a directory and edits it. If a dired for that directory already
|
|---|
| 70 | exists, go to that buffer, otherwise create one. With an argument, include
|
|---|
| 71 | UNIX dot files."
|
|---|
| 72 | "Prompts for a directory and edits it. If a dired for that directory already
|
|---|
| 73 | exists, go to that buffer, otherwise create one. With an argument, include
|
|---|
| 74 | UNIX dot files."
|
|---|
| 75 | (let ((info (if (hemlock-bound-p 'dired-information)
|
|---|
| 76 | (value dired-information))))
|
|---|
| 77 | (dired-guts nil
|
|---|
| 78 | ;; Propagate dot-files property to subdirectory edits.
|
|---|
| 79 | (or (and info (dired-info-dot-files-p info))
|
|---|
| 80 | p)
|
|---|
| 81 | directory)))
|
|---|
| 82 |
|
|---|
| 83 | (defcommand "Dired with Pattern" (p)
|
|---|
| 84 | "Do a dired, prompting for a pattern which may include a single *. With an
|
|---|
| 85 | argument, include UNIX dit files."
|
|---|
| 86 | "Do a dired, prompting for a pattern which may include a single *. With an
|
|---|
| 87 | argument, include UNIX dit files."
|
|---|
| 88 | (dired-guts t p nil))
|
|---|
| 89 |
|
|---|
| 90 | (defun dired-guts (patternp dot-files-p directory)
|
|---|
| 91 | (let* ((dpn (value pathname-defaults))
|
|---|
| 92 | (directory (dired-directorify
|
|---|
| 93 | (or directory
|
|---|
| 94 | (prompt-for-file
|
|---|
| 95 | :prompt "Edit Directory: "
|
|---|
| 96 | :help "Pathname to edit."
|
|---|
| 97 | :default (make-pathname
|
|---|
| 98 | :device (pathname-device dpn)
|
|---|
| 99 | :directory (pathname-directory dpn))
|
|---|
| 100 | :must-exist nil))))
|
|---|
| 101 | (pattern (if patternp
|
|---|
| 102 | (prompt-for-string
|
|---|
| 103 | :prompt "Filename pattern: "
|
|---|
| 104 | :help "Type a filename with a single asterisk."
|
|---|
| 105 | :trim t)))
|
|---|
| 106 | (full-name (namestring (if pattern
|
|---|
| 107 | (merge-pathnames directory pattern)
|
|---|
| 108 | directory)))
|
|---|
| 109 | (name (concatenate 'simple-string "Dired " full-name))
|
|---|
| 110 | (buffer (cdr (assoc full-name *pathnames-to-dired-buffers*
|
|---|
| 111 | :test #'string=))))
|
|---|
| 112 | (declare (simple-string full-name))
|
|---|
| 113 | (setf (value pathname-defaults) (merge-pathnames directory dpn))
|
|---|
| 114 | (change-to-buffer
|
|---|
| 115 | (cond (buffer
|
|---|
| 116 | (when (and dot-files-p
|
|---|
| 117 | (not (dired-info-dot-files-p
|
|---|
| 118 | (variable-value 'dired-information
|
|---|
| 119 | :buffer buffer))))
|
|---|
| 120 | (setf (dired-info-dot-files-p (variable-value 'dired-information
|
|---|
| 121 | :buffer buffer))
|
|---|
| 122 | t)
|
|---|
| 123 | (update-dired-buffer directory pattern buffer))
|
|---|
| 124 | buffer)
|
|---|
| 125 | (t
|
|---|
| 126 | (let ((buffer (make-buffer
|
|---|
| 127 | name :modes '("Dired")
|
|---|
| 128 | :modeline-fields
|
|---|
| 129 | (append (value default-modeline-fields)
|
|---|
| 130 | (list (modeline-field :dired-cmds)))
|
|---|
| 131 | :delete-hook (list 'dired-buffer-delete-hook))))
|
|---|
| 132 | (unless (initialize-dired-buffer directory pattern
|
|---|
| 133 | dot-files-p buffer)
|
|---|
| 134 | (delete-buffer-if-possible buffer)
|
|---|
| 135 | (editor-error "No entries for ~A." full-name))
|
|---|
| 136 | (push (cons full-name buffer) *pathnames-to-dired-buffers*)
|
|---|
| 137 | buffer))))))
|
|---|
| 138 |
|
|---|
| 139 | ;;; INITIALIZE-DIRED-BUFFER gets a dired in the buffer and defines some
|
|---|
| 140 | ;;; variables to make it usable as a dired buffer. If there are no file
|
|---|
| 141 | ;;; satisfying directory, then this returns nil, otherwise t.
|
|---|
| 142 | ;;;
|
|---|
| 143 | (defun initialize-dired-buffer (directory pattern dot-files-p buffer)
|
|---|
| 144 | (multiple-value-bind (pathnames dired-files)
|
|---|
| 145 | (dired-in-buffer directory pattern dot-files-p buffer)
|
|---|
| 146 | (if (zerop (length dired-files))
|
|---|
| 147 | nil
|
|---|
| 148 | (defhvar "Dired Information"
|
|---|
| 149 | "Contains the information neccessary to manipulate dired buffers."
|
|---|
| 150 | :buffer buffer
|
|---|
| 151 | :value (make-dired-information :pathname directory
|
|---|
| 152 | :pattern pattern
|
|---|
| 153 | :dot-files-p dot-files-p
|
|---|
| 154 | :write-date (file-write-date directory)
|
|---|
| 155 | :files dired-files
|
|---|
| 156 | :file-list pathnames)))))
|
|---|
| 157 |
|
|---|
| 158 | ;;; CALL-PRINT-DIRECTORY gives us a nice way to report PRINT-DIRECTORY errors
|
|---|
| 159 | ;;; to the user and to clean up the dired buffer.
|
|---|
| 160 | ;;;
|
|---|
| 161 | (defun call-print-directory (directory mark dot-files-p)
|
|---|
| 162 | (handler-case (with-output-to-mark (s mark :full)
|
|---|
| 163 | (print-directory directory s
|
|---|
| 164 | :all dot-files-p :verbose t :return-list t))
|
|---|
| 165 | (error (condx)
|
|---|
| 166 | (delete-buffer-if-possible (line-buffer (mark-line mark)))
|
|---|
| 167 | (editor-error "~A" condx))))
|
|---|
| 168 |
|
|---|
| 169 | ;;; DIRED-BUFFER-DELETE-HOOK is called on dired buffers upon deletion. This
|
|---|
| 170 | ;;; removes the buffer from the pathnames mapping, and it deletes and buffer
|
|---|
| 171 | ;;; local variables referring to it.
|
|---|
| 172 | ;;;
|
|---|
| 173 | (defun dired-buffer-delete-hook (buffer)
|
|---|
| 174 | (setf *pathnames-to-dired-buffers*
|
|---|
| 175 | (delete buffer *pathnames-to-dired-buffers* :test #'eq :key #'cdr)))
|
|---|
| 176 |
|
|---|
| 177 |
|
|---|
| 178 | |
|---|
| 179 |
|
|---|
| 180 | ;;;; Dired deletion and undeletion.
|
|---|
| 181 |
|
|---|
| 182 | (defcommand "Dired Delete File" (p)
|
|---|
| 183 | "Marks a file for deletion; signals an error if not in a dired buffer.
|
|---|
| 184 | With an argument, this prompts for a pattern that may contain at most one
|
|---|
| 185 | wildcard, an asterisk, and all names matching the pattern will be flagged
|
|---|
| 186 | for deletion."
|
|---|
| 187 | "Marks a file for deletion; signals an error if not in a dired buffer."
|
|---|
| 188 | (dired-frob-deletion p t))
|
|---|
| 189 |
|
|---|
| 190 | (defcommand "Dired Undelete File" (p)
|
|---|
| 191 | "Removes a mark for deletion; signals and error if not in a dired buffer.
|
|---|
| 192 | With an argument, this prompts for a pattern that may contain at most one
|
|---|
| 193 | wildcard, an asterisk, and all names matching the pattern will be unflagged
|
|---|
| 194 | for deletion."
|
|---|
| 195 | "Removes a mark for deletion; signals and error if not in a dired buffer."
|
|---|
| 196 | (dired-frob-deletion p nil))
|
|---|
| 197 |
|
|---|
| 198 | (defcommand "Dired Delete File and Down Line" (p)
|
|---|
| 199 | "Marks file for deletion and moves down a line.
|
|---|
| 200 | See \"Dired Delete File\"."
|
|---|
| 201 | "Marks file for deletion and moves down a line.
|
|---|
| 202 | See \"Dired Delete File\"."
|
|---|
| 203 | (declare (ignore p))
|
|---|
| 204 | (dired-frob-deletion nil t)
|
|---|
| 205 | (dired-down-line (current-point)))
|
|---|
| 206 |
|
|---|
| 207 | (defcommand "Dired Undelete File and Down Line" (p)
|
|---|
| 208 | "Marks file undeleted and moves down a line.
|
|---|
| 209 | See \"Dired Delete File\"."
|
|---|
| 210 | "Marks file undeleted and moves down a line.
|
|---|
| 211 | See \"Dired Delete File\"."
|
|---|
| 212 | (declare (ignore p))
|
|---|
| 213 | (dired-frob-deletion nil nil)
|
|---|
| 214 | (dired-down-line (current-point)))
|
|---|
| 215 |
|
|---|
| 216 | (defcommand "Dired Delete File with Pattern" (p)
|
|---|
| 217 | "Prompts for a pattern and marks matching files for deletion.
|
|---|
| 218 | See \"Dired Delete File\"."
|
|---|
| 219 | "Prompts for a pattern and marks matching files for deletion.
|
|---|
| 220 | See \"Dired Delete File\"."
|
|---|
| 221 | (declare (ignore p))
|
|---|
| 222 | (dired-frob-deletion t t)
|
|---|
| 223 | (dired-down-line (current-point)))
|
|---|
| 224 |
|
|---|
| 225 | (defcommand "Dired Undelete File with Pattern" (p)
|
|---|
| 226 | "Prompts for a pattern and marks matching files undeleted.
|
|---|
| 227 | See \"Dired Delete File\"."
|
|---|
| 228 | "Prompts for a pattern and marks matching files undeleted.
|
|---|
| 229 | See \"Dired Delete File\"."
|
|---|
| 230 | (declare (ignore p))
|
|---|
| 231 | (dired-frob-deletion t nil)
|
|---|
| 232 | (dired-down-line (current-point)))
|
|---|
| 233 |
|
|---|
| 234 | ;;; DIRED-FROB-DELETION takes arguments indicating whether to prompt for a
|
|---|
| 235 | ;;; pattern and whether to mark the file deleted or undeleted. This uses
|
|---|
| 236 | ;;; CURRENT-POINT and CURRENT-BUFFER, and if not in a dired buffer, signal
|
|---|
| 237 | ;;; an error.
|
|---|
| 238 | ;;;
|
|---|
| 239 | (defun dired-frob-deletion (patternp deletep)
|
|---|
| 240 | (unless (hemlock-bound-p 'dired-information)
|
|---|
| 241 | (editor-error "Not in Dired buffer."))
|
|---|
| 242 | (with-mark ((mark (current-point) :left-inserting))
|
|---|
| 243 | (let* ((dir-info (value dired-information))
|
|---|
| 244 | (files (dired-info-files dir-info))
|
|---|
| 245 | (del-files
|
|---|
| 246 | (if patternp
|
|---|
| 247 | (dired:pathnames-from-pattern
|
|---|
| 248 | (prompt-for-string
|
|---|
| 249 | :prompt "Filename pattern: "
|
|---|
| 250 | :help "Type a filename with a single asterisk."
|
|---|
| 251 | :trim t)
|
|---|
| 252 | (dired-info-file-list dir-info))
|
|---|
| 253 | (list (dired-file-pathname
|
|---|
| 254 | (array-element-from-mark mark files)))))
|
|---|
| 255 | (note-char (if deletep #\D #\space)))
|
|---|
| 256 | (with-writable-buffer ((current-buffer))
|
|---|
| 257 | (dolist (f del-files)
|
|---|
| 258 | (let* ((pos (position f files :test #'equal
|
|---|
| 259 | :key #'dired-file-pathname))
|
|---|
| 260 | (dired-file (svref files pos)))
|
|---|
| 261 | (buffer-start mark)
|
|---|
| 262 | (line-offset mark pos 0)
|
|---|
| 263 | (setf (dired-file-deleted-p dired-file) deletep)
|
|---|
| 264 | (if deletep
|
|---|
| 265 | (setf (dired-file-write-date dired-file)
|
|---|
| 266 | (file-write-date (dired-file-pathname dired-file)))
|
|---|
| 267 | (setf (dired-file-write-date dired-file) nil))
|
|---|
| 268 | (setf (next-character mark) note-char)))))))
|
|---|
| 269 |
|
|---|
| 270 | (defun dired-down-line (point)
|
|---|
| 271 | (line-offset point 1)
|
|---|
| 272 | (when (blank-line-p (mark-line point))
|
|---|
| 273 | (line-offset point -1)))
|
|---|
| 274 |
|
|---|
| 275 |
|
|---|
| 276 | |
|---|
| 277 |
|
|---|
| 278 | ;;;; Dired file finding and going to dired buffers.
|
|---|
| 279 |
|
|---|
| 280 | (defcommand "Dired Edit File" (p)
|
|---|
| 281 | "Read in file or recursively \"Dired\" a directory."
|
|---|
| 282 | "Read in file or recursively \"Dired\" a directory."
|
|---|
| 283 | (declare (ignore p))
|
|---|
| 284 | (let ((point (current-point)))
|
|---|
| 285 | (when (blank-line-p (mark-line point)) (editor-error "Not on a file line."))
|
|---|
| 286 | (let ((pathname (dired-file-pathname
|
|---|
| 287 | (array-element-from-mark
|
|---|
| 288 | point (dired-info-files (value dired-information))))))
|
|---|
| 289 | (if (directoryp pathname)
|
|---|
| 290 | (dired-command nil (directory-namestring pathname))
|
|---|
| 291 | (change-to-buffer (find-file-buffer pathname))))))
|
|---|
| 292 |
|
|---|
| 293 | (defcommand "Dired View File" (p)
|
|---|
| 294 | "Read in file as if by \"View File\" or recursively \"Dired\" a directory.
|
|---|
| 295 | This associates the file's buffer with the dired buffer."
|
|---|
| 296 | "Read in file as if by \"View File\".
|
|---|
| 297 | This associates the file's buffer with the dired buffer."
|
|---|
| 298 | (declare (ignore p))
|
|---|
| 299 | (let ((point (current-point)))
|
|---|
| 300 | (when (blank-line-p (mark-line point)) (editor-error "Not on a file line."))
|
|---|
| 301 | (let ((pathname (dired-file-pathname
|
|---|
| 302 | (array-element-from-mark
|
|---|
| 303 | point (dired-info-files (value dired-information))))))
|
|---|
| 304 | (if (directoryp pathname)
|
|---|
| 305 | (dired-command nil (directory-namestring pathname))
|
|---|
| 306 | (let* ((dired-buf (current-buffer))
|
|---|
| 307 | (buffer (view-file-command nil pathname)))
|
|---|
| 308 | (push #'(lambda (buffer)
|
|---|
| 309 | (declare (ignore buffer))
|
|---|
| 310 | (setf dired-buf nil))
|
|---|
| 311 | (buffer-delete-hook dired-buf))
|
|---|
| 312 | (setf (variable-value 'view-return-function :buffer buffer)
|
|---|
| 313 | #'(lambda ()
|
|---|
| 314 | (if dired-buf
|
|---|
| 315 | (change-to-buffer dired-buf)
|
|---|
| 316 | (dired-from-buffer-pathname-command nil)))))))))
|
|---|
| 317 |
|
|---|
| 318 | (defcommand "Dired from Buffer Pathname" (p)
|
|---|
| 319 | "Invokes \"Dired\" on the directory part of the current buffer's pathname.
|
|---|
| 320 | With an argument, also prompt for a file pattern within that directory."
|
|---|
| 321 | "Invokes \"Dired\" on the directory part of the current buffer's pathname.
|
|---|
| 322 | With an argument, also prompt for a file pattern within that directory."
|
|---|
| 323 | (let ((pathname (buffer-pathname (current-buffer))))
|
|---|
| 324 | (if pathname
|
|---|
| 325 | (dired-command p (directory-namestring pathname))
|
|---|
| 326 | (editor-error "No pathname associated with buffer."))))
|
|---|
| 327 |
|
|---|
| 328 | (defcommand "Dired Up Directory" (p)
|
|---|
| 329 | "Invokes \"Dired\" on the directory up one level from the current Dired
|
|---|
| 330 | buffer."
|
|---|
| 331 | "Invokes \"Dired\" on the directory up one level from the current Dired
|
|---|
| 332 | buffer."
|
|---|
| 333 | (declare (ignore p))
|
|---|
| 334 | (unless (hemlock-bound-p 'dired-information)
|
|---|
| 335 | (editor-error "Not in Dired buffer."))
|
|---|
| 336 | (let ((dirs (or (pathname-directory
|
|---|
| 337 | (dired-info-pathname (value dired-information)))
|
|---|
| 338 | '(:relative))))
|
|---|
| 339 | (dired-command nil
|
|---|
| 340 | (truename (make-pathname :directory (nconc dirs '(:UP)))))))
|
|---|
| 341 |
|
|---|
| 342 |
|
|---|
| 343 | |
|---|
| 344 |
|
|---|
| 345 | ;;;; Dired misc. commands -- update, help, line motion.
|
|---|
| 346 |
|
|---|
| 347 | (defcommand "Dired Update Buffer" (p)
|
|---|
| 348 | "Recompute the contents of a dired buffer.
|
|---|
| 349 | This maintains delete flags for files that have not been modified."
|
|---|
| 350 | "Recompute the contents of a dired buffer.
|
|---|
| 351 | This maintains delete flags for files that have not been modified."
|
|---|
| 352 | (declare (ignore p))
|
|---|
| 353 | (unless (hemlock-bound-p 'dired-information)
|
|---|
| 354 | (editor-error "Not in Dired buffer."))
|
|---|
| 355 | (let ((buffer (current-buffer))
|
|---|
| 356 | (dir-info (value dired-information)))
|
|---|
| 357 | (update-dired-buffer (dired-info-pathname dir-info)
|
|---|
| 358 | (dired-info-pattern dir-info)
|
|---|
| 359 | buffer)))
|
|---|
| 360 |
|
|---|
| 361 | ;;; UPDATE-DIRED-BUFFER updates buffer with a dired of directory, deleting
|
|---|
| 362 | ;;; whatever is in the buffer already. This assumes buffer was previously
|
|---|
| 363 | ;;; used as a dired buffer having necessary variables bound. The new files
|
|---|
| 364 | ;;; are compared to the old ones propagating any deleted flags if the name
|
|---|
| 365 | ;;; and the write date is the same for both specifications.
|
|---|
| 366 | ;;;
|
|---|
| 367 | (defun update-dired-buffer (directory pattern buffer)
|
|---|
| 368 | (with-writable-buffer (buffer)
|
|---|
| 369 | (delete-region (buffer-region buffer))
|
|---|
| 370 | (let ((dir-info (variable-value 'dired-information :buffer buffer)))
|
|---|
| 371 | (multiple-value-bind (pathnames new-dired-files)
|
|---|
| 372 | (dired-in-buffer directory pattern
|
|---|
| 373 | (dired-info-dot-files-p dir-info)
|
|---|
| 374 | buffer)
|
|---|
| 375 | (let ((point (buffer-point buffer))
|
|---|
| 376 | (old-dired-files (dired-info-files dir-info)))
|
|---|
| 377 | (declare (simple-vector old-dired-files))
|
|---|
| 378 | (dotimes (i (length old-dired-files))
|
|---|
| 379 | (let ((old-file (svref old-dired-files i)))
|
|---|
| 380 | (when (dired-file-deleted-p old-file)
|
|---|
| 381 | (let ((pos (position (dired-file-pathname old-file)
|
|---|
| 382 | new-dired-files :test #'equal
|
|---|
| 383 | :key #'dired-file-pathname)))
|
|---|
| 384 | (when pos
|
|---|
| 385 | (let* ((new-file (svref new-dired-files pos))
|
|---|
| 386 | (write-date (file-write-date
|
|---|
| 387 | (dired-file-pathname new-file))))
|
|---|
| 388 | (when (= (dired-file-write-date old-file) write-date)
|
|---|
| 389 | (setf (dired-file-deleted-p new-file) t)
|
|---|
| 390 | (setf (dired-file-write-date new-file) write-date)
|
|---|
| 391 | (setf (next-character
|
|---|
| 392 | (line-offset (buffer-start point) pos 0))
|
|---|
| 393 | #\D))))))))
|
|---|
| 394 | (setf (dired-info-files dir-info) new-dired-files)
|
|---|
| 395 | (setf (dired-info-file-list dir-info) pathnames)
|
|---|
| 396 | (setf (dired-info-write-date dir-info)
|
|---|
| 397 | (file-write-date directory))
|
|---|
| 398 | (move-mark point (buffer-start-mark buffer)))))))
|
|---|
| 399 |
|
|---|
| 400 | ;;; DIRED-IN-BUFFER inserts a dired listing of directory in buffer returning
|
|---|
| 401 | ;;; two values: a list of pathnames of files only, and an array of dired-file
|
|---|
| 402 | ;;; structures. This uses FILTER-REGION to insert a space for the indication
|
|---|
| 403 | ;;; of whether the file is flagged for deletion. Then we clean up extra header
|
|---|
| 404 | ;;; and trailing lines known to be in the output (into every code a little
|
|---|
| 405 | ;;; slime must fall).
|
|---|
| 406 | ;;;
|
|---|
| 407 | (defun dired-in-buffer (directory pattern dot-files-p buffer)
|
|---|
| 408 | (let ((point (buffer-point buffer)))
|
|---|
| 409 | (with-writable-buffer (buffer)
|
|---|
| 410 | (let* ((pathnames (call-print-directory
|
|---|
| 411 | (if pattern
|
|---|
| 412 | (merge-pathnames directory pattern)
|
|---|
| 413 | directory)
|
|---|
| 414 | point
|
|---|
| 415 | dot-files-p))
|
|---|
| 416 | (dired-files (make-array (length pathnames))))
|
|---|
| 417 | (declare (list pathnames) (simple-vector dired-files))
|
|---|
| 418 | (filter-region #'(lambda (str)
|
|---|
| 419 | (concatenate 'simple-string " " str))
|
|---|
| 420 | (buffer-region buffer))
|
|---|
| 421 | (delete-characters point -2)
|
|---|
| 422 | (delete-region (line-to-region (mark-line (buffer-start point))))
|
|---|
| 423 | (delete-characters point)
|
|---|
| 424 | (do ((p pathnames (cdr p))
|
|---|
| 425 | (i 0 (1+ i)))
|
|---|
| 426 | ((null p))
|
|---|
| 427 | (setf (svref dired-files i) (make-dired-file (car p))))
|
|---|
| 428 | (values (delete-if #'directoryp pathnames) dired-files)))))
|
|---|
| 429 |
|
|---|
| 430 |
|
|---|
| 431 | (defcommand "Dired Help" (p)
|
|---|
| 432 | "How to use dired."
|
|---|
| 433 | "How to use dired."
|
|---|
| 434 | (declare (ignore p))
|
|---|
| 435 | (describe-mode-command nil "Dired"))
|
|---|
| 436 |
|
|---|
| 437 | (defcommand "Dired Next File" (p)
|
|---|
| 438 | "Moves to next undeleted file."
|
|---|
| 439 | "Moves to next undeleted file."
|
|---|
| 440 | (unless (dired-line-offset (current-point) (or p 1))
|
|---|
| 441 | (editor-error "Not enough lines.")))
|
|---|
| 442 |
|
|---|
| 443 | (defcommand "Dired Previous File" (p)
|
|---|
| 444 | "Moves to previous undeleted file."
|
|---|
| 445 | "Moves to next undeleted file."
|
|---|
| 446 | (unless (dired-line-offset (current-point) (or p -1))
|
|---|
| 447 | (editor-error "Not enough lines.")))
|
|---|
| 448 |
|
|---|
| 449 | ;;; DIRED-LINE-OFFSET moves mark n undeleted file lines, returning mark. If
|
|---|
| 450 | ;;; there are not enough lines, mark remains unmoved, this returns nil.
|
|---|
| 451 | ;;;
|
|---|
| 452 | (defun dired-line-offset (mark n)
|
|---|
| 453 | (with-mark ((m mark))
|
|---|
| 454 | (let ((step (if (plusp n) 1 -1)))
|
|---|
| 455 | (dotimes (i (abs n) (move-mark mark m))
|
|---|
| 456 | (loop
|
|---|
| 457 | (unless (line-offset m step 0)
|
|---|
| 458 | (return-from dired-line-offset nil))
|
|---|
| 459 | (when (blank-line-p (mark-line m))
|
|---|
| 460 | (return-from dired-line-offset nil))
|
|---|
| 461 | (when (char= (next-character m) #\space)
|
|---|
| 462 | (return)))))))
|
|---|
| 463 |
|
|---|
| 464 |
|
|---|
| 465 | |
|---|
| 466 |
|
|---|
| 467 | ;;;; Dired user interaction functions.
|
|---|
| 468 |
|
|---|
| 469 | (defun dired-error-function (string &rest args)
|
|---|
| 470 | (apply #'editor-error string args))
|
|---|
| 471 |
|
|---|
| 472 | (defun dired-report-function (string &rest args)
|
|---|
| 473 | (clear-echo-area)
|
|---|
| 474 | (apply #'message string args))
|
|---|
| 475 |
|
|---|
| 476 | (defun dired-yesp-function (string &rest args)
|
|---|
| 477 | (prompt-for-y-or-n :prompt (cons string args) :default t))
|
|---|
| 478 |
|
|---|
| 479 |
|
|---|
| 480 | |
|---|
| 481 |
|
|---|
| 482 | ;;;; Dired expunging and quitting.
|
|---|
| 483 |
|
|---|
| 484 | (defcommand "Dired Expunge Files" (p)
|
|---|
| 485 | "Expunges files marked for deletion.
|
|---|
| 486 | Query the user if value of \"Dired File Expunge Confirm\" is non-nil. Do
|
|---|
| 487 | the same with directories and the value of \"Dired Directory Expunge
|
|---|
| 488 | Confirm\"."
|
|---|
| 489 | "Expunges files marked for deletion.
|
|---|
| 490 | Query the user if value of \"Dired File Expunge Confirm\" is non-nil. Do
|
|---|
| 491 | the same with directories and the value of \"Dired Directory Expunge
|
|---|
| 492 | Confirm\"."
|
|---|
| 493 | (declare (ignore p))
|
|---|
| 494 | (when (expunge-dired-files)
|
|---|
| 495 | (dired-update-buffer-command nil))
|
|---|
| 496 | (maintain-dired-consistency))
|
|---|
| 497 |
|
|---|
| 498 | (defcommand "Dired Quit" (p)
|
|---|
| 499 | "Expunges the files in a dired buffer and then exits."
|
|---|
| 500 | "Expunges the files in a dired buffer and then exits."
|
|---|
| 501 | (declare (ignore p))
|
|---|
| 502 | (expunge-dired-files)
|
|---|
| 503 | (delete-buffer-if-possible (current-buffer)))
|
|---|
| 504 |
|
|---|
| 505 | (defhvar "Dired File Expunge Confirm"
|
|---|
| 506 | "When set (the default), \"Dired Expunge Files\" and \"Dired Quit\" will ask
|
|---|
| 507 | for confirmation before deleting the marked files."
|
|---|
| 508 | :value t)
|
|---|
| 509 |
|
|---|
| 510 | (defhvar "Dired Directory Expunge Confirm"
|
|---|
| 511 | "When set (the default), \"Dired Expunge Files\" and \"Dired Quit\" will ask
|
|---|
| 512 | for confirmation before deleting each marked directory."
|
|---|
| 513 | :value t)
|
|---|
| 514 |
|
|---|
| 515 | (defun expunge-dired-files ()
|
|---|
| 516 | (multiple-value-bind (marked-files marked-dirs) (get-marked-dired-files)
|
|---|
| 517 | (let ((dired:*error-function* #'dired-error-function)
|
|---|
| 518 | (dired:*report-function* #'dired-report-function)
|
|---|
| 519 | (dired:*yesp-function* #'dired-yesp-function)
|
|---|
| 520 | (we-did-something nil))
|
|---|
| 521 | (when (and marked-files
|
|---|
| 522 | (or (not (value dired-file-expunge-confirm))
|
|---|
| 523 | (prompt-for-y-or-n :prompt "Really delete files? "
|
|---|
| 524 | :default t
|
|---|
| 525 | :must-exist t
|
|---|
| 526 | :default-string "Y")))
|
|---|
| 527 | (setf we-did-something t)
|
|---|
| 528 | (dolist (file-info marked-files)
|
|---|
| 529 | (let ((pathname (car file-info))
|
|---|
| 530 | (write-date (cdr file-info)))
|
|---|
| 531 | (if (= write-date (file-write-date pathname))
|
|---|
| 532 | (dired:delete-file (namestring pathname) :clobber t
|
|---|
| 533 | :recursive nil)
|
|---|
| 534 | (message "~A has been modified, it remains unchanged."
|
|---|
| 535 | (namestring pathname))))))
|
|---|
| 536 | (when marked-dirs
|
|---|
| 537 | (dolist (dir-info marked-dirs)
|
|---|
| 538 | (let ((dir (car dir-info))
|
|---|
| 539 | (write-date (cdr dir-info)))
|
|---|
| 540 | (if (= write-date (file-write-date dir))
|
|---|
| 541 | (when (or (not (value dired-directory-expunge-confirm))
|
|---|
| 542 | (prompt-for-y-or-n
|
|---|
| 543 | :prompt (list "~a is a directory. Delete it? "
|
|---|
| 544 | (directory-namestring dir))
|
|---|
| 545 | :default t
|
|---|
| 546 | :must-exist t
|
|---|
| 547 | :default-string "Y"))
|
|---|
| 548 | (dired:delete-file (directory-namestring dir) :clobber t
|
|---|
| 549 | :recursive t)
|
|---|
| 550 | (setf we-did-something t))
|
|---|
| 551 | (message "~A has been modified, it remains unchanged.")))))
|
|---|
| 552 | we-did-something)))
|
|---|
| 553 |
|
|---|
| 554 |
|
|---|
| 555 | |
|---|
| 556 |
|
|---|
| 557 | ;;;; Dired copying and renaming.
|
|---|
| 558 |
|
|---|
| 559 | (defhvar "Dired Copy File Confirm"
|
|---|
| 560 | "Can be either t, nil, or :update. T means always query before clobbering an
|
|---|
| 561 | existing file, nil means don't query before clobbering an existing file, and
|
|---|
| 562 | :update means only ask if the existing file is newer than the source."
|
|---|
| 563 | :value T)
|
|---|
| 564 |
|
|---|
| 565 | (defhvar "Dired Rename File Confirm"
|
|---|
| 566 | "When non-nil, dired will query before clobbering an existing file."
|
|---|
| 567 | :value T)
|
|---|
| 568 |
|
|---|
| 569 | (defcommand "Dired Copy File" (p)
|
|---|
| 570 | "Copy the file under the point"
|
|---|
| 571 | "Copy the file under the point"
|
|---|
| 572 | (declare (ignore p))
|
|---|
| 573 | (let* ((point (current-point))
|
|---|
| 574 | (confirm (value dired-copy-file-confirm))
|
|---|
| 575 | (source (dired-file-pathname
|
|---|
| 576 | (array-element-from-mark
|
|---|
| 577 | point (dired-info-files (value dired-information)))))
|
|---|
| 578 | (dest (prompt-for-file
|
|---|
| 579 | :prompt (if (directoryp source)
|
|---|
| 580 | "Destination Directory Name: "
|
|---|
| 581 | "Destination Filename: ")
|
|---|
| 582 | :help "Name of new file."
|
|---|
| 583 | :default source
|
|---|
| 584 | :must-exist nil))
|
|---|
| 585 | (dired:*error-function* #'dired-error-function)
|
|---|
| 586 | (dired:*report-function* #'dired-report-function)
|
|---|
| 587 | (dired:*yesp-function* #'dired-yesp-function))
|
|---|
| 588 | (dired:copy-file source dest :update (if (eq confirm :update) t nil)
|
|---|
| 589 | :clobber (not confirm)))
|
|---|
| 590 | (maintain-dired-consistency))
|
|---|
| 591 |
|
|---|
| 592 | (defcommand "Dired Rename File" (p)
|
|---|
| 593 | "Rename the file or directory under the point"
|
|---|
| 594 | "Rename the file or directory under the point"
|
|---|
| 595 | (declare (ignore p))
|
|---|
| 596 | (let* ((point (current-point))
|
|---|
| 597 | (source (dired-namify (dired-file-pathname
|
|---|
| 598 | (array-element-from-mark
|
|---|
| 599 | point
|
|---|
| 600 | (dired-info-files (value dired-information))))))
|
|---|
| 601 | (dest (prompt-for-file
|
|---|
| 602 | :prompt "New Filename: "
|
|---|
| 603 | :help "The new name for this file."
|
|---|
| 604 | :default source
|
|---|
| 605 | :must-exist nil))
|
|---|
| 606 | (dired:*error-function* #'dired-error-function)
|
|---|
| 607 | (dired:*report-function* #'dired-report-function)
|
|---|
| 608 | (dired:*yesp-function* #'dired-yesp-function))
|
|---|
| 609 | ;; ARRAY-ELEMENT-FROM-MARK moves mark to line start.
|
|---|
| 610 | (dired:rename-file source dest :clobber (value dired-rename-file-confirm)))
|
|---|
| 611 | (maintain-dired-consistency))
|
|---|
| 612 |
|
|---|
| 613 | (defcommand "Dired Copy with Wildcard" (p)
|
|---|
| 614 | "Copy files that match a pattern containing ONE wildcard."
|
|---|
| 615 | "Copy files that match a pattern containing ONE wildcard."
|
|---|
| 616 | (declare (ignore p))
|
|---|
| 617 | (let* ((dir-info (value dired-information))
|
|---|
| 618 | (confirm (value dired-copy-file-confirm))
|
|---|
| 619 | (pattern (prompt-for-string
|
|---|
| 620 | :prompt "Filename pattern: "
|
|---|
| 621 | :help "Type a filename with a single asterisk."
|
|---|
| 622 | :trim t))
|
|---|
| 623 | (destination (namestring
|
|---|
| 624 | (prompt-for-file
|
|---|
| 625 | :prompt "Destination Spec: "
|
|---|
| 626 | :help "Destination spec. May contain ONE asterisk."
|
|---|
| 627 | :default (dired-info-pathname dir-info)
|
|---|
| 628 | :must-exist nil)))
|
|---|
| 629 | (dired:*error-function* #'dired-error-function)
|
|---|
| 630 | (dired:*yesp-function* #'dired-yesp-function)
|
|---|
| 631 | (dired:*report-function* #'dired-report-function))
|
|---|
| 632 | (dired:copy-file pattern destination :update (if (eq confirm :update) t nil)
|
|---|
| 633 | :clobber (not confirm)
|
|---|
| 634 | :directory (dired-info-file-list dir-info)))
|
|---|
| 635 | (maintain-dired-consistency))
|
|---|
| 636 |
|
|---|
| 637 | (defcommand "Dired Rename with Wildcard" (p)
|
|---|
| 638 | "Rename files that match a pattern containing ONE wildcard."
|
|---|
| 639 | "Rename files that match a pattern containing ONE wildcard."
|
|---|
| 640 | (declare (ignore p))
|
|---|
| 641 | (let* ((dir-info (value dired-information))
|
|---|
| 642 | (pattern (prompt-for-string
|
|---|
| 643 | :prompt "Filename pattern: "
|
|---|
| 644 | :help "Type a filename with a single asterisk."
|
|---|
| 645 | :trim t))
|
|---|
| 646 | (destination (namestring
|
|---|
| 647 | (prompt-for-file
|
|---|
| 648 | :prompt "Destination Spec: "
|
|---|
| 649 | :help "Destination spec. May contain ONE asterisk."
|
|---|
| 650 | :default (dired-info-pathname dir-info)
|
|---|
| 651 | :must-exist nil)))
|
|---|
| 652 | (dired:*error-function* #'dired-error-function)
|
|---|
| 653 | (dired:*yesp-function* #'dired-yesp-function)
|
|---|
| 654 | (dired:*report-function* #'dired-report-function))
|
|---|
| 655 | (dired:rename-file pattern destination
|
|---|
| 656 | :clobber (not (value dired-rename-file-confirm))
|
|---|
| 657 | :directory (dired-info-file-list dir-info)))
|
|---|
| 658 | (maintain-dired-consistency))
|
|---|
| 659 |
|
|---|
| 660 | (defcommand "Delete File" (p)
|
|---|
| 661 | "Delete a file. Specify directories with a trailing slash."
|
|---|
| 662 | "Delete a file. Specify directories with a trailing slash."
|
|---|
| 663 | (declare (ignore p))
|
|---|
| 664 | (let* ((spec (namestring
|
|---|
| 665 | (prompt-for-file
|
|---|
| 666 | :prompt "Delete File: "
|
|---|
| 667 | :help '("Name of File or Directory to delete. ~
|
|---|
| 668 | One wildcard is permitted.")
|
|---|
| 669 | :must-exist nil)))
|
|---|
| 670 | (directoryp (directoryp spec))
|
|---|
| 671 | (dired:*error-function* #'dired-error-function)
|
|---|
| 672 | (dired:*report-function* #'dired-report-function)
|
|---|
| 673 | (dired:*yesp-function* #'dired-yesp-function))
|
|---|
| 674 | (when (or (not directoryp)
|
|---|
| 675 | (not (value dired-directory-expunge-confirm))
|
|---|
| 676 | (prompt-for-y-or-n
|
|---|
| 677 | :prompt (list "~A is a directory. Delete it? "
|
|---|
| 678 | (directory-namestring spec))
|
|---|
| 679 | :default t :must-exist t :default-string "Y")))
|
|---|
| 680 | (dired:delete-file spec :recursive t
|
|---|
| 681 | :clobber (or directoryp
|
|---|
| 682 | (value dired-file-expunge-confirm))))
|
|---|
| 683 | (maintain-dired-consistency))
|
|---|
| 684 |
|
|---|
| 685 | (defcommand "Copy File" (p)
|
|---|
| 686 | "Copy a file, allowing ONE wildcard."
|
|---|
| 687 | "Copy a file, allowing ONE wildcard."
|
|---|
| 688 | (declare (ignore p))
|
|---|
| 689 | (let* ((confirm (value dired-copy-file-confirm))
|
|---|
| 690 | (source (namestring
|
|---|
| 691 | (prompt-for-file
|
|---|
| 692 | :prompt "Source Filename: "
|
|---|
| 693 | :help "Name of File to copy. One wildcard is permitted."
|
|---|
| 694 | :must-exist nil)))
|
|---|
| 695 | (dest (namestring
|
|---|
| 696 | (prompt-for-file
|
|---|
| 697 | :prompt (if (directoryp source)
|
|---|
| 698 | "Destination Directory Name: "
|
|---|
| 699 | "Destination Filename: ")
|
|---|
| 700 | :help "Name of new file."
|
|---|
| 701 | :default source
|
|---|
| 702 | :must-exist nil)))
|
|---|
| 703 | (dired:*error-function* #'dired-error-function)
|
|---|
| 704 | (dired:*report-function* #'dired-report-function)
|
|---|
| 705 | (dired:*yesp-function* #'dired-yesp-function))
|
|---|
| 706 | (dired:copy-file source dest :update (if (eq confirm :update) t nil)
|
|---|
| 707 | :clobber (not confirm)))
|
|---|
| 708 | (maintain-dired-consistency))
|
|---|
| 709 |
|
|---|
| 710 | (defcommand "Rename File" (p)
|
|---|
| 711 | "Rename a file, allowing ONE wildcard."
|
|---|
| 712 | "Rename a file, allowing ONE wildcard."
|
|---|
| 713 | (declare (ignore p))
|
|---|
| 714 | (let* ((source (namestring
|
|---|
| 715 | (prompt-for-file
|
|---|
| 716 | :prompt "Source Filename: "
|
|---|
| 717 | :help "Name of file to rename. One wildcard is permitted."
|
|---|
| 718 | :must-exist nil)))
|
|---|
| 719 | (dest (namestring
|
|---|
| 720 | (prompt-for-file
|
|---|
| 721 | :prompt (if (directoryp source)
|
|---|
| 722 | "Destination Directory Name: "
|
|---|
| 723 | "Destination Filename: ")
|
|---|
| 724 | :help "Name of new file."
|
|---|
| 725 | :default source
|
|---|
| 726 | :must-exist nil)))
|
|---|
| 727 | (dired:*error-function* #'dired-error-function)
|
|---|
| 728 | (dired:*report-function* #'dired-report-function)
|
|---|
| 729 | (dired:*yesp-function* #'dired-yesp-function))
|
|---|
| 730 | (dired:rename-file source dest
|
|---|
| 731 | :clobber (not (value dired-rename-file-confirm))))
|
|---|
| 732 | (maintain-dired-consistency))
|
|---|
| 733 |
|
|---|
| 734 | (defun maintain-dired-consistency ()
|
|---|
| 735 | (dolist (info *pathnames-to-dired-buffers*)
|
|---|
| 736 | (let* ((directory (directory-namestring (car info)))
|
|---|
| 737 | (buffer (cdr info))
|
|---|
| 738 | (dir-info (variable-value 'dired-information :buffer buffer))
|
|---|
| 739 | (write-date (file-write-date directory)))
|
|---|
| 740 | (unless (= (dired-info-write-date dir-info) write-date)
|
|---|
| 741 | (update-dired-buffer directory (dired-info-pattern dir-info) buffer)))))
|
|---|
| 742 |
|
|---|
| 743 |
|
|---|
| 744 | |
|---|
| 745 |
|
|---|
| 746 | ;;;; Dired utilities.
|
|---|
| 747 |
|
|---|
| 748 | ;;; GET-MARKED-DIRED-FILES returns as multiple values a list of file specs
|
|---|
| 749 | ;;; and a list of directory specs that have been marked for deletion. This
|
|---|
| 750 | ;;; assumes the current buffer is a "Dired" buffer.
|
|---|
| 751 | ;;;
|
|---|
| 752 | (defun get-marked-dired-files ()
|
|---|
| 753 | (let* ((files (dired-info-files (value dired-information)))
|
|---|
| 754 | (length (length files))
|
|---|
| 755 | (marked-files ())
|
|---|
| 756 | (marked-dirs ()))
|
|---|
| 757 | (unless files (editor-error "Not in Dired buffer."))
|
|---|
| 758 | (do ((i 0 (1+ i)))
|
|---|
| 759 | ((= i length) (values (nreverse marked-files) (nreverse marked-dirs)))
|
|---|
| 760 | (let* ((thing (svref files i))
|
|---|
| 761 | (pathname (dired-file-pathname thing)))
|
|---|
| 762 | (when (and (dired-file-deleted-p thing) ; file marked for delete
|
|---|
| 763 | (probe-file pathname)) ; file still exists
|
|---|
| 764 | (if (directoryp pathname)
|
|---|
| 765 | (push (cons pathname (file-write-date pathname)) marked-dirs)
|
|---|
| 766 | (push (cons pathname (file-write-date pathname))
|
|---|
| 767 | marked-files)))))))
|
|---|
| 768 |
|
|---|
| 769 | ;;; ARRAY-ELEMENT-FROM-MARK -- Internal Interface.
|
|---|
| 770 | ;;;
|
|---|
| 771 | ;;; This counts the lines between it and the beginning of the buffer. The
|
|---|
| 772 | ;;; number is used to index vector as if each line mapped to an element
|
|---|
| 773 | ;;; starting with the zero'th element (lines are numbered starting at 1).
|
|---|
| 774 | ;;; This must use AREF since some modes use this with extendable vectors.
|
|---|
| 775 | ;;;
|
|---|
| 776 | (defun array-element-from-mark (mark vector
|
|---|
| 777 | &optional (error-msg "Invalid line."))
|
|---|
| 778 | (when (blank-line-p (mark-line mark)) (editor-error error-msg))
|
|---|
| 779 | (aref vector
|
|---|
| 780 | (1- (count-lines (region
|
|---|
| 781 | (buffer-start-mark (line-buffer (mark-line mark)))
|
|---|
| 782 | mark)))))
|
|---|
| 783 |
|
|---|
| 784 | ;;; DIRED-NAMIFY and DIRED-DIRECTORIFY are implementation dependent slime.
|
|---|
| 785 | ;;;
|
|---|
| 786 | (defun dired-namify (pathname)
|
|---|
| 787 | (let* ((string (namestring pathname))
|
|---|
| 788 | (last (1- (length string))))
|
|---|
| 789 | (if (char= (schar string last) #\/)
|
|---|
| 790 | (subseq string 0 last)
|
|---|
| 791 | string)))
|
|---|
| 792 | ;;;
|
|---|
| 793 | ;;; This is necessary to derive a canonical representation for directory
|
|---|
| 794 | ;;; names, so "Dired" can map various strings naming one directory to that
|
|---|
| 795 | ;;; one directory.
|
|---|
| 796 | ;;;
|
|---|
| 797 | (defun dired-directorify (pathname)
|
|---|
| 798 | (let ((directory (ext:unix-namestring pathname)))
|
|---|
| 799 | (if (directoryp directory)
|
|---|
| 800 | directory
|
|---|
| 801 | (pathname (concatenate 'simple-string (namestring directory) "/")))))
|
|---|
| 802 |
|
|---|
| 803 |
|
|---|
| 804 | |
|---|
| 805 |
|
|---|
| 806 | ;;;; View Mode.
|
|---|
| 807 |
|
|---|
| 808 | (defmode "View" :major-p nil
|
|---|
| 809 | :setup-function 'setup-view-mode
|
|---|
| 810 | :cleanup-function 'cleanup-view-mode
|
|---|
| 811 | :precedence 5.0
|
|---|
| 812 | :documentation
|
|---|
| 813 | "View mode scrolls forwards and backwards in a file with the buffer read-only.
|
|---|
| 814 | Scrolling off the end optionally deletes the buffer.")
|
|---|
| 815 |
|
|---|
| 816 | (defun setup-view-mode (buffer)
|
|---|
| 817 | (defhvar "View Return Function"
|
|---|
| 818 | "Function that gets called when quitting or returning from view mode."
|
|---|
| 819 | :value nil
|
|---|
| 820 | :buffer buffer)
|
|---|
| 821 | (setf (buffer-writable buffer) nil))
|
|---|
| 822 | ;;;
|
|---|
| 823 | (defun cleanup-view-mode (buffer)
|
|---|
| 824 | (delete-variable 'view-return-function :buffer buffer)
|
|---|
| 825 | (setf (buffer-writable buffer) t))
|
|---|
| 826 |
|
|---|
| 827 | (defcommand "View File" (p &optional pathname)
|
|---|
| 828 | "Reads a file in as if by \"Find File\", but read-only. Commands exist
|
|---|
| 829 | for scrolling convenience."
|
|---|
| 830 | "Reads a file in as if by \"Find File\", but read-only. Commands exist
|
|---|
| 831 | for scrolling convenience."
|
|---|
| 832 | (declare (ignore p))
|
|---|
| 833 | (let* ((pn (or pathname
|
|---|
| 834 | (prompt-for-file
|
|---|
| 835 | :prompt "View File: " :must-exist t
|
|---|
| 836 | :help "Name of existing file to read into its own buffer."
|
|---|
| 837 | :default (buffer-default-pathname (current-buffer)))))
|
|---|
| 838 | (buffer (make-buffer (format nil "View File ~A" (gensym)))))
|
|---|
| 839 | (visit-file-command nil pn buffer)
|
|---|
| 840 | (setf (buffer-minor-mode buffer "View") t)
|
|---|
| 841 | (change-to-buffer buffer)
|
|---|
| 842 | buffer))
|
|---|
| 843 |
|
|---|
| 844 | (defcommand "View Return" (p)
|
|---|
| 845 | "Return to a parent buffer, if it exists."
|
|---|
| 846 | "Return to a parent buffer, if it exists."
|
|---|
| 847 | (declare (ignore p))
|
|---|
| 848 | (unless (call-view-return-fun)
|
|---|
| 849 | (editor-error "No View return method for this buffer.")))
|
|---|
| 850 |
|
|---|
| 851 | (defcommand "View Quit" (p)
|
|---|
| 852 | "Delete a buffer in view mode."
|
|---|
| 853 | "Delete a buffer in view mode, invoking VIEW-RETURN-FUNCTION if it exists for
|
|---|
| 854 | this buffer."
|
|---|
| 855 | (declare (ignore p))
|
|---|
| 856 | (let* ((buf (current-buffer))
|
|---|
| 857 | (funp (call-view-return-fun)))
|
|---|
| 858 | (delete-buffer-if-possible buf)
|
|---|
| 859 | (unless funp (editor-error "No View return method for this buffer."))))
|
|---|
| 860 |
|
|---|
| 861 | ;;; CALL-VIEW-RETURN-FUN returns nil if there is no current
|
|---|
| 862 | ;;; view-return-function. If there is one, it calls it and returns t.
|
|---|
| 863 | ;;;
|
|---|
| 864 | (defun call-view-return-fun ()
|
|---|
| 865 | (if (hemlock-bound-p 'view-return-function)
|
|---|
| 866 | (let ((fun (value view-return-function)))
|
|---|
| 867 | (cond (fun
|
|---|
| 868 | (funcall fun)
|
|---|
| 869 | t)))))
|
|---|
| 870 |
|
|---|
| 871 |
|
|---|
| 872 | (defhvar "View Scroll Deleting Buffer"
|
|---|
| 873 | "When this is set, \"View Scroll Down\" deletes the buffer when the end
|
|---|
| 874 | of the file is visible."
|
|---|
| 875 | :value t)
|
|---|
| 876 |
|
|---|
| 877 | (defcommand "View Scroll Down" (p)
|
|---|
| 878 | "Scroll the current window down through its buffer.
|
|---|
| 879 | If the end of the file is visible, then delete the buffer if \"View Scroll
|
|---|
| 880 | Deleting Buffer\" is set. If the buffer is associated with a dired buffer,
|
|---|
| 881 | this returns there instead of to the previous buffer."
|
|---|
| 882 | "Scroll the current window down through its buffer.
|
|---|
| 883 | If the end of the file is visible, then delete the buffer if \"View Scroll
|
|---|
| 884 | Deleting Buffer\" is set. If the buffer is associated with a dired buffer,
|
|---|
| 885 | this returns there instead of to the previous buffer."
|
|---|
| 886 | (if (and (not p)
|
|---|
| 887 | (displayed-p (buffer-end-mark (current-buffer))
|
|---|
| 888 | (current-window))
|
|---|
| 889 | (value view-scroll-deleting-buffer))
|
|---|
| 890 | (view-quit-command nil)
|
|---|
| 891 | (scroll-window-down-command p)))
|
|---|
| 892 |
|
|---|
| 893 | (defcommand "View Edit File" (p)
|
|---|
| 894 | "Turn off \"View\" mode in this buffer."
|
|---|
| 895 | "Turn off \"View\" mode in this buffer."
|
|---|
| 896 | (declare (ignore p))
|
|---|
| 897 | (let ((buf (current-buffer)))
|
|---|
| 898 | (setf (buffer-minor-mode buf "View") nil)
|
|---|
| 899 | (warn-about-visit-file-buffers buf)))
|
|---|
| 900 |
|
|---|
| 901 | (defcommand "View Help" (p)
|
|---|
| 902 | "Shows \"View\" mode help message."
|
|---|
| 903 | "Shows \"View\" mode help message."
|
|---|
| 904 | (declare (ignore p))
|
|---|
| 905 | (describe-mode-command nil "View"))
|
|---|
