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

Contents of /src/hemlock/diredcoms.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5