/[cmucl]/src/hemlock/diredcoms.lisp
ViewVC logotype

Contents of /src/hemlock/diredcoms.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5