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

Contents of /src/hemlock/diredcoms.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5