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

Diff of /src/hemlock/dired.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1.1.3.1.1 by wlott, Wed Feb 5 16:31:07 1992 UTC revision 1.1.1.6 by ram, Wed Sep 1 09:47:37 1993 UTC
# Line 15  Line 15 
15  ;;; Written by Bill Chiles.  ;;; Written by Bill Chiles.
16  ;;;  ;;;
17    
18    (defpackage "DIRED"
19      (:shadow "RENAME-FILE" "DELETE-FILE")
20      (:export "COPY-FILE" "RENAME-FILE" "FIND-FILE" "DELETE-FILE"
21               "MAKE-DIRECTORY"
22               "*UPDATE-DEFAULT*" "*CLOBBER-DEFAULT*" "*RECURSIVE-DEFAULT*"
23               "*REPORT-FUNCTION*" "*ERROR-FUNCTION*" "*YESP-FUNCTION*"
24               "PATHNAMES-FROM-PATTERN"))
25    
26  (in-package "DIRED")  (in-package "DIRED")
27    
 (shadow '(rename-file delete-file))  
   
 (export '(copy-file rename-file find-file delete-file make-directory  
           *update-default* *clobber-default* *recursive-default*  
           *report-function* *error-function* *yesp-function*  
           pathnames-from-pattern))  
   
   
28    
29  ;;;; Exported parameters.  ;;;; Exported parameters.
30    
# Line 207  Line 207 
207  ;;; adds it to the end of the sequence of directory names from pname2, returning  ;;; adds it to the end of the sequence of directory names from pname2, returning
208  ;;; a pathname.  ;;; a pathname.
209  ;;;  ;;;
210    #|
211  (defun merge-dirs (pname1 pname2)  (defun merge-dirs (pname1 pname2)
212    (let* ((dirs1 (pathname-directory pname1))    (let* ((dirs1 (pathname-directory pname1))
213           (dirs2 (pathname-directory pname2))           (dirs2 (pathname-directory pname2))
# Line 217  Line 218 
218      (setf (svref new-dirs2 dirs2-len)      (setf (svref new-dirs2 dirs2-len)
219            (svref dirs1 (1- (length dirs1))))            (svref dirs1 (1- (length dirs1))))
220      (make-pathname :directory new-dirs2 :device :absolute)))      (make-pathname :directory new-dirs2 :device :absolute)))
221    |#
222    
223    (defun merge-dirs (pname1 pname2)
224      (let* ((dirs1 (pathname-directory pname1))
225             (dirs2 (pathname-directory pname2))
226             (dirs2-len (length dirs2))
227             (new-dirs2 (make-list (1+ dirs2-len))))
228        (replace new-dirs2 dirs2)
229        (setf (nth dirs2-len new-dirs2)
230              (nth (1- (length dirs1)) dirs1))
231        (make-pathname :directory new-dirs2 :device :unspecific)))
232    
233  ;;; COPY-FILE-1 takes pathnames which either both contain a single wildcard  ;;; COPY-FILE-1 takes pathnames which either both contain a single wildcard
234  ;;; or none.  Wildp1 and Wildp2 are either nil or indexes into the  ;;; or none.  Wildp1 and Wildp2 are either nil or indexes into the
# Line 612  Line 624 
624                            dev-or-err))                            dev-or-err))
625      (setf (car *utimes-buffer*) atime)      (setf (car *utimes-buffer*) atime)
626      (setf (caddr *utimes-buffer*) secs))      (setf (caddr *utimes-buffer*) secs))
627    (multiple-value-bind (winp err) (unix:unix-utimes ses-name *utimes-buffer*)    (multiple-value-bind (winp err)
628                           `(unix:unix-utimes ses-name ,@*utimes-buffer*)
629      (unless winp      (unless winp
630        (funcall *error-function* "Couldn't set write date of file ~S: ~A"        (funcall *error-function* "Couldn't set write date of file ~S: ~A"
631                 ses-name                 ses-name

Legend:
Removed from v.1.1.1.3.1.1  
changed lines
  Added in v.1.1.1.6

  ViewVC Help
Powered by ViewVC 1.1.5