/[cmucl]/src/code/filesys.lisp
ViewVC logotype

Diff of /src/code/filesys.lisp

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

revision 1.72 by toy, Fri Feb 14 19:47:12 2003 UTC revision 1.73 by toy, Tue Jun 10 16:52:36 2003 UTC
# Line 25  Line 25 
25    
26  (in-package "EXTENSIONS")  (in-package "EXTENSIONS")
27  (export '(print-directory complete-file ambiguous-files default-directory  (export '(print-directory complete-file ambiguous-files default-directory
28                            file-writable unix-namestring))            purge-files file-writable unix-namestring))
29  (in-package "LISP")  (in-package "LISP")
30    
31    
# Line 40  Line 40 
40  ;;; type := "." [^/.]*  ;;; type := "." [^/.]*
41  ;;; version := ".*" | ".~" ([0-9]+ | "*") "~"  ;;; version := ".*" | ".~" ([0-9]+ | "*") "~"
42  ;;;  ;;;
43  ;;; Note: this grammer is ambiguous.  The string foo.bar.~5~ can be parsed  ;;; Note: this grammar is ambiguous.  The string foo.bar.~5~ can be parsed
44  ;;; as either just the file specified or as specifying the file, type, and  ;;; as either just the file specified or as specifying the file, type, and
45  ;;; version.  Therefore, we use the following rules when confronted with  ;;; version.  Therefore, we use the following rules when confronted with
46  ;;; an ambiguous file.type.version string:  ;;; an ambiguous file.type.version string:
# Line 48  Line 48 
48  ;;; - If the first character is a dot, it's part of the file.  It is not  ;;; - If the first character is a dot, it's part of the file.  It is not
49  ;;; considered a dot in the following rules.  ;;; considered a dot in the following rules.
50  ;;;  ;;;
51  ;;; - If there is only one dot, it seperates the file and the type.  ;;; - If there is only one dot, it separates the file and the type.
52  ;;;  ;;;
53  ;;; - If there are multiple dots and the stuff following the last dot  ;;; - If there are multiple dots and the stuff following the last dot
54  ;;; is a valid version, then that is the version and the stuff between  ;;; is a valid version, then that is the version and the stuff between
# Line 65  Line 65 
65  ;;; [abc] - matches any of a, b, or c.  ;;; [abc] - matches any of a, b, or c.
66  ;;; {str1,str2,...,strn} - matches any of str1, str2, ..., or strn.  ;;; {str1,str2,...,strn} - matches any of str1, str2, ..., or strn.
67  ;;;  ;;;
68  ;;; Any of these special characters can be preceeded by a backslash to  ;;; Any of these special characters can be preceded by a backslash to
69  ;;; cause it to be treated as a regular character.  ;;; cause it to be treated as a regular character.
70  ;;;  ;;;
71    
72  (defun remove-backslashes (namestr start end)  (defun remove-backslashes (namestr start end)
73    "Remove and occurences of \\ from the string because we've already    "Remove any occurrences of \\ from the string because we've already
74     checked for whatever they may have been backslashed."     checked for whatever may have been backslashed."
75    (declare (type simple-base-string namestr)    (declare (type simple-base-string namestr)
76             (type index start end))             (type index start end))
77    (let* ((result (make-string (- end start)))    (let* ((result (make-string (- end start)))
# Line 199  Line 199 
199         (any-version (namestr start end)         (any-version (namestr start end)
200           ;; process end of string looking for a version candidate.           ;; process end of string looking for a version candidate.
201           (multiple-value-bind (version where)           (multiple-value-bind (version where)
202             (explicit-version namestr start end)               (explicit-version namestr start end)
203             (cond ((not (eq version :newest))             (cond ((not (eq version :newest))
204                    (values version where))                    (values version where))
205                   ((and (>= (- end 2) start)                   ((and (>= (- end 2) start)
# Line 221  Line 221 
221         (any-name (namestr start end)         (any-name (namestr start end)
222           (declare (ignore namestr))           (declare (ignore namestr))
223           (values start end)))           (values start end)))
224      (multiple-value-bind      (multiple-value-bind (version vstart)
225          (version vstart)(any-version namestr start end)          (any-version namestr start end)
226        (multiple-value-bind        (multiple-value-bind (tstart tend)
227            (tstart tend)(any-type namestr start vstart)            (any-type namestr start vstart)
228          (multiple-value-bind          (multiple-value-bind (nstart nend)
229              (nstart nend)(any-name namestr start (or tstart vstart))              (any-name namestr start (or tstart vstart))
230            (values            (values
231             (maybe-make-pattern namestr nstart nend)             (maybe-make-pattern namestr nstart nend)
232             (and tstart (maybe-make-pattern namestr (1+ tstart) tend))             (and tstart (maybe-make-pattern namestr (1+ tstart) tend))
# Line 242  Line 242 
242                         (char= (schar namestr start) #\/))))                         (char= (schar namestr start) #\/))))
243      (when absolute      (when absolute
244        (incf start))        (incf start))
245      ;; Next, split the remainder into slash seperated chunks.      ;; Next, split the remainder into slash separated chunks.
246      (collect ((pieces))      (collect ((pieces))
247        (loop        (loop
248          (let ((slash (position #\/ namestr :start start :end end)))          (let ((slash (position #\/ namestr :start start :end end)))
# Line 279  Line 279 
279                 nil                 nil
280                 (let ((first (car pieces)))                 (let ((first (car pieces)))
281                   (multiple-value-bind                   (multiple-value-bind
282                       (search-list new-start)                         (search-list new-start)
283                       (maybe-extract-search-list namestr                       (maybe-extract-search-list namestr
284                                                  (car first) (cdr first))                                                  (car first) (cdr first))
285                     (when search-list                     (when search-list
# Line 425  Line 425 
425             (type-supplied (not (or (null type) (eq type :unspecific))))             (type-supplied (not (or (null type) (eq type :unspecific))))
426             (logical-p (logical-pathname-p pathname))             (logical-p (logical-pathname-p pathname))
427             (version (%pathname-version pathname))             (version (%pathname-version pathname))
428             (version-supplied (not (or (null version) (member version '(:newest :unspecific))))))             (version-supplied (not (or (null version)
429                                          (member version '(:newest
430                                                            :unspecific))))))
431        (when name        (when name
432          (strings (unparse-unix-piece name)))          (strings (unparse-unix-piece name)))
433        (when type-supplied        (when type-supplied
# Line 562  Line 564 
564  ;;; %enumerate-directories  --   Internal  ;;; %enumerate-directories  --   Internal
565  ;;;  ;;;
566  ;;; The directory node and device numbers are maintained for the current path  ;;; The directory node and device numbers are maintained for the current path
567  ;;; during the search for the detection of paths loops upon :wild-inferiors.  ;;; during the search for the detection of path loops upon :wild-inferiors.
568  ;;;  ;;;
569  (defun %enumerate-directories (head tail pathname verify-existance  (defun %enumerate-directories (head tail pathname verify-existance
570                                 follow-links nodes function)                                 follow-links nodes function)
# Line 775  Line 777 
777  ;;;  ;;;
778  (defun probe-file (pathname)  (defun probe-file (pathname)
779    "Return a pathname which is the truename of the file if it exists, NIL    "Return a pathname which is the truename of the file if it exists, NIL
780    otherwise. An error of type file-error is signaled if pathname is wild."    otherwise. An error of type file-error is signalled if pathname is wild."
781    (if (wild-pathname-p pathname)    (if (wild-pathname-p pathname)
782        (error 'simple-file-error        (error 'simple-file-error
783               :pathname pathname               :pathname pathname
# Line 843  Line 845 
845                                         (unix:get-unix-error-msg err))))))                                         (unix:get-unix-error-msg err))))))
846    t)    t)
847    
848    ;;; Purge-Files  --  Public
849    ;;;
850    ;;;    Purge old file versions
851    ;;;
852    (defun purge-files (pathname &optional (keep 0))
853      "Delete old versions of files matching the given Pathname,
854    optionally keeping some of the most recent old versions."
855      (declare (type (or pathname string stream) pathname)
856               (type (integer 0 *) keep))
857      (let ((hash (make-hash-table :test 'equal)))
858        (enumerate-search-list
859            (path (make-pathname :version :wild :defaults pathname))
860          (clrhash hash)
861          (enumerate-matches (name path nil :follow-links nil)
862            (let ((dot (position #\. name :from-end t))
863                  (len (length name)))
864              (when (and dot
865                         (> len (+ dot 3))
866                         (char= (char name (1+ dot)) #\~)
867                         (char= (char name (1- len)) #\~)
868                         (eq (unix:unix-file-kind name) :file))
869                (multiple-value-bind (version next)
870                    (parse-integer name :start (+ dot 2) :end (1- len)
871                                   :junk-allowed t)
872                  (when (and version (= next (1- len)))
873                    (push (cons version name)
874                          (gethash (subseq name 0 dot) hash '())))))))
875          (maphash (lambda (key value)
876                     (declare (ignore key))
877                     (mapc #'unix:unix-unlink
878                           (mapcar #'cdr (nthcdr keep
879                                                 (sort value #'> :key #'car)))))
880                   hash))))
881    
882    
883  ;;; User-Homedir-Pathname  --  Public  ;;; User-Homedir-Pathname  --  Public
884  ;;;  ;;;
# Line 858  Line 894 
894  ;;;  ;;;
895  (defun file-write-date (file)  (defun file-write-date (file)
896    "Return file's creation date, or NIL if it doesn't exist.    "Return file's creation date, or NIL if it doesn't exist.
897   An error of type file-error is signaled if file is a wild pathname"   An error of type file-error is signalled if file is a wild pathname"
898    (if (wild-pathname-p file)    (if (wild-pathname-p file)
899        (error 'simple-file-error        (error 'simple-file-error
900               :pathname file               :pathname file
# Line 906  Line 942 
942    "Returns a list of pathnames, one for each file that matches the given    "Returns a list of pathnames, one for each file that matches the given
943     pathname.  Supplying :ALL as nil causes this to ignore Unix dot files.  This     pathname.  Supplying :ALL as nil causes this to ignore Unix dot files.  This
944     never includes Unix dot and dot-dot in the result.  If :TRUENAMEP is NIL,     never includes Unix dot and dot-dot in the result.  If :TRUENAMEP is NIL,
945     then symblolic links in the result are not expanded which is not the     then symbolic links in the result are not expanded, which is not the
946     default because TRUENAME does follow links, and the result pathnames are     default because TRUENAME does follow links and the result pathnames are
947     defined to be the TRUENAME of the pathname (the truename of a link may well     defined to be the TRUENAME of the pathname (the truename of a link may well
948     be in another directory.) If FOLLOW-LINKS is NIL then symbolic links are     be in another directory).  If FOLLOW-LINKS is NIL then symbolic links are
949     not followed."     not followed."
950    (let ((results nil))    (let ((results nil))
951      (enumerate-search-list      (enumerate-search-list
# Line 940  Line 976 
976  ;;; PRINT-DIRECTORY is exported from the EXTENSIONS package.  ;;; PRINT-DIRECTORY is exported from the EXTENSIONS package.
977  ;;;  ;;;
978  (defun print-directory (pathname &optional stream &key all verbose return-list)  (defun print-directory (pathname &optional stream &key all verbose return-list)
979    "Like Directory, but prints a terse, multi-coloumn directory listing    "Like Directory, but prints a terse, multi-column directory listing
980     instead of returning a list of pathnames.  When :all is supplied and     instead of returning a list of pathnames.  When :all is supplied and
981     non-nil, then Unix dot files are included too (as ls -a).  When :vervose     non-nil, then Unix dot files are included too (as ls -a).  When :verbose
982     is supplied and non-nil, then a long listing of miscellaneous     is supplied and non-nil, then a long listing of miscellaneous
983     information is output one file per line."     information is output one file per line."
984    (let ((*standard-output* (out-synonym-of stream))    (let ((*standard-output* (out-synonym-of stream))
# Line 955  Line 991 
991    (let ((contents (directory pathname :all all :check-for-subdirs nil    (let ((contents (directory pathname :all all :check-for-subdirs nil
992                               :truenamep nil))                               :truenamep nil))
993          (result nil))          (result nil))
994      (format t "Directory of ~A :~%" (namestring pathname))      (format t "Directory of ~A:~%" (namestring pathname))
995      (dolist (file contents)      (dolist (file contents)
996        (let* ((namestring (unix-namestring file))        (let* ((namestring (unix-namestring file))
997               (tail (subseq namestring               (tail (subseq namestring
# Line 1059  Line 1095 
1095             (cols (max (truncate width col-width) 1))             (cols (max (truncate width col-width) 1))
1096             (lines (ceiling cnt cols)))             (lines (ceiling cnt cols)))
1097        (declare (fixnum cols lines))        (declare (fixnum cols lines))
1098        (format t "Directory of ~A :~%" (namestring pathname))        (format t "Directory of ~A:~%" (namestring pathname))
1099        (dotimes (i lines)        (dotimes (i lines)
1100          (declare (fixnum i))          (declare (fixnum i))
1101          (dotimes (j cols)          (dotimes (j cols)

Legend:
Removed from v.1.72  
changed lines
  Added in v.1.73

  ViewVC Help
Powered by ViewVC 1.1.5