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

Contents of /src/hemlock/diredcoms.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5