/[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.25.1.1 by wlott, Sun Feb 2 21:01:25 1992 UTC revision 1.114 by rtoy, Tue Mar 1 04:32:58 2011 UTC
# Line 18  Line 18 
18    
19  (in-package "LISP")  (in-package "LISP")
20    
21    (intl:textdomain "cmucl")
22    
23  (export '(truename probe-file user-homedir-pathname directory  (export '(truename probe-file user-homedir-pathname directory
24            rename-file delete-file file-write-date file-author))            rename-file delete-file file-write-date file-author))
25    
# Line 25  Line 27 
27    
28  (in-package "EXTENSIONS")  (in-package "EXTENSIONS")
29  (export '(print-directory complete-file ambiguous-files default-directory  (export '(print-directory complete-file ambiguous-files default-directory
30                            file-writable unix-namestring))            purge-backup-files file-writable unix-namestring))
31  (in-package "LISP")  (in-package "LISP")
32    
33    
# Line 38  Line 40 
40  ;;; search-list := [^:/]*:  ;;; search-list := [^:/]*:
41  ;;; file := [^/]*  ;;; file := [^/]*
42  ;;; type := "." [^/.]*  ;;; type := "." [^/.]*
43  ;;; version := "." ([0-9]+ | "*")  ;;; version := ".*" | ".~" ([1-9]+[0-9]* | "*") "~"
44  ;;;  ;;;
45  ;;; 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
46  ;;; 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
47  ;;; version.  Therefore, we use the following rules when confronted with  ;;; version.  Therefore, we use the following rules when confronted with
48  ;;; an ambiguous file.type.version string:  ;;; an ambiguous file.type.version string:
# Line 48  Line 50 
50  ;;; - 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
51  ;;; considered a dot in the following rules.  ;;; considered a dot in the following rules.
52  ;;;  ;;;
53  ;;; - 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.
54  ;;;  ;;;
55  ;;; - If there are multiple dots and the stuff following the last dot  ;;; - If there are multiple dots and the stuff following the last dot
56  ;;; 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 67 
67  ;;; [abc] - matches any of a, b, or c.  ;;; [abc] - matches any of a, b, or c.
68  ;;; {str1,str2,...,strn} - matches any of str1, str2, ..., or strn.  ;;; {str1,str2,...,strn} - matches any of str1, str2, ..., or strn.
69  ;;;  ;;;
70  ;;; Any of these special characters can be preceeded by a backslash to  ;;; Any of these special characters can be preceded by a backslash to
71  ;;; cause it to be treated as a regular character.  ;;; cause it to be treated as a regular character.
72  ;;;  ;;;
73    
74  (defun remove-backslashes (namestr start end)  (defun remove-backslashes (namestr start end)
75    "Remove and occurences of \\ from the string because we've already    "Remove any occurrences of \\ from the string because we've already
76     checked for whatever they may have been backslashed."     checked for whatever may have been backslashed."
77    (declare (type simple-base-string namestr)    (declare (type simple-base-string namestr)
78             (type index start end))             (type index start end))
79    (let* ((result (make-string (- end start)))    (let* ((result (make-string (- end start)))
# Line 92  Line 94 
94                        (incf dst)))))))                        (incf dst)))))))
95      (when quoted      (when quoted
96        (error 'namestring-parse-error        (error 'namestring-parse-error
97               :complaint "Backslash in bad place."               :complaint (intl:gettext "Backslash in bad place.")
98               :namestring namestr               :namestring namestr
99               :offset (1- end)))               :offset (1- end)))
100      (shrink-vector result dst)))      (shrink-vector result dst)))
101    
102  (defvar *ignore-wildcards* nil)  (defvar *ignore-wildcards* nil
103      "If non-NIL, Unix shell-style wildcards are ignored when parsing
104      pathname namestrings.  They are also ignored when computing
105      namestrings for pathname objects.  Thus, *, ?, etc. are not
106      wildcards when parsing a namestring, and are not escaped when
107      printing pathnames.")
108    
109  (defun maybe-make-pattern (namestr start end)  (defun maybe-make-pattern (namestr start end)
110    (declare (type simple-base-string namestr)    (declare (type simple-base-string namestr)
# Line 145  Line 152 
152                                (position #\] namestr :start index :end end)))                                (position #\] namestr :start index :end end)))
153                           (unless close-bracket                           (unless close-bracket
154                             (error 'namestring-parse-error                             (error 'namestring-parse-error
155                                    :complaint "``['' with no corresponding ``]''"                                    :complaint (intl:gettext "``['' with no corresponding ``]''")
156                                    :namestring namestr                                    :namestring namestr
157                                    :offset index))                                    :offset index))
158                           (pattern (list :character-set                           (pattern (list :character-set
# Line 160  Line 167 
167              (flush-pending-regulars)))              (flush-pending-regulars)))
168          (cond ((null (pattern))          (cond ((null (pattern))
169                 "")                 "")
170                ((and (null (cdr (pattern)))                ((null (cdr (pattern)))
171                      (simple-string-p (car (pattern))))                 (let ((piece (first (pattern))))
172                 (car (pattern)))                   (typecase piece
173                       ((member :multi-char-wild) :wild)
174                       (simple-string piece)
175                       (t
176                        (make-pattern (pattern))))))
177                (t                (t
178                 (make-pattern (pattern)))))))                 (make-pattern (pattern)))))))
179    
180    ;;; extract-name-type-and-version  --  Internal.
181    ;;;
182  (defun extract-name-type-and-version (namestr start end)  (defun extract-name-type-and-version (namestr start end)
183    (declare (type simple-base-string namestr)    (declare (type simple-base-string namestr)
184             (type index start end))             (type index start end))
185    (let* ((last-dot (position #\. namestr :start (1+ start) :end end    (labels
186                               :from-end t))        ((explicit-version (namestr start end)
187           (second-to-last-dot (and last-dot           ;; Look for something like "~*~" at the end of the
188                                    (position #\. namestr :start (1+ start)           ;; namestring, where * can be #\* or some digits.  This
189                                              :end last-dot :from-end t)))           ;; denotes a version.
190           (version :newest))           ;;(format t "explicit-version ~S ~A ~A~%" namestr start end)
191      ;; If there is a second-to-last dot, check to see if there is a valid           (cond ((or (< (- end start) 4)
192      ;; version after the last dot.                      (and (char/= (schar namestr (1- end)) #\~)
193      (when second-to-last-dot                           (char/= (schar namestr (1- end)) #\*)))
194        (cond ((and (= (+ last-dot 2) end)                  ;; No explicit version given, so return NIL to
195                    (char= (schar namestr (1+ last-dot)) #\*))                  ;; indicate we don't want file versions, unless
196               (setf version :wild))                  ;; requested in other ways.
197              ((and (< (1+ last-dot) end)                  ;;(format t "case 1: ~A ~A~%" nil end)
198                    (do ((index (1+ last-dot) (1+ index)))                  (values nil end))
199                        ((= index end) t)                 ((and (not *ignore-wildcards*)
200                      (unless (char<= #\0 (schar namestr index) #\9)                       (char= (schar namestr (- end 2)) #\*)
201                        (return nil))))                       (char= (schar namestr (- end 3)) #\~)
202               (setf version                       (char= (schar namestr (- end 4)) #\.))
203                     (parse-integer namestr :start (1+ last-dot) :end end)))                  ;; Found "~*~", so it's a wild version
204              (t                  ;;(format t "case 2: ~A ~A~%" :wild (- end 4))
205               (setf second-to-last-dot nil))))                  (values :wild (- end 4)))
206      (cond (second-to-last-dot                 (t
207             (values (maybe-make-pattern namestr start second-to-last-dot)                  ;; Look for a version number.  Start at the end, just
208                     (maybe-make-pattern namestr                  ;; before the ~ and keep looking for digits.  If the
209                                         (1+ second-to-last-dot)                  ;; first non-digit is ~, and the leading character is
210                                         last-dot)                  ;; a non-zero digit, we have a version number, so get
211                     version))                  ;; it.  If not, we didn't find a version number, so we
212            (last-dot                  ;; call it :newest
213             (values (maybe-make-pattern namestr start last-dot)                  (do ((i (- end 2) (1- i)))
214                     (maybe-make-pattern namestr (1+ last-dot) end)                      ((< i (+ start 1))
215                     version))                       ;;(format t "case 3: ~A ~A~%" :newest end)
216            (t                       (values :newest end))
217             (values (maybe-make-pattern namestr start end)                    (let ((char (schar namestr i)))
218                     nil                      (when (eql char #\~)
219                     version)))))                        (return (if (char= (schar namestr (1- i)) #\.)
220                                      (if (char= (schar namestr (1+ i)) #\0)
221                                          (values nil end)
222                                          (values (parse-integer namestr :start (1+ i)
223                                                                 :end (1- end))
224                                                  (1- i)))
225                                      (values :newest end))))
226                        (unless (char<= #\0 char #\9)
227                          ;; It's not a digit.  Give up, and say the
228                          ;; version is NIL.
229                          ;;(format t "case 3 return: ~A ~A~%" nil end)
230                          (return (values nil end))))))))
231           (any-version (namestr start end)
232             ;; process end of string looking for a version candidate.
233             (multiple-value-bind (version where)
234                 (explicit-version namestr start end)
235               (cond ((not (eq version :newest))
236                      (values version where))
237                     ((and (not *ignore-wildcards*)
238                           (>= (- end 2) start)
239                           (char= (schar namestr (- end 1)) #\*)
240                           (char= (schar namestr (- end 2)) #\.)
241                           (find #\. namestr
242                                 :start (min (1+ start) (- end 2))
243                                 :end (- end 2)))
244                      (values :wild (- end 2)))
245                     (t (values version where)))))
246           (any-type (namestr start end)
247             ;; Process end of string looking for a type. A leading "."
248             ;; is part of the name.
249             (let ((where (position #\. namestr
250                                    :start (min (1+ start) end)
251                                    :end end :from-end t)))
252               (when where
253                 (values where end))))
254           (any-name (namestr start end)
255             (declare (ignore namestr))
256             (values start end)))
257        (multiple-value-bind (version vstart)
258            (any-version namestr start end)
259          (multiple-value-bind (tstart tend)
260              (any-type namestr start vstart)
261            (multiple-value-bind (nstart nend)
262                (any-name namestr start (or tstart vstart))
263              (values
264               (maybe-make-pattern namestr nstart nend)
265               (and tstart (maybe-make-pattern namestr (1+ tstart) tend))
266               version))))))
267    
268    ;;; Take a string and return a list of cons cells that mark the char
269    ;;; separated subseq. The first value t if absolute directories location.
270    ;;;
271  (defun split-at-slashes (namestr start end)  (defun split-at-slashes (namestr start end)
272    (declare (type simple-base-string namestr)    (declare (type simple-base-string namestr)
273             (type index start end))             (type index start end))
# Line 212  Line 275 
275                         (char= (schar namestr start) #\/))))                         (char= (schar namestr start) #\/))))
276      (when absolute      (when absolute
277        (incf start))        (incf start))
278      ;; Next, split the remainder into slash seperated chunks.      ;; Next, split the remainder into slash separated chunks.
279      (collect ((pieces))      (collect ((pieces))
280        (loop        (loop
281          (let ((slash (position #\/ namestr :start start :end end)))          (let ((slash (position #\/ namestr :start start :end end)))
# Line 249  Line 312 
312                 nil                 nil
313                 (let ((first (car pieces)))                 (let ((first (car pieces)))
314                   (multiple-value-bind                   (multiple-value-bind
315                       (search-list new-start)                         (search-list new-start)
316                       (maybe-extract-search-list namestr                       (maybe-extract-search-list namestr
317                                                  (car first) (cdr first))                                                  (car first) (cdr first))
318                     (when search-list                     (when search-list
319                         ;; Lose if this search-list is already defined as
320                         ;; a logical host.  Since the syntax for
321                         ;; search-lists and logical pathnames are the
322                         ;; same, we can't allow the creation of one when
323                         ;; the other is defined.
324                         (when (find-logical-host search-list nil)
325                           (error (intl:gettext "~A already names a logical host") search-list))
326                       (setf absolute t)                       (setf absolute t)
327                       (setf (car first) new-start))                       (setf (car first) new-start))
328                     search-list)))))                     search-list)))))
329        (multiple-value-bind        (multiple-value-bind (name type version)
           (name type version)  
330            (let* ((tail (car (last pieces)))            (let* ((tail (car (last pieces)))
331                   (tail-start (car tail))                   (tail-start (car tail))
332                   (tail-end (cdr tail)))                   (tail-end (cdr tail)))
333              (unless (= tail-start tail-end)              (unless (= tail-start tail-end)
334                (setf pieces (butlast pieces))                (setf pieces (butlast pieces))
335                (extract-name-type-and-version namestr tail-start tail-end)))                (cond ((string= namestr ".." :start1 tail-start :end1 tail-end)
336                         ;; ".." is a directory.  Add this piece to the
337                         ;; list of pieces, and make the name/type/version
338                         ;; nil.
339                         (setf pieces (append pieces (list (cons tail-start tail-end))))
340                         (values nil nil nil))
341                        ((string= namestr "." :start1 tail-start :end1 tail-end)
342                         ;; "." is a directory as well.
343                         (setf pieces (append pieces (list (cons tail-start tail-end))))
344                         (values nil nil nil))
345                        ((not (find-if-not #'(lambda (c)
346                                               (char= c #\.))
347                                           namestr :start tail-start :end tail-end))
348                         ;; Got a bunch of dots.  Make it a file of the
349                         ;; same name, and type the empty string.
350                         (values (subseq namestr tail-start (1- tail-end)) "" nil))
351                        (t
352                         (extract-name-type-and-version namestr tail-start tail-end)))))
353            ;; PVE: Make sure there are no illegal characters in the name
354            ;; such as #\Null and #\/.
355            (when (and (stringp name)
356                       (find-if #'(lambda (x)
357                                    (or (char= x #\Null) (char= x #\/)))
358                                name))
359              (error 'parse-error))
360          ;; Now we have everything we want.  So return it.          ;; Now we have everything we want.  So return it.
361          (values nil ; no host for unix namestrings.          (values nil ; no host for unix namestrings.
362                  nil ; no devices for unix namestrings.                  nil ; no devices for unix namestrings.
# Line 274  Line 367 
367                      (let ((piece-start (car piece))                      (let ((piece-start (car piece))
368                            (piece-end (cdr piece)))                            (piece-end (cdr piece)))
369                        (unless (= piece-start piece-end)                        (unless (= piece-start piece-end)
370                          (let ((dir (maybe-make-pattern namestr                          (cond ((string= namestr ".." :start1 piece-start
371                                                         piece-start                                               :end1 piece-end)
372                                                         piece-end)))                                 (dirs :up))
373                            (if (and (simple-string-p dir)                                ((string= namestr "**" :start1 piece-start
374                                     (string= dir ".."))                                          :end1 piece-end)
375                                (dirs :up)                                 (dirs :wild-inferiors))
376                                (dirs dir))))))                                (t
377                                   (dirs (maybe-make-pattern namestr
378                                                             piece-start
379                                                             piece-end)))))))
380                    (cond (absolute                    (cond (absolute
381                           (cons :absolute (dirs)))                           (cons :absolute (dirs)))
382                          ((dirs)                          ((dirs)
383                           (cons :relative (dirs)))                           ;; "." in a :relative directory is the same
384                             ;; as if it weren't there, so remove them.
385                             (cons :relative (delete "." (dirs) :test #'equal)))
386                          (t                          (t
387                           nil)))                           ;; If there is no directory and the name is
388                  name                           ;; "." and the type is NIL, we really got
389                             ;; directory ".", so make it so.
390                             (if (and (equal name ".")
391                                      (null type))
392                                 (list :relative)
393                             nil))))
394                    ;; A file with name "." and type NIL can't be the name
395                    ;; of file on Unix because it's a directory.  This was
396                    ;; handled above, so we can just set the name to nil.
397                    (if (and (equal name ".")
398                             (null type))
399                        nil
400                        name)
401                  type                  type
402                  version)))))                  version)))))
403    
404  (defun unparse-unix-host (pathname)  (defun unparse-unix-host (pathname)
405    (declare (type pathname pathname)    (declare (type pathname pathname)
406             (ignore pathname))             (ignore pathname))
407    "Unix")    ;; this host designator needs to be recognized as a physical host in
408      ;; PARSE-NAMESTRING. Until sbcl-0.7.3.x, we had "Unix" here, but
409      ;; that's a valid Logical Hostname, so that's a bad choice. -- CSR,
410      ;;
411      ;; No it isn't - in fact, I'm pretty sure "" is illegal here (and if
412      ;; it isn't, it should be - it ought to mean "the default host", from
413      ;; *default-pathname-defaults*)  -- P. Foley
414      "")
415    
416  (defun unparse-unix-piece (thing)  (defun unparse-unix-piece (thing)
417    (etypecase thing    (etypecase thing
418        ((member :wild) "*")
419        ((member :unspecific)
420         ;; CLHS 19.2.2.2.3.1 says "That is, both nil and :unspecific
421         ;; cause the component not to appear in the namestring."
422         "")
423      (simple-string      (simple-string
424       (let* ((srclen (length thing))       (if *ignore-wildcards*
425              (dstlen srclen))           thing
426         (dotimes (i srclen)           (let* ((srclen (length thing))
427           (case (schar thing i)                  (dstlen srclen))
428             ((#\* #\? #\[)             (dotimes (i srclen)
429              (incf dstlen))))               (case (schar thing i)
        (let ((result (make-string dstlen))  
              (dst 0))  
          (dotimes (src srclen)  
            (let ((char (schar thing src)))  
              (case char  
430                 ((#\* #\? #\[)                 ((#\* #\? #\[)
431                  (setf (schar result dst) #\\)                  (incf dstlen))))
432                  (incf dst)))             (let ((result (make-string dstlen))
433               (setf (schar result dst) char)                   (dst 0))
434               (incf dst)))               (dotimes (src srclen)
435           result)))                 (let ((char (schar thing src)))
436                     (case char
437                       ((#\* #\? #\[)
438                        (setf (schar result dst) #\\)
439                        (incf dst)))
440                     (setf (schar result dst) char)
441                     (incf dst)))
442                 result))))
443      (pattern      (pattern
444       (collect ((strings))       (collect ((strings))
445         (dolist (piece (pattern-pieces thing))         (dolist (piece (pattern-pieces thing))
# Line 323  Line 447 
447             (simple-string             (simple-string
448              (strings piece))              (strings piece))
449             (symbol             (symbol
450              (case piece              (ecase piece
451                (:multi-char-wild                (:multi-char-wild
452                 (strings "*"))                 (strings "*"))
453                (:single-char-wild                (:single-char-wild
454                 (strings "?"))                 (strings "?"))))
               (t  
                (error "Invalid pattern piece: ~S" piece))))  
455             (cons             (cons
456              (case (car piece)              (case (car piece)
457                (:character-set                (:character-set
458                 (strings "[")                 (strings "[")
459                 (strings (cdr piece))                 (strings (second piece))
460                 (strings "]"))                 (strings "]"))
461                (t                (t
462                 (error "Invalid pattern piece: ~S" piece))))))                 (error (intl:gettext "Invalid pattern piece: ~S") piece))))))
463         (apply #'concatenate         (apply #'concatenate
464                'simple-string                'simple-string
465                (strings))))))                (strings))))))
# Line 354  Line 476 
476                 (t                 (t
477                  (pieces "/"))))                  (pieces "/"))))
478          (:relative          (:relative
479           ;; Nothing special.           ;; Nothing special, except if we were given '(:relative).
480             (unless directory
481               (pieces "./"))
482           ))           ))
483        (dolist (dir directory)        (dolist (dir directory)
484          (typecase dir          (typecase dir
485            ((member :up)            ((member :up)
486             (pieces "../"))             (pieces "../"))
487            ((member :back)            ((member :back)
488             (error ":BACK cannot be represented in namestrings."))             (error (intl:gettext ":BACK cannot be represented in namestrings.")))
489            ((or simple-string pattern)            ((member :wild-inferiors)
490               (pieces "**/"))
491              ((or simple-string pattern (eql :wild))
492             (pieces (unparse-unix-piece dir))             (pieces (unparse-unix-piece dir))
493             (pieces "/"))             (pieces "/"))
494            (t            (t
495             (error "Invalid directory component: ~S" dir)))))             (error (intl:gettext "Invalid directory component: ~S") dir)))))
496      (apply #'concatenate 'simple-string (pieces))))      (apply #'concatenate 'simple-string (pieces))))
497    
498  (defun unparse-unix-directory (pathname)  (defun unparse-unix-directory (pathname)
499    (declare (type pathname pathname))    (declare (type pathname pathname))
500    (unparse-unix-directory-list (%pathname-directory pathname)))    (unparse-unix-directory-list (%pathname-directory pathname)))
501    
502  (defun unparse-unix-file (pathname)  (defun unparse-unix-file (pathname)
503    (declare (type pathname pathname))    (declare (type pathname pathname))
504    (collect ((strings))    (collect ((strings))
505      (let* ((name (%pathname-name pathname))      (let* ((name (%pathname-name pathname))
506             (type (%pathname-type pathname))             (type (%pathname-type pathname))
507             (type-supplied (not (or (null type) (eq type :unspecific))))             (type-supplied (not (or (null type) (eq type :unspecific))))
508               (logical-p (logical-pathname-p pathname))
509             (version (%pathname-version pathname))             (version (%pathname-version pathname))
510             (version-supplied (not (or (null version) (eq version :newest)))))             ;; Preserve version :newest for logical pathnames.
511               (version-supplied (not (or (null version)
512                                          (member version (if logical-p
513                                                              '(:unspecific)
514                                                              '(:newest
515                                                                :unspecific)))))))
516        (when name        (when name
517            (when (stringp name)
518              (when (find #\/ name)
519                (error (intl:gettext "Cannot specify a directory separator in a pathname name: ~S") name))
520              (when (and (not type-supplied)
521                         (find #\. name :start 1))
522                ;; A single leading dot is ok.
523                (error (intl:gettext "Cannot specify a dot in a pathname name without a pathname type: ~S") name))
524              (when (or (and (string= ".." name)
525                             (not type-supplied))
526                        (and (string= "." name)
527                             (not type-supplied)))
528                ;; Can't have a name of ".." or "." without a type.
529                (error (intl:gettext "Invalid value for a pathname name: ~S") name)))
530          (strings (unparse-unix-piece name)))          (strings (unparse-unix-piece name)))
531        (when type-supplied        (when type-supplied
532          (unless name          (unless name
533            (error "Cannot specify the type without a file: ~S" pathname))            (error (intl:gettext "Cannot specify the type without a file: ~S") pathname))
534            (when (stringp type)
535              (when (find #\/ type)
536                (error (intl:gettext "Cannot specify a directory separator in a pathname type: ~S") type))
537              (when (find #\. type)
538                (error (intl:gettext "Cannot specify a dot in a pathname type: ~S") type)))
539          (strings ".")          (strings ".")
540          (strings (unparse-unix-piece type)))          (strings (unparse-unix-piece type)))
541          (when (and (not (member version '(nil :newest :unspecific)))
542                     (not name))
543            ;; We don't want version without a name, because when we try
544            ;; to read #p".~*~" back, the name is "", not NIL.
545            (error (intl:gettext "Cannot specify a version without a file: ~S") pathname))
546        (when version-supplied        (when version-supplied
         (unless type-supplied  
           (error "Cannot specify the version without a type: ~S" pathname))  
547          (strings (if (eq version :wild)          (strings (if (eq version :wild)
548                       ".*"                       (if logical-p ".*" ".~*~")
549                       (format nil ".~D" version)))))                       (format nil (if logical-p ".~A" ".~~~D~~")
550      (apply #'concatenate 'simple-string (strings))))                               version)))))
551        (and (strings) (apply #'concatenate 'simple-string (strings)))))
552    
553  (defun unparse-unix-namestring (pathname)  (defun unparse-unix-namestring (pathname)
554    (declare (type pathname pathname))    (declare (type pathname pathname))
# Line 405  Line 559 
559  (defun unparse-unix-enough (pathname defaults)  (defun unparse-unix-enough (pathname defaults)
560    (declare (type pathname pathname defaults))    (declare (type pathname pathname defaults))
561    (flet ((lose ()    (flet ((lose ()
562             (error "~S cannot be represented relative to ~S"             (error (intl:gettext "~S cannot be represented relative to ~S")
563                    pathname defaults)))                    pathname defaults)))
564      (collect ((strings))      ;; Only the first path in a search-list is considered.
565        (let* ((pathname-directory (%pathname-directory pathname))      (enumerate-search-list (pathname pathname)
566               (defaults-directory (%pathname-directory defaults))        (enumerate-search-list (defaults defaults)
567               (prefix-len (length defaults-directory))          (collect ((strings))
568               (result-dir            (let* ((pathname-directory (%pathname-directory pathname))
569                (cond ((and (> prefix-len 1)                   (defaults-directory (%pathname-directory defaults))
570                            (>= (length pathname-directory) prefix-len)                   (prefix-len (length defaults-directory))
571                            (compare-component (subseq pathname-directory                   (result-dir
572                                                       0 prefix-len)                    (cond ((null pathname-directory)
573                                               defaults-directory))                           ;; No directory, so relative to default.  But
574                       ;; Pathname starts with a prefix of default.  So just                           ;; if we're relative to default, NIL is as
575                       ;; use a relative directory from then on out.                           ;; good as '(:relative) and it results in a
576                       (cons :relative (nthcdr prefix-len pathname-directory)))                           ;; shorter namestring.
577                      ((eq (car pathname-directory) :absolute)                           #+nil (list :relative)
578                       ;; We are an absolute pathname, so we can just use it.                           nil)
579                       pathname-directory)                          ((and (>= prefix-len 1)
580                      (t                                (>= (length pathname-directory) prefix-len)
581                       ;; We are a relative directory.  So we lose.                                (compare-component (subseq pathname-directory
582                       (lose)))))                                                           0 prefix-len)
583          (strings (unparse-unix-directory-list result-dir)))                                                   defaults-directory))
584        (let* ((pathname-version (%pathname-version pathname))                           ;; Pathname starts with a prefix of default,
585               (version-needed (and pathname-version                           ;; which also means both are either :relative
586                                    (not (eq pathname-version :newest))))                           ;; or :absolute directories.  So just use a
587               (pathname-type (%pathname-type pathname))                           ;; relative directory from then on out.
588               (type-needed (or version-needed                           (let ((dir-tail (nthcdr prefix-len pathname-directory)))
589                                (and pathname-type                             ;; If both directories are identical, don't
590                                     (not (eq pathname-type :unspecific)))))                             ;; return just :relative.  Returning NIL
591               (pathname-name (%pathname-name pathname))                             ;; results in a shorter string.
592               (name-needed (or type-needed                             (if dir-tail
593                                (and pathname-name                                 (cons :relative dir-tail)
594                                     (not (compare-component pathname-name                                 nil)))
595                                                             (%pathname-name                          ((and (eq (car pathname-directory) :relative)
596                                                              defaults)))))))                                (not (eq (car defaults-directory) :absolute)))
597          (when name-needed                           ;; Can't represent a relative directory
598            (unless pathname-name (lose))                           ;; relative to an absolute directory.  But
599            (strings (unparse-unix-piece pathname-name)))                           ;; there's no problem if both are relative;
600          (when type-needed                           ;; we just return our path.
601            (when (or (null pathname-type) (eq pathname-type :unspecific))                           pathname-directory)
602              (lose))                          ((eq (car pathname-directory) :absolute)
603            (strings ".")                           ;; We are an absolute pathname, so we can just use it.
604            (strings (unparse-unix-piece pathname-type)))                           pathname-directory)
605          (when version-needed                          (t
606            (typecase pathname-version                           ;; We are a relative directory.  So we lose.
607              ((member :wild)                           (lose)))))
608               (strings ".*"))              (strings (unparse-unix-directory-list result-dir)))
609              (integer            (let* ((pathname-version (%pathname-version pathname))
610               (strings (format nil ".~D" pathname-version)))                   (version-needed (and pathname-version
611              (t                                        (not (eq pathname-version :newest))))
612               (lose)))))                   (pathname-type (%pathname-type pathname))
613        (apply #'concatenate 'simple-string (strings)))))                   (type-needed (or version-needed
614                                      (and pathname-type
615                                           (not (eq pathname-type :unspecific)))))
616                     (pathname-name (%pathname-name pathname))
617                     (name-needed (or type-needed
618                                      (and pathname-name
619                                           (not (compare-component pathname-name
620                                                                   (%pathname-name
621                                                                    defaults)))))))
622                (when name-needed
623                  (unless pathname-name (lose))
624                  (strings (unparse-unix-piece pathname-name)))
625                (when type-needed
626                  (when (or (null pathname-type) (eq pathname-type :unspecific))
627                    (lose))
628                  (strings ".")
629                  (strings (unparse-unix-piece pathname-type)))
630                (when version-needed
631                  (typecase pathname-version
632                    ((member :wild)
633                     (strings ".~*~"))
634                    (integer
635                     (strings (format nil ".~~~D~~" pathname-version)))
636                    (t
637                     (lose)))))
638              (return-from unparse-unix-enough (apply #'concatenate 'simple-string (strings))))))))
639    
640    
641  (defstruct (unix-host  (defstruct (unix-host
# Line 481  Line 660 
660  ;;;; Wildcard matching stuff.  ;;;; Wildcard matching stuff.
661    
662  (defmacro enumerate-matches ((var pathname &optional result  (defmacro enumerate-matches ((var pathname &optional result
663                                    &key (verify-existance t))                                    &key (verify-existence t) (follow-links t))
664                               &body body)                               &body body)
665    (let ((body-name (gensym)))    (let ((body-name (gensym)))
666      `(block nil      `(block nil
667         (flet ((,body-name (,var)         (flet ((,body-name (,var)
668                  ,@body))                  ,@body))
669           (%enumerate-matches (pathname ,pathname)           (%enumerate-matches (pathname ,pathname)
670                               ,verify-existance                               ,verify-existence ,follow-links
671                               #',body-name)                               #',body-name)
672           ,result))))           ,result))))
673    
674  (defun %enumerate-matches (pathname verify-existance function)  (defun %enumerate-matches (pathname verify-existence follow-links function)
675    (when (pathname-type pathname)    (when (pathname-type pathname)
676      (unless (pathname-name pathname)      (unless (pathname-name pathname)
677        (error "Cannot supply a type without a name:~%  ~S" pathname)))        (error (intl:gettext "Cannot supply a type without a name:~%  ~S") pathname)))
   (when (and (integerp (pathname-version pathname))  
              (member (pathname-type pathname) '(nil :unspecific)))  
     (error "Cannot supply a version without a type:~%  ~S" pathname))  
678    (let ((directory (pathname-directory pathname)))    (let ((directory (pathname-directory pathname)))
679      (if directory      (if directory
680          (ecase (car directory)          (ecase (car directory)
681            (:absolute            (:absolute
682             (%enumerate-directories "/" (cdr directory) pathname             (%enumerate-directories "/" (cdr directory) pathname
683                                     verify-existance function))                                     verify-existence follow-links
684                                       nil function))
685            (:relative            (:relative
686             (%enumerate-directories "" (cdr directory) pathname             (%enumerate-directories "" (cdr directory) pathname
687                                     verify-existance function)))                                     verify-existence follow-links
688          (%enumerate-files "" pathname verify-existance function))))                                     nil function)))
689            (%enumerate-files "" pathname verify-existence function))))
690  (defun %enumerate-directories (head tail pathname verify-existance function)  
691    (if tail  ;;; %enumerate-directories  --   Internal
692        (let ((piece (car tail)))  ;;;
693          (etypecase piece  ;;; The directory node and device numbers are maintained for the current path
694            (simple-string  ;;; during the search for the detection of path loops upon :wild-inferiors.
695             (%enumerate-directories (concatenate 'string head piece "/")  ;;;
696                                     (cdr tail) pathname verify-existance  (defun %enumerate-directories (head tail pathname verify-existence
697                                     function))                                 follow-links nodes function)
698            (pattern    (declare (simple-string head))
699             (let ((dir (unix:open-dir head)))    (macrolet ((unix-xstat (name)
700               (when dir                 `(if follow-links
701                 (unwind-protect                      (unix:unix-stat ,name)
702                     (loop                      (unix:unix-lstat ,name)))
703                       (let ((name (unix:read-dir dir)))               (with-directory-node-noted ((head) &body body)
704                         (cond ((null name)                 `(multiple-value-bind (res dev ino mode)
705                                (return))                      (unix-xstat ,head)
706                               ((string= name "."))                    (when (and res (eql (logand mode unix:s-ifmt) unix:s-ifdir))
707                               ((string= name ".."))                      (let ((nodes (cons (cons dev ino) nodes)))
708                               ((pattern-matches piece name)                        ,@body))))
709                                (let ((subdir (concatenate 'string               (do-directory-entries ((name directory) &body body)
710                                                           head name "/")))                 `(let ((dir (unix:open-dir ,directory)))
711                                  (when (eq (unix:unix-file-kind subdir)                    (when dir
712                                            :directory)                      (unwind-protect
713                                    (%enumerate-directories                           (loop
714                                     subdir (cdr tail) pathname verify-existance                            (let ((,name (unix:read-dir dir)))
715                                     function)))))))                              (cond ((null ,name)
716                   (unix:close-dir dir)))))                                     (return))
717            ((member :up)                                    ((string= ,name "."))
718             (%enumerate-directories (concatenate 'string head "../")                                    ((string= ,name ".."))
719                                     (cdr tail) pathname verify-existance                                    (t
720                                     function))))                                     ,@body))))
721        (%enumerate-files head pathname verify-existance function)))                        (unix:close-dir dir))))))
722        (if tail
723  (defun %enumerate-files (directory pathname verify-existance function)          (let ((piece (car tail)))
724    (let ((name (pathname-name pathname))            (etypecase piece
725          (type (pathname-type pathname))              (simple-string
726          (version (pathname-version pathname)))               (let ((head (concatenate 'string head piece)))
727      (cond ((null name)                 (with-directory-node-noted (head)
728             (when (or (not verify-existance)                   (%enumerate-directories (concatenate 'string head "/")
729                                             (cdr tail) pathname
730                                             verify-existence follow-links
731                                             nodes function))))
732                ((member :wild-inferiors)
733                 (%enumerate-directories head (rest tail) pathname
734                                         verify-existence follow-links
735                                         nodes function)
736                 (do-directory-entries (name head)
737                   (let ((subdir (concatenate 'string head name)))
738                     (multiple-value-bind (res dev ino mode)
739                         (unix-xstat subdir)
740                       (declare (type (or fixnum null) mode))
741                       (when (and res (eql (logand mode unix:s-ifmt) unix:s-ifdir))
742                         (unless (dolist (dir nodes nil)
743                                   (when (and (eql (car dir) dev)
744                                              (eql (cdr dir) ino))
745                                     (return t)))
746                           (let ((nodes (cons (cons dev ino) nodes))
747                                 (subdir (concatenate 'string subdir "/")))
748                             (%enumerate-directories subdir tail pathname
749                                                     verify-existence follow-links
750                                                     nodes function))))))))
751                ((or pattern (member :wild))
752                 (do-directory-entries (name head)
753                   (when (or (eq piece :wild) (pattern-matches piece name))
754                     (let ((subdir (concatenate 'string head name)))
755                       (multiple-value-bind (res dev ino mode)
756                           (unix-xstat subdir)
757                         (declare (type (or fixnum null) mode))
758                         (when (and res
759                                    (eql (logand mode unix:s-ifmt) unix:s-ifdir))
760                           (let ((nodes (cons (cons dev ino) nodes))
761                                 (subdir (concatenate 'string subdir "/")))
762                             (%enumerate-directories subdir (rest tail) pathname
763                                                     verify-existence follow-links
764                                                     nodes function))))))))
765                ((member :up)
766                 (let ((head (concatenate 'string head "..")))
767                   (with-directory-node-noted (head)
768                     (%enumerate-directories (concatenate 'string head "/")
769                                             (rest tail) pathname
770                                             verify-existence follow-links
771                                             nodes function))))))
772            (%enumerate-files head pathname verify-existence function))))
773    
774    (defun %enumerate-files (directory pathname verify-existence function)
775      (declare (simple-string directory))
776      (let ((name (%pathname-name pathname))
777            (type (%pathname-type pathname))
778            (version (%pathname-version pathname)))
779        (cond ((member name '(nil :unspecific))
780               (when (or (not verify-existence)
781                       (unix:unix-file-kind directory))                       (unix:unix-file-kind directory))
782               (funcall function directory)))               (funcall function directory)))
783            ((or (pattern-p name)            ((or (pattern-p name)
784                 (pattern-p type)                 (pattern-p type)
785                   (eq name :wild)
786                   (eq type :wild)
787                 (eq version :wild))                 (eq version :wild))
788             (let ((dir (unix:open-dir directory)))             (let ((dir (unix:open-dir directory)))
789               (when dir               (when dir
# Line 567  Line 798 
798                                   (let ((*ignore-wildcards* t))                                   (let ((*ignore-wildcards* t))
799                                     (extract-name-type-and-version                                     (extract-name-type-and-version
800                                      file 0 (length file)))                                      file 0 (length file)))
801                                   ;; Match also happens if the file has
802                                   ;; no explicit version and we're asking
803                                   ;; for version :NEWEST, since that's
804                                   ;; what no version means.
805                                 (when (and (components-match file-name name)                                 (when (and (components-match file-name name)
806                                            (components-match file-type type)                                            (components-match file-type type)
807                                            (components-match file-version                                            (or (components-match file-version
808                                                              version))                                                                  version)
809                                                  (and (eq file-version nil)
810                                                       (eq version :newest))))
811                                   (funcall function                                   (funcall function
812                                            (concatenate 'string                                            (concatenate 'string
813                                                         directory                                                         directory
# Line 581  Line 818 
818             (let ((file (concatenate 'string directory name)))             (let ((file (concatenate 'string directory name)))
819               (unless (or (null type) (eq type :unspecific))               (unless (or (null type) (eq type :unspecific))
820                 (setf file (concatenate 'string file "." type)))                 (setf file (concatenate 'string file "." type)))
821               (unless (or (null version) (eq version :newest))               (unless (member version '(nil :newest :wild :unspecific))
822                 (setf file (concatenate 'string file "."                 (setf file (concatenate 'string file ".~"
823                                         (quick-integer-to-string version))))                                         (quick-integer-to-string version)
824               (when (or (not verify-existance)                                         "~")))
825                         (unix:unix-file-kind file))               (when (or (not verify-existence)
826                           (unix:unix-file-kind file t))
827                 (funcall function file)))))))                 (funcall function file)))))))
828    
829  (defun quick-integer-to-string (n)  (defun quick-integer-to-string (n)
830    (declare (type integer n))    (declare (type integer n))
831    (cond ((zerop n) "0")    (cond ((not (fixnump n))
832             (write-to-string n :base 10 :radix nil))
833            ((zerop n) "0")
834          ((eql n 1) "1")          ((eql n 1) "1")
835          ((minusp n)          ((minusp n)
836           (concatenate 'simple-string "-"           (concatenate 'simple-string "-"
# Line 606  Line 846 
846                 (replace res res :start2 i :end2 len)                 (replace res res :start2 i :end2 len)
847                 (shrink-vector res (- len i)))                 (shrink-vector res (- len i)))
848             (declare (simple-string res)             (declare (simple-string res)
849                      (fixnum len i r))                      (fixnum len i r q))
850             (multiple-value-setq (q r) (truncate q 10))             (multiple-value-setq (q r) (truncate q 10))
851             (setf (schar res i) (schar "0123456789" r))))))             (setf (schar res i) (schar "0123456789" r))))))
852    
853    
854  ;;;; UNIX-NAMESTRING -- public  ;;;; UNIX-NAMESTRING -- public
855  ;;;  ;;;
856  (defun unix-namestring (pathname &optional (for-input t))  (defun unix-namestring (pathname &optional (for-input t) executable-only)
857    "Convert PATHNAME into a string that can be used with UNIX system calls.    "Convert PATHNAME into a string that can be used with UNIX system calls.
858     Search-lists and wild-cards are expanded."     Search-lists and wild-cards are expanded. If optional argument
859       FOR-INPUT is true and PATHNAME doesn't exist, NIL is returned.
860       If optional argument EXECUTABLE-ONLY is true, NIL is returned
861       unless an executable version of PATHNAME exists."
862      ;; toy@rtp.ericsson.se: Let unix-namestring also handle logical
863      ;; pathnames too.
864      (let ((path (let ((lpn (pathname pathname)))
865                    (if (logical-pathname-p lpn)
866                        (namestring (translate-logical-pathname lpn))
867                        pathname))))
868    (enumerate-search-list    (enumerate-search-list
869        (pathname pathname)        (pathname path)
870      (collect ((names))      (collect ((names))
871        (enumerate-matches (name pathname nil :verify-existance for-input)        (enumerate-matches (name pathname nil :verify-existence for-input
872          (names name))                                 :follow-links t)
873            (when (or (not executable-only)
874                      (and (eq (unix:unix-file-kind name) :file)
875                           (unix:unix-access name unix:x_ok)))
876              (names name)))
877        (let ((names (names)))        (let ((names (names)))
878          (when names          (when names
879            (when (cdr names)            (when (cdr names)
880              (error "~S is ambiguous:~{~%  ~A~}" pathname names))              (error 'simple-file-error
881            (return (car names)))))))                     :format-control (intl:gettext "~S is ambiguous:~{~%  ~A~}")
882                       :format-arguments (list pathname names)))
883              (return (car names))))))))
884    
885    
886  ;;;; TRUENAME and PROBE-FILE.  ;;;; TRUENAME and PROBE-FILE.
# Line 636  Line 891 
891  ;;;  ;;;
892  (defun truename (pathname)  (defun truename (pathname)
893    "Return the pathname for the actual file described by the pathname    "Return the pathname for the actual file described by the pathname
894    An error is signalled if no such file exists."    An error of type file-error is signalled if no such file exists,
895    (let ((result (probe-file pathname)))    or the pathname is wild."
896      (unless result    (if (wild-pathname-p pathname)
897        (error "The file ~S does not exist." (namestring pathname)))        (error 'simple-file-error
898      result))               :format-control (intl:gettext "Bad place for a wild pathname.")
899                 :pathname pathname)
900          (let ((result (probe-file pathname)))
901            (unless result
902              (error 'simple-file-error
903                     :pathname pathname
904                     :format-control (intl:gettext "The file ~S does not exist.")
905                     :format-arguments (list (namestring pathname))))
906            result)))
907    
908  ;;; Probe-File  --  Public  ;;; Probe-File  --  Public
909  ;;;  ;;;
910  ;;; If PATHNAME exists, return it's truename, otherwise NIL.  ;;; If PATHNAME exists, return its truename, otherwise NIL.
911  ;;;  ;;;
912  (defun probe-file (pathname)  (defun probe-file (pathname)
913    "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
914    otherwise."    otherwise. An error of type file-error is signalled if pathname is wild."
915    (let ((namestring (unix-namestring pathname t)))    (if (wild-pathname-p pathname)
916      (when (and namestring (unix:unix-file-kind namestring))        (error 'simple-file-error
917        (let ((truename (unix:unix-resolve-links               :pathname pathname
918                         (unix:unix-maybe-prepend-current-directory               :format-control (intl:gettext "Bad place for a wild pathname."))
919                          namestring))))        (let ((namestring (unix-namestring (merge-pathnames pathname) t)))
920          (when truename          (when (and namestring (unix:unix-file-kind namestring))
921            (let ((*ignore-wildcards* t))            (let ((truename (unix:unix-resolve-links
922              (pathname (unix:unix-simplify-pathname truename))))))))                             (unix:unix-maybe-prepend-current-directory
923                                namestring))))
924                (when truename
925                  (let ((*ignore-wildcards* t))
926                    (pathname (unix:unix-simplify-pathname truename)))))))))
927    
928    
929  ;;;; Other random operations.  ;;;; Other random operations.
# Line 665  Line 932 
932  ;;;  ;;;
933  (defun rename-file (file new-name)  (defun rename-file (file new-name)
934    "Rename File to have the specified New-Name.  If file is a stream open to a    "Rename File to have the specified New-Name.  If file is a stream open to a
935    file, then the associated file is renamed.  If the file does not yet exist    file, then the associated file is renamed."
   then the file is created with the New-Name when the stream is closed."  
936    (let* ((original (truename file))    (let* ((original (truename file))
937           (original-namestring (unix-namestring original t))           (original-namestring (unix-namestring original t))
938           (new-name (merge-pathnames new-name original))           (new-name (merge-pathnames new-name file))
939           (new-namestring (unix-namestring new-name nil)))           (new-namestring (unix-namestring new-name nil)))
     (unless original-namestring  
       (error "~S doesn't exist." file))  
940      (unless new-namestring      (unless new-namestring
941        (error "~S can't be created." new-name))        (error 'simple-file-error
942                 :pathname new-name
943                 :format-control (intl:gettext "~S can't be created.")
944                 :format-arguments (list new-name)))
945      (multiple-value-bind (res error)      (multiple-value-bind (res error)
946                           (unix:unix-rename original-namestring                           (unix:unix-rename original-namestring
947                                             new-namestring)                                             new-namestring)
948        (unless res        (unless res
949          (error "Failed to rename ~A to ~A: ~A"          (error 'simple-file-error
950                 original new-name (unix:get-unix-error-msg error)))                 :pathname new-name
951                   :format-control (intl:gettext "Failed to rename ~A to ~A: ~A")
952                   :format-arguments (list original new-name
953                                           (unix:get-unix-error-msg error))))
954        (when (streamp file)        (when (streamp file)
955          (file-name file new-namestring))          (file-name file new-namestring))
956        (values new-name original (truename new-name)))))        (values new-name original (truename new-name)))))
# Line 691  Line 961 
961  ;;;  ;;;
962  (defun delete-file (file)  (defun delete-file (file)
963    "Delete the specified file."    "Delete the specified file."
964    (let ((namestring (unix-namestring file t)))    (let ((namestring (unix-namestring (merge-pathnames file) t)))
965      (when (streamp file)      (when (streamp file)
966        (close file :abort t))        ;; Close the file, but don't try to revert or anything.  We want
967          ;; to delete it, man!
968          (close file))
969      (unless namestring      (unless namestring
970        (error "~S doesn't exist." file))        (error 'simple-file-error
971                 :pathname file
972                 :format-control (intl:gettext "~S doesn't exist.")
973                 :format-arguments (list file)))
974    
975      (multiple-value-bind (res err) (unix:unix-unlink namestring)      (multiple-value-bind (res err) (unix:unix-unlink namestring)
976        (unless res        (unless res
977          (error "Could not delete ~A: ~A."          (error 'simple-file-error
978                 namestring                 :pathname namestring
979                 (unix:get-unix-error-msg err)))))                 :format-control (intl:gettext "Could not delete ~A: ~A.")
980                   :format-arguments (list namestring
981                                           (unix:get-unix-error-msg err))))))
982    t)    t)
983    
984    ;;; Purge-Backup-Files  --  Public
985    ;;;
986    ;;;    Purge old file versions
987    ;;;
988    (defun purge-backup-files (pathname &optional (keep 0))
989      "Delete old versions of files matching the given Pathname,
990    optionally keeping some of the most recent old versions."
991      (declare (type (or pathname string stream) pathname)
992               (type (integer 0 *) keep))
993      (let ((hash (make-hash-table :test 'equal)))
994        (enumerate-search-list
995            (path (make-pathname :version :wild :defaults pathname))
996          (clrhash hash)
997          (enumerate-matches (name path nil :follow-links nil)
998            (let ((dot (position #\. name :from-end t))
999                  (len (length name)))
1000              (when (and dot
1001                         (> len (+ dot 3))
1002                         (char= (char name (1+ dot)) #\~)
1003                         (char= (char name (1- len)) #\~)
1004                         (eq (unix:unix-file-kind name) :file))
1005                (multiple-value-bind (version next)
1006                    (parse-integer name :start (+ dot 2) :end (1- len)
1007                                   :junk-allowed t)
1008                  (when (and version (= next (1- len)))
1009                    (push (cons version name)
1010                          (gethash (subseq name 0 dot) hash '())))))))
1011          (maphash (lambda (key value)
1012                     (declare (ignore key))
1013                     (mapc #'unix:unix-unlink
1014                           (mapcar #'cdr (nthcdr keep
1015                                                 (sort value #'> :key #'car)))))
1016                   hash))))
1017    
1018    
1019  ;;; User-Homedir-Pathname  --  Public  ;;; User-Homedir-Pathname  --  Public
1020  ;;;  ;;;
# Line 718  Line 1029 
1029  ;;; File-Write-Date  --  Public  ;;; File-Write-Date  --  Public
1030  ;;;  ;;;
1031  (defun file-write-date (file)  (defun file-write-date (file)
1032    "Return file's creation date, or NIL if it doesn't exist."    "Return file's creation date, or NIL if it doesn't exist.
1033    (let ((name (unix-namestring file t)))   An error of type file-error is signalled if file is a wild pathname"
1034      (when name    (if (wild-pathname-p file)
1035        (multiple-value-bind        (error 'simple-file-error
1036            (res dev ino mode nlink uid gid rdev size atime mtime)               :pathname file
1037            (unix:unix-stat name)               :format-control (intl:gettext "Bad place for a wild pathname."))
1038          (declare (ignore dev ino mode nlink uid gid rdev size atime))        (let ((name (unix-namestring (merge-pathnames file) t)))
1039          (when res          (when name
1040            (+ unix-to-universal-time mtime))))))            (multiple-value-bind
1041                  (res dev ino mode nlink uid gid rdev size atime mtime)
1042                  (unix:unix-stat name)
1043                (declare (ignore dev ino mode nlink uid gid rdev size atime))
1044                (when res
1045                  (+ unix-to-universal-time mtime)))))))
1046    
1047  ;;; File-Author  --  Public  ;;; File-Author  --  Public
1048  ;;;  ;;;
1049  (defun file-author (file)  (defun file-author (file)
1050    "Returns the file author as a string, or nil if the author cannot be    "Returns the file author as a string, or nil if the author cannot be
1051     determined.  Signals an error if file doesn't exist."   determined.  Signals an error of type file-error if file doesn't exist,
1052    (let ((name (unix-namestring (pathname file) t)))   or file is a wild pathname."
1053      (unless name    (if (wild-pathname-p file)
1054        (error "~S doesn't exist." file))        (error 'simple-file-error
1055      (multiple-value-bind (winp dev ino mode nlink uid)               :pathname file
1056                           (unix:unix-stat file)               :format-control (intl:gettext "Bad place for a wild pathname."))
1057        (declare (ignore dev ino mode nlink))        (let ((name (unix-namestring (merge-pathnames file) t)))
1058        (if winp (lookup-login-name uid)))))          (unless name
1059              (error 'simple-file-error
1060                     :pathname file
1061                     :format-control (intl:gettext "~S doesn't exist.")
1062                     :format-arguments (list file)))
1063            (multiple-value-bind (winp dev ino mode nlink uid)
1064                                 (unix:unix-stat name)
1065              (declare (ignore dev ino mode nlink))
1066              (when winp
1067                (let ((user-info (unix:unix-getpwuid uid)))
1068                  (when user-info
1069                    (unix:user-info-name user-info))))))))
1070    
1071    
1072  ;;;; DIRECTORY.  ;;;; DIRECTORY.
1073    
1074  ;;; DIRECTORY  --  public.  ;;; DIRECTORY  --  public.
1075  ;;;  ;;;
1076  (defun directory (pathname &key (all t) (check-for-subdirs t)  (defun directory (pathname &key (all t) (check-for-subdirs t)
1077                             (follow-links t))                    (truenamep t) (follow-links t))
1078    "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
1079     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
1080     never includes Unix dot and dot-dot in the result.  If :FOLLOW-LINKS is NIL,     never includes Unix dot and dot-dot in the result.  If :TRUENAMEP is NIL,
1081     then symblolic links in the result are not expanded.  This is not the     then symbolic links in the result are not expanded, which is not the
1082     default because TRUENAME does follow links, and the result pathnames are     default because TRUENAME does follow links and the result pathnames are
1083     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
1084     be in another directory.)"     be in another directory).  If FOLLOW-LINKS is NIL then symbolic links are
1085    (let ((results nil))     not followed."
1086      (enumerate-search-list    (flet ((ordered-strings-remove-duplicates (list)
1087          (pathname (merge-pathnames pathname             (let ((results '())
1088                                     (make-pathname :name :wild                   (prev nil))
1089                                                    :type :wild               (dolist (elem list)
1090                                                    :version :wild)))                 (when (or (null prev)
1091        (enumerate-matches (name pathname)                           (not (string= elem prev)))
1092          (when (or all                   (push elem results))
1093                    (let ((slash (position #\/ name :from-end t)))                 (setf prev elem))
1094                      (or (null slash)               (nreverse results))))
1095                          (= (1+ slash) (length name))      (let ((results nil))
1096                          (char/= (schar name (1+ slash)) #\.))))        (enumerate-search-list
1097            (push name results))))            (pathname (merge-pathnames pathname
1098      (let ((*ignore-wildcards* t))                                       (make-pathname :name :wild
1099        (mapcar #'(lambda (name)                                                      :type :wild
1100                    (let ((name (if (and check-for-subdirs                                                      :version :wild
1101                                         (eq (unix:unix-file-kind name)                                                      :defaults *default-pathname-defaults*)
1102                                             :directory))                                       :wild))
1103                                    (concatenate 'string name "/")          (enumerate-matches (name pathname nil :follow-links follow-links)
1104                                    name)))            (when (or all
1105                      (if follow-links (truename name) (pathname name))))                      (let ((slash (position #\/ name :from-end t)))
1106                (sort (delete-duplicates results :test #'string=) #'string<)))))                        (or (null slash)
1107                              (= (1+ slash) (length name))
1108                              (char/= (schar name (1+ slash)) #\.))))
1109                (push name results))))
1110          (let ((*ignore-wildcards* t))
1111            (mapcar #'(lambda (name)
1112                        (let ((name (if (and check-for-subdirs
1113                                             (eq (unix:unix-file-kind name)
1114                                                 :directory))
1115                                        (concatenate 'string name "/")
1116                                        name)))
1117                          (if truenamep (truename name) (pathname name))))
1118                    (ordered-strings-remove-duplicates (sort results #'string<)))))))
1119    
1120    
1121    
1122  ;;;; Printing directories.  ;;;; Printing directories.
# Line 785  Line 1124 
1124  ;;; PRINT-DIRECTORY is exported from the EXTENSIONS package.  ;;; PRINT-DIRECTORY is exported from the EXTENSIONS package.
1125  ;;;  ;;;
1126  (defun print-directory (pathname &optional stream &key all verbose return-list)  (defun print-directory (pathname &optional stream &key all verbose return-list)
1127    "Like Directory, but prints a terse, multi-coloumn directory listing    "Like Directory, but prints a terse, multi-column directory listing
1128     instead of returning a list of pathnames.  When :all is supplied and     instead of returning a list of pathnames.  When :all is supplied and
1129     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
1130     is supplied and non-nil, then a long listing of miscellaneous     is supplied and non-nil, then a long listing of miscellaneous
1131     information is output one file per line."     information is output one file per line."
1132    (let ((*standard-output* (out-synonym-of stream))    (let ((*standard-output* (out-synonym-of stream))
# Line 798  Line 1137 
1137    
1138  (defun print-directory-verbose (pathname all return-list)  (defun print-directory-verbose (pathname all return-list)
1139    (let ((contents (directory pathname :all all :check-for-subdirs nil    (let ((contents (directory pathname :all all :check-for-subdirs nil
1140                               :follow-links nil))                               :truenamep nil))
1141          (result nil))          (result nil))
1142      (format t "Directory of ~A :~%" (namestring pathname))      (format t (intl:gettext "Directory of ~A:~%") (namestring pathname))
1143      (dolist (file contents)      (dolist (file contents)
1144        (let* ((namestring (unix-namestring file))        (let* ((namestring (unix-namestring file))
1145               (tail (subseq namestring               (tail (subseq namestring
# Line 843  Line 1182 
1182                     (declare (ignore sec min hour date month))                     (declare (ignore sec min hour date month))
1183                     (format t "~2D ~8A ~8D ~12A ~A~@[/~]~%"                     (format t "~2D ~8A ~8D ~12A ~A~@[/~]~%"
1184                             nlink                             nlink
1185                             (or (lookup-login-name uid) uid)                             (let ((user-info (unix:unix-getpwuid uid)))
1186                                 (if user-info (unix:user-info-name user-info) uid))
1187                             size                             size
1188                             (decode-universal-time-for-files mtime year)                             (decode-universal-time-for-files mtime year)
1189                             tail                             tail
1190                             (= (logand mode unix::s_ifmt) unix::s_ifdir))))                             (= (logand mode unix:s-ifmt) unix:s-ifdir))))
1191                  (t (format t "Couldn't stat ~A -- ~A.~%"                  (t (format t (intl:gettext "Couldn't stat ~A -- ~A.~%")
1192                             tail                             tail
1193                             (unix:get-unix-error-msg dev-or-err))))                             (unix:get-unix-error-msg dev-or-err))))
1194            (when return-list            (when return-list
1195              (push (if (= (logand mode unix::s_ifmt) unix::s_ifdir)              (push (if (= (logand mode unix:s-ifmt) unix:s-ifdir)
1196                        (pathname (concatenate 'string namestring "/"))                        (pathname (concatenate 'string namestring "/"))
1197                        file)                        file)
1198                    result)))))                    result)))))
# Line 873  Line 1213 
1213          (names ())          (names ())
1214          (cnt 0)          (cnt 0)
1215          (max-len 0)          (max-len 0)
1216          (result (directory pathname :all all :follow-links nil)))          (result (directory pathname :all all :truenamep nil)))
1217      (declare (list names) (fixnum max-len cnt))      (declare (list names) (fixnum max-len cnt))
1218      ;;      ;;
1219      ;; Get the data.      ;; Get the data.
# Line 903  Line 1243 
1243             (cols (max (truncate width col-width) 1))             (cols (max (truncate width col-width) 1))
1244             (lines (ceiling cnt cols)))             (lines (ceiling cnt cols)))
1245        (declare (fixnum cols lines))        (declare (fixnum cols lines))
1246        (format t "Directory of ~A :~%" (namestring pathname))        (format t (intl:gettext "Directory of ~A:~%") (namestring pathname))
1247        (dotimes (i lines)        (dotimes (i lines)
1248          (declare (fixnum i))          (declare (fixnum i))
1249          (dotimes (j cols)          (dotimes (j cols)
# Line 918  Line 1258 
1258      (when return-list      (when return-list
1259        result)))        result)))
1260    
   
   
 ;;;; Translating uid's and gid's.  
   
 (defvar *uid-hash-table* (make-hash-table)  
   "Hash table for keeping track of uid's and login names.")  
   
 ;;; LOOKUP-LOGIN-NAME translates a user id into a login name.  Previous  
 ;;; lookups are cached in a hash table since groveling the passwd(s) files  
 ;;; is somewhat expensive.  The table may hold nil for id's that cannot  
 ;;; be looked up since this means the files are searched in their entirety  
 ;;; each time this id is translated.  
 ;;;  
 (defun lookup-login-name (uid)  
   (multiple-value-bind (login-name foundp) (gethash uid *uid-hash-table*)  
     (if foundp  
         login-name  
         (setf (gethash uid *uid-hash-table*)  
               (get-group-or-user-name :user uid)))))  
   
 (defvar *gid-hash-table* (make-hash-table)  
   "Hash table for keeping track of gid's and group names.")  
   
 ;;; LOOKUP-GROUP-NAME translates a group id into a group name.  Previous  
 ;;; lookups are cached in a hash table since groveling the group(s) files  
 ;;; is somewhat expensive.  The table may hold nil for id's that cannot  
 ;;; be looked up since this means the files are searched in their entirety  
 ;;; each time this id is translated.  
 ;;;  
 (defun lookup-group-name (gid)  
   (multiple-value-bind (group-name foundp) (gethash gid *gid-hash-table*)  
     (if foundp  
         group-name  
         (setf (gethash gid *gid-hash-table*)  
               (get-group-or-user-name :group gid)))))  
   
   
 ;;; GET-GROUP-OR-USER-NAME first tries "/etc/passwd" ("/etc/group") since it is  
 ;;; a much smaller file, contains all the local id's, and most uses probably  
 ;;; involve id's on machines one would login into.  Then if necessary, we look  
 ;;; in "/etc/passwds" ("/etc/groups") which is really long and has to be  
 ;;; fetched over the net.  
 ;;;  
 (defun get-group-or-user-name (group-or-user id)  
   "Returns the simple-string user or group name of the user whose uid or gid  
    is id, or NIL if no such user or group exists.  Group-or-user is either  
    :group or :user."  
   (let ((id-string (let ((*print-base* 10)) (prin1-to-string id))))  
     (declare (simple-string id-string))  
     (multiple-value-bind (file1 file2)  
                          (ecase group-or-user  
                            (:group (values "/etc/group" "/etc/groups"))  
                            (:user (values "/etc/passwd" "/etc/passwd")))  
       (or (get-group-or-user-name-aux id-string file1)  
           (get-group-or-user-name-aux id-string file2)))))  
   
 (defun get-group-or-user-name-aux (id-string passwd-file)  
   (with-open-file (stream passwd-file)  
     (loop  
       (let ((entry (read-line stream nil)))  
         (unless entry (return nil))  
         (let ((name-end (position #\: (the simple-string entry)  
                                   :test #'char=)))  
           (when name-end  
             (let ((id-start (position #\: (the simple-string entry)  
                                       :start (1+ name-end) :test #'char=)))  
               (when id-start  
                 (incf id-start)  
                 (let ((id-end (position #\: (the simple-string entry)  
                                         :start id-start :test #'char=)))  
                   (when (and id-end  
                              (string= id-string entry  
                                       :start2 id-start :end2 id-end))  
                     (return (subseq entry 0 name-end))))))))))))  
   
1261    
1262  ;;;; File completion.  ;;;; File completion.
1263    
# Line 1002  Line 1267 
1267                                 ignore-types)                                 ignore-types)
1268    (let ((files (directory (complete-file-directory-arg pathname defaults)    (let ((files (directory (complete-file-directory-arg pathname defaults)
1269                            :check-for-subdirs nil                            :check-for-subdirs nil
1270                            :follow-links nil)))                            :truenamep nil)))
1271      (cond ((null files)      (cond ((null files)
1272             (values nil nil))             (values nil nil))
1273            ((null (cdr files))            ((null (cdr files))
# Line 1070  Line 1335 
1335     We look in the directory specified by Defaults as well as looking down     We look in the directory specified by Defaults as well as looking down
1336     the search list."     the search list."
1337    (directory (complete-file-directory-arg pathname defaults)    (directory (complete-file-directory-arg pathname defaults)
1338               :follow-links nil               :truenamep nil
1339               :check-for-subdirs nil))               :check-for-subdirs nil))
1340    
1341    
# Line 1078  Line 1343 
1343  ;;; File-writable -- exported from extensions.  ;;; File-writable -- exported from extensions.
1344  ;;;  ;;;
1345  ;;;   Determines whether the single argument (which should be a pathname)  ;;;   Determines whether the single argument (which should be a pathname)
1346  ;;;   can be written by the the current task.  ;;;   can be written by the current task.
1347  ;;;  ;;;
1348  (defun file-writable (name)  (defun file-writable (name)
1349    "File-writable accepts a pathname and returns T if the current    "File-writable accepts a pathname and returns T if the current
# Line 1120  Line 1385 
1385    a file will be written if no directory is specified.  This may be changed    a file will be written if no directory is specified.  This may be changed
1386    with setf."    with setf."
1387    (multiple-value-bind (gr dir-or-error)    (multiple-value-bind (gr dir-or-error)
1388                         (unix:unix-current-directory)        (unix:unix-current-directory)
1389      (if gr      (if gr
1390          (let ((*ignore-wildcards* t))          (let ((*ignore-wildcards* t))
1391            (pathname (concatenate 'simple-string dir-or-error "/")))            (values
1392          (error dir-or-error))))             (parse-namestring (concatenate 'simple-string dir-or-error "/")
1393                                 *unix-host*)))
1394            (error dir-or-error))))
1395    
1396  ;;; %Set-Default-Directory  --  Internal  ;;; %Set-Default-Directory  --  Internal
1397  ;;;  ;;;
1398  (defun %set-default-directory (new-val)  (defun %set-default-directory (new-val)
1399    (let ((namestring (unix-namestring new-val t)))    (let ((namestring (unix-namestring new-val t)))
1400      (unless namestring      (unless namestring
1401        (error "~S doesn't exist." new-val))        (error 'simple-file-error
1402                 :format-control (intl:gettext "~S doesn't exist.")
1403                 :format-arguments (list new-val)))
1404      (multiple-value-bind (gr error)      (multiple-value-bind (gr error)
1405                           (unix:unix-chdir namestring)                           (unix:unix-chdir namestring)
1406        (if gr        (if gr
# Line 1142  Line 1411 
1411  (defsetf default-directory %set-default-directory)  (defsetf default-directory %set-default-directory)
1412    
1413  (defun filesys-init ()  (defun filesys-init ()
1414      ;; Use :unspecific so we don't create file versions whenever merging
1415      ;; happens.  If the user wants that, let him change
1416      ;; *default-pathname-defaults* appropriately.
1417    (setf *default-pathname-defaults*    (setf *default-pathname-defaults*
1418          (%make-pathname *unix-host* nil nil nil nil :newest))          (%make-pathname *unix-host* nil nil nil nil :unspecific))
1419    (setf (search-list "default:") (default-directory))    (setf (search-list "default:") (default-directory))
1420    nil)    nil)
1421    
1422    ;;; Ensure-Directories-Exist  --  Public
1423    ;;;
1424    (defun ensure-directories-exist (pathspec &key verbose (mode #o777))
1425      "Tests whether the directories containing the specified file
1426      actually exist, and attempts to create them if they do not.
1427      Portable programs should avoid using the :MODE keyword argument."
1428      (let* ((pathname (merge-pathnames pathspec))
1429             (pathname (if (logical-pathname-p pathname)
1430                           (translate-logical-pathname pathname)
1431                           pathname))
1432             (created-p nil))
1433        (when (wild-pathname-p pathname)
1434          (error 'simple-file-error
1435                 :format-control (intl:gettext "Bad place for a wild pathname.")
1436                 :pathname pathspec))
1437        (enumerate-search-list (pathname pathname)
1438           (let ((dir (pathname-directory pathname)))
1439             (loop for i from 1 upto (length dir)
1440                   do (let ((newpath (make-pathname
1441                                      :host (pathname-host pathname)
1442                                      :device (pathname-device pathname)
1443                                      :directory (subseq dir 0 i))))
1444                        (tagbody
1445                         retry
1446                           (restart-case
1447                               (unless (probe-file newpath)
1448                                 (let ((namestring (namestring newpath)))
1449                                   (when verbose
1450                                     (format *standard-output* (intl:gettext "~&Creating directory: ~A~%")
1451                                             namestring))
1452                                   (unix:unix-mkdir namestring mode)
1453                                   (unless (probe-file namestring)
1454                                     (error 'simple-file-error
1455                                            :pathname pathspec
1456                                            :format-control (intl:gettext "Can't create directory ~A.")
1457                                            :format-arguments (list namestring)))
1458                                   (setf created-p t)))
1459                             (retry () :report "Try to create the directory again"
1460                                    (go retry))))))
1461             ;; Only the first path in a search-list is considered.
1462             (return (values pathname created-p))))))

Legend:
Removed from v.1.25.1.1  
changed lines
  Added in v.1.114

  ViewVC Help
Powered by ViewVC 1.1.5