/[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.43.2.6 by pw, Sat Mar 23 18:49:59 2002 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 177  Line 184 
184             (type index start end))             (type index start end))
185    (labels    (labels
186        ((explicit-version (namestr start end)        ((explicit-version (namestr start end)
187           (cond ((or (< (- end start) 5)           ;; Look for something like "~*~" at the end of the
188                      (char/= (schar namestr (1- end)) #\~))           ;; namestring, where * can be #\* or some digits.  This
189                  (values :newest end))           ;; denotes a version.
190                 ((and (char= (schar namestr (- end 2)) #\*)           ;;(format t "explicit-version ~S ~A ~A~%" namestr start end)
191             (cond ((or (< (- end start) 4)
192                        (and (char/= (schar namestr (1- end)) #\~)
193                             (char/= (schar namestr (1- end)) #\*)))
194                    ;; No explicit version given, so return NIL to
195                    ;; indicate we don't want file versions, unless
196                    ;; requested in other ways.
197                    ;;(format t "case 1: ~A ~A~%" nil end)
198                    (values nil end))
199                   ((and (not *ignore-wildcards*)
200                         (char= (schar namestr (- end 2)) #\*)
201                       (char= (schar namestr (- end 3)) #\~)                       (char= (schar namestr (- end 3)) #\~)
202                       (char= (schar namestr (- end 4)) #\.))                       (char= (schar namestr (- end 4)) #\.))
203                    ;; Found "~*~", so it's a wild version
204                    ;;(format t "case 2: ~A ~A~%" :wild (- end 4))
205                  (values :wild (- end 4)))                  (values :wild (- end 4)))
206                 (t                 (t
207                    ;; Look for a version number.  Start at the end, just
208                    ;; before the ~ and keep looking for digits.  If the
209                    ;; first non-digit is ~, and the leading character is
210                    ;; a non-zero digit, we have a version number, so get
211                    ;; it.  If not, we didn't find a version number, so we
212                    ;; call it :newest
213                  (do ((i (- end 2) (1- i)))                  (do ((i (- end 2) (1- i)))
214                      ((< i (+ start 2)) (values :newest end))                      ((< i (+ start 1))
215                         ;;(format t "case 3: ~A ~A~%" :newest end)
216                         (values :newest end))
217                    (let ((char (schar namestr i)))                    (let ((char (schar namestr i)))
218                      (when (eql char #\~)                      (when (eql char #\~)
219                        (return (if (char= (schar namestr (1- i)) #\.)                        (return (if (char= (schar namestr (1- i)) #\.)
220                                    (values (parse-integer namestr :start (1+ i)                                    (if (char= (schar namestr (1+ i)) #\0)
221                                                           :end (1- end))                                        (values nil end)
222                                            (1- i))                                        (values (parse-integer namestr :start (1+ i)
223                                                                 :end (1- end))
224                                                  (1- i)))
225                                    (values :newest end))))                                    (values :newest end))))
226                      (unless (char<= #\0 char #\9)                      (unless (char<= #\0 char #\9)
227                        (return (values :newest end))))))))                        ;; 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)         (any-version (namestr start end)
232           ;; process end of string looking for a version candidate.           ;; process end of string looking for a version candidate.
233           (multiple-value-bind (version where)           (multiple-value-bind (version where)
234             (explicit-version namestr start end)               (explicit-version namestr start end)
235             (cond ((not (eq version :newest))             (cond ((not (eq version :newest))
236                    (values version where))                    (values version where))
237                   ((and (>= (- end 2) start)                   ((and (not *ignore-wildcards*)
238                           (>= (- end 2) start)
239                         (char= (schar namestr (- end 1)) #\*)                         (char= (schar namestr (- end 1)) #\*)
240                         (char= (schar namestr (- end 2)) #\.)                         (char= (schar namestr (- end 2)) #\.)
241                         (find #\. namestr                         (find #\. namestr
# Line 221  Line 254 
254         (any-name (namestr start end)         (any-name (namestr start end)
255           (declare (ignore namestr))           (declare (ignore namestr))
256           (values start end)))           (values start end)))
257      (multiple-value-bind      (multiple-value-bind (version vstart)
258          (version vstart)(any-version namestr start end)          (any-version namestr start end)
259        (multiple-value-bind        (multiple-value-bind (tstart tend)
260            (tstart tend)(any-type namestr start vstart)            (any-type namestr start vstart)
261          (multiple-value-bind          (multiple-value-bind (nstart nend)
262              (nstart nend)(any-name namestr start (or tstart vstart))              (any-name namestr start (or tstart vstart))
263            (values            (values
264             (maybe-make-pattern namestr nstart nend)             (maybe-make-pattern namestr nstart nend)
265             (and tstart (maybe-make-pattern namestr (1+ tstart) tend))             (and tstart (maybe-make-pattern namestr (1+ tstart) tend))
# Line 242  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 279  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          ;; PVE: Make sure there are no illegal characters in the name
354          ;; such as #\Null and #\/.          ;; such as #\Null and #\/.
355          (when (and (stringp name)          (when (and (stringp name)
# Line 312  Line 368 
368                            (piece-end (cdr piece)))                            (piece-end (cdr piece)))
369                        (unless (= piece-start piece-end)                        (unless (= piece-start piece-end)
370                          (cond ((string= namestr ".." :start1 piece-start                          (cond ((string= namestr ".." :start1 piece-start
371                                          :end1 piece-end)                                               :end1 piece-end)
372                                 (dirs :up))                                 (dirs :up))
373                                ((string= namestr "**" :start1 piece-start                                ((string= namestr "**" :start1 piece-start
374                                          :end1 piece-end)                                          :end1 piece-end)
# Line 324  Line 380 
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) "*")      ((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 373  Line 456 
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 393  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            ((member :wild-inferiors)            ((member :wild-inferiors)
490             (pieces "**/"))             (pieces "**/"))
491            ((or simple-string pattern)            ((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)
# Line 422  Line 507 
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))             (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
547          (strings (if (eq version :wild)          (strings (if (eq version :wild)
548                       (if logical-p ".*" ".~*~")                       (if logical-p ".*" ".~*~")
549                       (format nil (if logical-p ".~D" ".~~~D~~")                       (format nil (if logical-p ".~A" ".~~~D~~")
550                               version)))))                               version)))))
551      (and (strings) (apply #'concatenate 'simple-string (strings)))))      (and (strings) (apply #'concatenate 'simple-string (strings)))))
552    
# Line 446  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 522  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) (follow-links 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 ,follow-links                               ,verify-existence ,follow-links
671                               #',body-name)                               #',body-name)
672           ,result))))           ,result))))
673    
674  (defun %enumerate-matches (pathname verify-existance follow-links 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)))
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 follow-links                                     verify-existence follow-links
684                                     nil function))                                     nil function))
685            (:relative            (:relative
686             (%enumerate-directories "" (cdr directory) pathname             (%enumerate-directories "" (cdr directory) pathname
687                                     verify-existance follow-links                                     verify-existence follow-links
688                                     nil function)))                                     nil function)))
689          (%enumerate-files "" pathname verify-existance function))))          (%enumerate-files "" pathname verify-existence function))))
690    
691  ;;; %enumerate-directories  --   Internal  ;;; %enumerate-directories  --   Internal
692  ;;;  ;;;
693  ;;; The directory node and device numbers are maintained for the current path  ;;; The directory node and device numbers are maintained for the current path
694  ;;; during the search for the detection of paths loops upon :wild-inferiors.  ;;; during the search for the detection of path loops upon :wild-inferiors.
695  ;;;  ;;;
696  (defun %enumerate-directories (head tail pathname verify-existance  (defun %enumerate-directories (head tail pathname verify-existence
697                                 follow-links nodes function)                                 follow-links nodes function)
698    (declare (simple-string head))    (declare (simple-string head))
699    (macrolet ((unix-xstat (name)    (macrolet ((unix-xstat (name)
# Line 589  Line 727 
727                 (with-directory-node-noted (head)                 (with-directory-node-noted (head)
728                   (%enumerate-directories (concatenate 'string head "/")                   (%enumerate-directories (concatenate 'string head "/")
729                                           (cdr tail) pathname                                           (cdr tail) pathname
730                                           verify-existance follow-links                                           verify-existence follow-links
731                                           nodes function))))                                           nodes function))))
732              ((member :wild-inferiors)              ((member :wild-inferiors)
733               (%enumerate-directories head (rest tail) pathname               (%enumerate-directories head (rest tail) pathname
734                                       verify-existance follow-links                                       verify-existence follow-links
735                                       nodes function)                                       nodes function)
736               (do-directory-entries (name head)               (do-directory-entries (name head)
737                 (let ((subdir (concatenate 'string head name)))                 (let ((subdir (concatenate 'string head name)))
# Line 608  Line 746 
746                         (let ((nodes (cons (cons dev ino) nodes))                         (let ((nodes (cons (cons dev ino) nodes))
747                               (subdir (concatenate 'string subdir "/")))                               (subdir (concatenate 'string subdir "/")))
748                           (%enumerate-directories subdir tail pathname                           (%enumerate-directories subdir tail pathname
749                                                   verify-existance follow-links                                                   verify-existence follow-links
750                                                   nodes function))))))))                                                   nodes function))))))))
751              ((or pattern (member :wild))              ((or pattern (member :wild))
752               (do-directory-entries (name head)               (do-directory-entries (name head)
# Line 622  Line 760 
760                         (let ((nodes (cons (cons dev ino) nodes))                         (let ((nodes (cons (cons dev ino) nodes))
761                               (subdir (concatenate 'string subdir "/")))                               (subdir (concatenate 'string subdir "/")))
762                           (%enumerate-directories subdir (rest tail) pathname                           (%enumerate-directories subdir (rest tail) pathname
763                                                   verify-existance follow-links                                                   verify-existence follow-links
764                                                   nodes function))))))))                                                   nodes function))))))))
765              ((member :up)              ((member :up)
766               (let ((head (concatenate 'string head "..")))               (let ((head (concatenate 'string head "..")))
767                 (with-directory-node-noted (head)                 (with-directory-node-noted (head)
768                   (%enumerate-directories (concatenate 'string head "/")                   (%enumerate-directories (concatenate 'string head "/")
769                                           (rest tail) pathname                                           (rest tail) pathname
770                                           verify-existance follow-links                                           verify-existence follow-links
771                                           nodes function))))))                                           nodes function))))))
772          (%enumerate-files head pathname verify-existance function))))          (%enumerate-files head pathname verify-existence function))))
773    
774  (defun %enumerate-files (directory pathname verify-existance function)  (defun %enumerate-files (directory pathname verify-existence function)
775    (declare (simple-string directory))    (declare (simple-string directory))
776    (let ((name (%pathname-name pathname))    (let ((name (%pathname-name pathname))
777          (type (%pathname-type pathname))          (type (%pathname-type pathname))
778          (version (%pathname-version pathname)))          (version (%pathname-version pathname)))
779      (cond ((member name '(nil :unspecific))      (cond ((member name '(nil :unspecific))
780             (when (or (not verify-existance)             (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)                 (eq name :wild)
786                 (eq type :wild))                 (eq type :wild)
787                   (eq version :wild))
788             (let ((dir (unix:open-dir directory)))             (let ((dir (unix:open-dir directory)))
789               (when dir               (when dir
790                 (unwind-protect                 (unwind-protect
# Line 659  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 673  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 (member version '(nil :newest :wild))               (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                                         "~")))                                         "~")))
825               (when (or (not verify-existance)               (when (or (not verify-existence)
826                         (unix:unix-file-kind file t))                         (unix:unix-file-kind file t))
827                 (funcall function file)))))))                 (funcall function file)))))))
828    
# Line 723  Line 868 
868    (enumerate-search-list    (enumerate-search-list
869        (pathname path)        (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                                 :follow-links t)                                 :follow-links t)
873          (when (or (not executable-only)          (when (or (not executable-only)
874                    (and (eq (unix:unix-file-kind name) :file)                    (and (eq (unix:unix-file-kind name) :file)
# Line 733  Line 878 
878          (when names          (when names
879            (when (cdr names)            (when (cdr names)
880              (error 'simple-file-error              (error 'simple-file-error
881                     :format-control "~S is ambiguous:~{~%  ~A~}"                     :format-control (intl:gettext "~S is ambiguous:~{~%  ~A~}")
882                     :format-arguments (list pathname names)))                     :format-arguments (list pathname names)))
883            (return (car names))))))))            (return (car names))))))))
884    
# Line 750  Line 895 
895    or the pathname is wild."    or the pathname is wild."
896    (if (wild-pathname-p pathname)    (if (wild-pathname-p pathname)
897        (error 'simple-file-error        (error 'simple-file-error
898               :format-control "Bad place for a wild pathname."               :format-control (intl:gettext "Bad place for a wild pathname.")
899               :pathname pathname)               :pathname pathname)
900        (let ((result (probe-file pathname)))        (let ((result (probe-file pathname)))
901          (unless result          (unless result
902            (error 'simple-file-error            (error 'simple-file-error
903                   :pathname pathname                   :pathname pathname
904                   :format-control "The file ~S does not exist."                   :format-control (intl:gettext "The file ~S does not exist.")
905                   :format-arguments (list (namestring pathname))))                   :format-arguments (list (namestring pathname))))
906          result)))          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. 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."
915    (if (wild-pathname-p pathname)    (if (wild-pathname-p pathname)
916        (error 'simple-file-error        (error 'simple-file-error
917               :pathname pathname               :pathname pathname
918               :format-control "Bad place for a wild pathname.")               :format-control (intl:gettext "Bad place for a wild pathname."))
919        (let ((namestring (unix-namestring pathname t)))        (let ((namestring (unix-namestring (merge-pathnames pathname) t)))
920          (when (and namestring (unix:unix-file-kind namestring))          (when (and namestring (unix:unix-file-kind namestring))
921            (let ((truename (unix:unix-resolve-links            (let ((truename (unix:unix-resolve-links
922                             (unix:unix-maybe-prepend-current-directory                             (unix:unix-maybe-prepend-current-directory
# Line 790  Line 935 
935    file, then the associated file is renamed."    file, then the associated file is renamed."
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)))
940      (unless new-namestring      (unless new-namestring
941        (error 'simple-file-error        (error 'simple-file-error
942               :pathname new-name               :pathname new-name
943               :format-control "~S can't be created."               :format-control (intl:gettext "~S can't be created.")
944               :format-arguments (list new-name)))               :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
# Line 803  Line 948 
948        (unless res        (unless res
949          (error 'simple-file-error          (error 'simple-file-error
950                 :pathname new-name                 :pathname new-name
951                 :format-control "Failed to rename ~A to ~A: ~A"                 :format-control (intl:gettext "Failed to rename ~A to ~A: ~A")
952                 :format-arguments (list original new-name                 :format-arguments (list original new-name
953                                         (unix:get-unix-error-msg error))))                                         (unix:get-unix-error-msg error))))
954        (when (streamp file)        (when (streamp file)
# Line 816  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 'simple-file-error        (error 'simple-file-error
971               :pathname file               :pathname file
972               :format-control "~S doesn't exist."               :format-control (intl:gettext "~S doesn't exist.")
973               :format-arguments (list file)))               :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 'simple-file-error          (error 'simple-file-error
978                 :pathname namestring                 :pathname namestring
979                 :format-control "Could not delete ~A: ~A."                 :format-control (intl:gettext "Could not delete ~A: ~A.")
980                 :format-arguments (list namestring                 :format-arguments (list namestring
981                                         (unix:get-unix-error-msg err))))))                                         (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 849  Line 1030 
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   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"
1034    (if (wild-pathname-p file)    (if (wild-pathname-p file)
1035        (error 'simple-file-error        (error 'simple-file-error
1036               :pathname file               :pathname file
1037               :format-control "Bad place for a wild pathname.")               :format-control (intl:gettext "Bad place for a wild pathname."))
1038        (let ((name (unix-namestring file t)))        (let ((name (unix-namestring (merge-pathnames file) t)))
1039          (when name          (when name
1040            (multiple-value-bind            (multiple-value-bind
1041                (res dev ino mode nlink uid gid rdev size atime mtime)                (res dev ino mode nlink uid gid rdev size atime mtime)
# Line 872  Line 1053 
1053    (if (wild-pathname-p file)    (if (wild-pathname-p file)
1054        (error 'simple-file-error        (error 'simple-file-error
1055               :pathname file               :pathname file
1056               "Bad place for a wild pathname.")               :format-control (intl:gettext "Bad place for a wild pathname."))
1057        (let ((name (unix-namestring (pathname file) t)))        (let ((name (unix-namestring (merge-pathnames file) t)))
1058          (unless name          (unless name
1059            (error 'simple-file-error            (error 'simple-file-error
1060                   :pathname file                   :pathname file
1061                   :format-control "~S doesn't exist."                   :format-control (intl:gettext "~S doesn't exist.")
1062                   :format-arguments (list file)))                   :format-arguments (list file)))
1063          (multiple-value-bind (winp dev ino mode nlink uid)          (multiple-value-bind (winp dev ino mode nlink uid)
1064                               (unix:unix-stat name)                               (unix:unix-stat name)
1065            (declare (ignore dev ino mode nlink))            (declare (ignore dev ino mode nlink))
1066            (if winp (lookup-login-name uid))))))            (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                             (truenamep t) (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 :TRUENAMEP 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 which 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.) If FOLLOW-LINKS is NIL then symbolic links are     be in another directory).  If FOLLOW-LINKS is NIL then symbolic links are
1085     not followed."     not followed."
1086    (let ((results nil))    (flet ((ordered-strings-remove-duplicates (list)
1087      (enumerate-search-list             (let ((results '())
1088          (pathname (merge-pathnames pathname                   (prev nil))
1089                                     (make-pathname :name :wild               (dolist (elem list)
1090                                                    :type :wild                 (when (or (null prev)
1091                                                    :version :wild)))                           (not (string= elem prev)))
1092        (enumerate-matches (name pathname nil :follow-links follow-links)                   (push elem results))
1093          (when (or all                 (setf prev elem))
1094                    (let ((slash (position #\/ name :from-end t)))               (nreverse results))))
1095                      (or (null slash)      (let ((results nil))
1096                          (= (1+ slash) (length name))        (enumerate-search-list
1097                          (char/= (schar name (1+ slash)) #\.))))            (pathname (merge-pathnames pathname
1098            (push name results))))                                       (make-pathname :name :wild
1099      (let ((*ignore-wildcards* t))                                                      :type :wild
1100        (mapcar #'(lambda (name)                                                      :version :wild
1101                    (let ((name (if (and check-for-subdirs                                                      :defaults *default-pathname-defaults*)
1102                                         (eq (unix:unix-file-kind name)                                       :wild))
1103                                             :directory))          (enumerate-matches (name pathname nil :follow-links follow-links)
1104                                    (concatenate 'string name "/")            (when (or all
1105                                    name)))                      (let ((slash (position #\/ name :from-end t)))
1106                      (if truenamep (truename name) (pathname name))))                        (or (null slash)
1107                (sort (delete-duplicates results :test #'string=) #'string<)))))                            (= (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 928  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 943  Line 1139 
1139    (let ((contents (directory pathname :all all :check-for-subdirs nil    (let ((contents (directory pathname :all all :check-for-subdirs nil
1140                               :truenamep 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 986  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
# Line 1046  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 1061  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 1263  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 1285  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    
# Line 1296  Line 1425 
1425    "Tests whether the directories containing the specified file    "Tests whether the directories containing the specified file
1426    actually exist, and attempts to create them if they do not.    actually exist, and attempts to create them if they do not.
1427    Portable programs should avoid using the :MODE keyword argument."    Portable programs should avoid using the :MODE keyword argument."
1428    (let* ((pathname (pathname pathspec))    (let* ((pathname (merge-pathnames pathspec))
1429           (pathname (if (logical-pathname-p pathname)           (pathname (if (logical-pathname-p pathname)
1430                         (translate-logical-pathname pathname)                         (translate-logical-pathname pathname)
1431                         pathname))                         pathname))
1432           (created-p nil))           (created-p nil))
1433      (when (wild-pathname-p pathname)      (when (wild-pathname-p pathname)
1434        (error 'simple-file-error        (error 'simple-file-error
1435               :format-control "Bad place for a wild pathname."               :format-control (intl:gettext "Bad place for a wild pathname.")
1436               :pathname pathspec))               :pathname pathspec))
1437      (enumerate-search-list (pathname pathname)      (enumerate-search-list (pathname pathname)
1438         (let ((dir (pathname-directory pathname)))         (let ((dir (pathname-directory pathname)))
# Line 1312  Line 1441 
1441                                    :host (pathname-host pathname)                                    :host (pathname-host pathname)
1442                                    :device (pathname-device pathname)                                    :device (pathname-device pathname)
1443                                    :directory (subseq dir 0 i))))                                    :directory (subseq dir 0 i))))
1444                      (unless (probe-file newpath)                      (tagbody
1445                        (let ((namestring (namestring newpath)))                       retry
1446                          (when verbose                         (restart-case
1447                            (format *standard-output* "~&Creating directory: ~A~%"                             (unless (probe-file newpath)
1448                                    namestring))                               (let ((namestring (namestring newpath)))
1449                          (unix:unix-mkdir namestring mode)                                 (when verbose
1450                          (unless (probe-file namestring)                                   (format *standard-output* (intl:gettext "~&Creating directory: ~A~%")
1451                            (error 'simple-file-error                                           namestring))
1452                                   :pathname pathspec                                 (unix:unix-mkdir namestring mode)
1453                                   :format-control "Can't create directory ~A."                                 (unless (probe-file namestring)
1454                                   :format-arguments (list namestring)))                                   (error 'simple-file-error
1455                          (setf created-p t)))))                                          :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.           ;; Only the first path in a search-list is considered.
1462           (return (values pathname created-p))))))           (return (values pathname created-p))))))

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

  ViewVC Help
Powered by ViewVC 1.1.5