0.pre8.100:

[sbcl.git] / src / code / filesys.lisp

diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp
index 89658f2..849d66e 100644 (file)
--- a/src/code/filesys.lisp
+++ b/src/code/filesys.lisp
@@ -16,14 +16,11 @@
 ;;; Unix namestrings have the following format:
 ;;;
 ;;; namestring := [ directory ] [ file [ type [ version ]]]
 ;;; Unix namestrings have the following format:
 ;;;
 ;;; namestring := [ directory ] [ file [ type [ version ]]]

-;;; directory := [ "/" | search-list ] { file "/" }*
-;;; search-list := [^:/]*:
+;;; directory := [ "/" ] { file "/" }*

 ;;; file := [^/]*
 ;;; type := "." [^/.]*
 ;;; version := "." ([0-9]+ | "*")
 ;;;
 ;;; file := [^/]*
 ;;; type := "." [^/.]*
 ;;; version := "." ([0-9]+ | "*")
 ;;;

-;;; FIXME: Search lists are no longer supported.
-;;;

 ;;; Note: this grammar is ambiguous. The string foo.bar.5 can be
 ;;; parsed as either just the file specified or as specifying the
 ;;; file, type, and version. Therefore, we use the following rules
 ;;; Note: this grammar is ambiguous. The string foo.bar.5 can be
 ;;; parsed as either just the file specified or as specifying the
 ;;; file, type, and version. Therefore, we use the following rules

@@ -57,7 +54,7 @@
    checked for whatever they may have protected."
   (declare (type simple-base-string namestr)
           (type index start end))
    checked for whatever they may have protected."
   (declare (type simple-base-string namestr)
           (type index start end))

-  (let* ((result (make-string (- end start)))
+  (let* ((result (make-string (- end start) :element-type 'base-char))

         (dst 0)
         (quoted nil))
     (do ((src start (1+ src)))
         (dst 0)
         (quoted nil))
     (do ((src start (1+ src)))

@@ -218,89 +215,68 @@
          (setf start (1+ slash))))
       (values absolute (pieces)))))
 
          (setf start (1+ slash))))
       (values absolute (pieces)))))
 

-(defun maybe-extract-search-list (namestr start end)
-  (declare (type simple-base-string namestr)
-          (type index start end))
-  (let ((quoted nil))
-    (do ((index start (1+ index)))
-       ((= index end)
-        (values nil start))
-      (if quoted
-         (setf quoted nil)
-         (case (schar namestr index)
-           (#\\
-            (setf quoted t))
-           (#\:
-            (return (values (remove-backslashes namestr start index)
-                            (1+ index)))))))))
-

 (defun parse-unix-namestring (namestr start end)
   (declare (type simple-base-string namestr)
 (defun parse-unix-namestring (namestr start end)
   (declare (type simple-base-string namestr)

-          (type index start end))
+           (type index start end))

   (multiple-value-bind (absolute pieces) (split-at-slashes namestr start end)
   (multiple-value-bind (absolute pieces) (split-at-slashes namestr start end)

-    (let ((search-list (if absolute
-                          nil
-                          (let ((first (car pieces)))
-                            (multiple-value-bind (search-list new-start)
-                                (maybe-extract-search-list namestr
-                                                           (car first)
-                                                           (cdr first))
-                              (when search-list
-                                (setf absolute t)
-                                (setf (car first) new-start))
-                              search-list)))))
-      (multiple-value-bind (name type version)
-         (let* ((tail (car (last pieces)))
-                (tail-start (car tail))
-                (tail-end (cdr tail)))
-           (unless (= tail-start tail-end)
-             (setf pieces (butlast pieces))
-             (extract-name-type-and-version namestr tail-start tail-end)))
-       ;; PVE: make sure there are no illegal characters in
-       ;; the name, illegal being (code-char 0) and #\/
-       #!+high-security
-       (when (and (stringp name)
-                  (find-if #'(lambda (x) (or (char= x (code-char 0))
-                                             (char= x #\/)))
-                           name))
-         (error 'parse-error))
-       
-       ;; Now we have everything we want. So return it.
-       (values nil ; no host for unix namestrings.
-               nil ; no devices for unix namestrings.
-               (collect ((dirs))
-                 (when search-list
-                   (dirs (intern-search-list search-list)))
-                 (dolist (piece pieces)
-                   (let ((piece-start (car piece))
-                         (piece-end (cdr piece)))
-                     (unless (= piece-start piece-end)
-                       (cond ((string= namestr ".." :start1 piece-start
-                                       :end1 piece-end)
-                              (dirs :up))
-                             ((string= namestr "**" :start1 piece-start
-                                       :end1 piece-end)
-                              (dirs :wild-inferiors))
-                             (t
-                              (dirs (maybe-make-pattern namestr
-                                                        piece-start
-                                                        piece-end)))))))
-                 (cond (absolute
-                        (cons :absolute (dirs)))
-                       ((dirs)
-                        (cons :relative (dirs)))
-                       (t
-                        nil)))
-               name
-               type
-               version)))))
+    (multiple-value-bind (name type version)
+       (let* ((tail (car (last pieces)))
+              (tail-start (car tail))
+              (tail-end (cdr tail)))
+         (unless (= tail-start tail-end)
+           (setf pieces (butlast pieces))
+           (extract-name-type-and-version namestr tail-start tail-end)))
+
+      (when (stringp name)
+       (let ((position (position-if (lambda (char)
+                                      (or (char= char (code-char 0))
+                                          (char= char #\/)))
+                                    name)))
+         (when position
+           (error 'namestring-parse-error
+                  :complaint "can't embed #\\Nul or #\\/ in Unix namestring"
+                  :namestring namestr
+                  :offset position))))
+      ;; Now we have everything we want. So return it.
+      (values nil ; no host for Unix namestrings
+             nil ; no device for Unix namestrings
+             (collect ((dirs))
+               (dolist (piece pieces)
+                 (let ((piece-start (car piece))
+                       (piece-end (cdr piece)))
+                   (unless (= piece-start piece-end)
+                     (cond ((string= namestr ".."
+                                     :start1 piece-start
+                                     :end1 piece-end)
+                            (dirs :up))
+                           ((string= namestr "**"
+                                     :start1 piece-start
+                                     :end1 piece-end)
+                            (dirs :wild-inferiors))
+                           (t
+                            (dirs (maybe-make-pattern namestr
+                                                      piece-start
+                                                      piece-end)))))))
+               (cond (absolute
+                      (cons :absolute (dirs)))
+                     ((dirs)
+                      (cons :relative (dirs)))
+                     (t
+                      nil)))
+             name
+             type
+             version))))

 
 (/show0 "filesys.lisp 300")
 
 (defun unparse-unix-host (pathname)
   (declare (type pathname pathname)
           (ignore pathname))
 
 (/show0 "filesys.lisp 300")
 
 (defun unparse-unix-host (pathname)
   (declare (type pathname pathname)
           (ignore pathname))

-  "Unix")
+  ;; this host designator needs to be recognized as a physical host in
+  ;; PARSE-NAMESTRING. Until sbcl-0.7.3.x, we had "Unix" here, but
+  ;; that's a valid Logical Hostname, so that's a bad choice. -- CSR,
+  ;; 2002-05-09
+  "")

 
 (defun unparse-unix-piece (thing)
   (etypecase thing
 
 (defun unparse-unix-piece (thing)
   (etypecase thing

@@ -353,11 +329,7 @@
     (when directory
       (ecase (pop directory)
        (:absolute
     (when directory
       (ecase (pop directory)
        (:absolute

-        (cond ((search-list-p (car directory))
-               (pieces (search-list-name (pop directory)))
-               (pieces ":"))
-              (t
-               (pieces "/"))))
+        (pieces "/"))

        (:relative
         ;; nothing special
         ))
        (:relative
         ;; nothing special
         ))

@@ -461,29 +433,6 @@
            (t
             (lose)))))
       (apply #'concatenate 'simple-string (strings)))))
            (t
             (lose)))))
       (apply #'concatenate 'simple-string (strings)))))

-
-(/show0 "filesys.lisp 471")
-
-(def!struct (unix-host
-            (:make-load-form-fun make-unix-host-load-form)
-            (:include host
-                      (parse #'parse-unix-namestring)
-                      (unparse #'unparse-unix-namestring)
-                      (unparse-host #'unparse-unix-host)
-                      (unparse-directory #'unparse-unix-directory)
-                      (unparse-file #'unparse-unix-file)
-                      (unparse-enough #'unparse-unix-enough)
-                      (customary-case :lower))))
-
-(/show0 "filesys.lisp 486")
-
-(defvar *unix-host* (make-unix-host))
-
-(/show0 "filesys.lisp 488")
-
-(defun make-unix-host-load-form (host)
-  (declare (ignore host))
-  '*unix-host*)

 \f
 ;;;; wildcard matching stuff
 
 \f
 ;;;; wildcard matching stuff
 

@@ -508,28 +457,22 @@
 
 (/show0 "filesys.lisp 498")
 
 
 (/show0 "filesys.lisp 498")
 

-;;; FIXME: could maybe be EVAL-WHEN (COMPILE EVAL)
-
-(defmacro enumerate-matches ((var pathname &optional result
-                                 &key (verify-existence t)
-                                  (follow-links t))
-                            &body body)
-  (let ((body-name (gensym "ENUMERATE-MATCHES-BODY-FUN-")))
-    `(block nil
-       (flet ((,body-name (,var)
-               ,@body))
-         (declare (dynamic-extent ,body-name))
-        (%enumerate-matches (pathname ,pathname)
-                            ,verify-existence
-                             ,follow-links
-                            #',body-name)
-        ,result))))
+(defmacro !enumerate-matches ((var pathname &optional result
+                                  &key (verify-existence t)
+                                  (follow-links t))
+                             &body body)
+  `(block nil
+     (%enumerate-matches (pathname ,pathname)
+                        ,verify-existence
+                        ,follow-links
+                        (lambda (,var) ,@body))
+     ,result))

 
 (/show0 "filesys.lisp 500")
 
 ;;; Call FUNCTION on matches.
 (defun %enumerate-matches (pathname verify-existence follow-links function)
 
 (/show0 "filesys.lisp 500")
 
 ;;; Call FUNCTION on matches.
 (defun %enumerate-matches (pathname verify-existence follow-links function)

-  (/show0 "entering %ENUMERATE-MATCHES")
+  (/noshow0 "entering %ENUMERATE-MATCHES")

   (when (pathname-type pathname)
     (unless (pathname-name pathname)
       (error "cannot supply a type without a name:~%  ~S" pathname)))
   (when (pathname-type pathname)
     (unless (pathname-name pathname)
       (error "cannot supply a type without a name:~%  ~S" pathname)))

@@ -537,17 +480,17 @@
             (member (pathname-type pathname) '(nil :unspecific)))
     (error "cannot supply a version without a type:~%  ~S" pathname))
   (let ((directory (pathname-directory pathname)))
             (member (pathname-type pathname) '(nil :unspecific)))
     (error "cannot supply a version without a type:~%  ~S" pathname))
   (let ((directory (pathname-directory pathname)))

-    (/show0 "computed DIRECTORY")
+    (/noshow0 "computed DIRECTORY")

     (if directory
     (if directory

-       (ecase (car directory)
+       (ecase (first directory)

          (:absolute
          (:absolute

-          (/show0 "absolute directory")
-          (%enumerate-directories "/" (cdr directory) pathname
+          (/noshow0 "absolute directory")
+          (%enumerate-directories "/" (rest directory) pathname

                                   verify-existence follow-links
                                   nil function))
          (:relative
                                   verify-existence follow-links
                                   nil function))
          (:relative

-          (/show0 "relative directory")
-          (%enumerate-directories "" (cdr directory) pathname
+          (/noshow0 "relative directory")
+          (%enumerate-directories "" (rest directory) pathname

                                   verify-existence follow-links
                                   nil function)))
        (%enumerate-files "" pathname verify-existence function))))
                                   verify-existence follow-links
                                   nil function)))
        (%enumerate-files "" pathname verify-existence function))))

@@ -566,14 +509,21 @@
                  (when (and res (eql (logand mode sb!unix:s-ifmt)
                                      sb!unix:s-ifdir))
                    (let ((nodes (cons (cons dev ino) nodes)))
                  (when (and res (eql (logand mode sb!unix:s-ifmt)
                                      sb!unix:s-ifdir))
                    (let ((nodes (cons (cons dev ino) nodes)))

+                     ,@body))))
+            (with-directory-node-removed ((head) &body body)
+              `(multiple-value-bind (res dev ino mode)
+                   (unix-xstat ,head)
+                 (when (and res (eql (logand mode sb!unix:s-ifmt)
+                                     sb!unix:s-ifdir))
+                   (let ((nodes (remove (cons dev ino) nodes :test #'equal)))

                      ,@body)))))
     (if tail
        (let ((piece (car tail)))
          (etypecase piece
            (simple-string
                      ,@body)))))
     (if tail
        (let ((piece (car tail)))
          (etypecase piece
            (simple-string

-            (let ((head (concatenate 'string head piece)))
+            (let ((head (concatenate 'base-string head piece)))

               (with-directory-node-noted (head)
               (with-directory-node-noted (head)

-                (%enumerate-directories (concatenate 'string head "/")
+                (%enumerate-directories (concatenate 'base-string head "/")

                                         (cdr tail) pathname
                                         verify-existence follow-links
                                         nodes function))))
                                         (cdr tail) pathname
                                         verify-existence follow-links
                                         nodes function))))

@@ -582,7 +532,7 @@
                                     verify-existence follow-links
                                     nodes function)
             (dolist (name (ignore-errors (directory-lispy-filenames head)))
                                     verify-existence follow-links
                                     nodes function)
             (dolist (name (ignore-errors (directory-lispy-filenames head)))

-              (let ((subdir (concatenate 'string head name)))
+              (let ((subdir (concatenate 'base-string head name)))

                 (multiple-value-bind (res dev ino mode)
                     (unix-xstat subdir)
                   (declare (type (or fixnum null) mode))
                 (multiple-value-bind (res dev ino mode)
                     (unix-xstat subdir)
                   (declare (type (or fixnum null) mode))

@@ -593,14 +543,14 @@
                                          (eql (cdr dir) ino))
                                 (return t)))
                       (let ((nodes (cons (cons dev ino) nodes))
                                          (eql (cdr dir) ino))
                                 (return t)))
                       (let ((nodes (cons (cons dev ino) nodes))

-                            (subdir (concatenate 'string subdir "/")))
+                            (subdir (concatenate 'base-string subdir "/")))

                         (%enumerate-directories subdir tail pathname
                                                 verify-existence follow-links
                                                 nodes function))))))))
            ((or pattern (member :wild))
             (dolist (name (directory-lispy-filenames head))
               (when (or (eq piece :wild) (pattern-matches piece name))
                         (%enumerate-directories subdir tail pathname
                                                 verify-existence follow-links
                                                 nodes function))))))))
            ((or pattern (member :wild))
             (dolist (name (directory-lispy-filenames head))
               (when (or (eq piece :wild) (pattern-matches piece name))

-                (let ((subdir (concatenate 'string head name)))
+                (let ((subdir (concatenate 'base-string head name)))

                   (multiple-value-bind (res dev ino mode)
                       (unix-xstat subdir)
                     (declare (type (or fixnum null) mode))
                   (multiple-value-bind (res dev ino mode)
                       (unix-xstat subdir)
                     (declare (type (or fixnum null) mode))

@@ -608,29 +558,30 @@
                                (eql (logand mode sb!unix:s-ifmt)
                                     sb!unix:s-ifdir))
                       (let ((nodes (cons (cons dev ino) nodes))
                                (eql (logand mode sb!unix:s-ifmt)
                                     sb!unix:s-ifdir))
                       (let ((nodes (cons (cons dev ino) nodes))

-                            (subdir (concatenate 'string subdir "/")))
+                            (subdir (concatenate 'base-string subdir "/")))

                         (%enumerate-directories subdir (rest tail) pathname
                                                 verify-existence follow-links
                                                 nodes function))))))))
          ((member :up)
                         (%enumerate-directories subdir (rest tail) pathname
                                                 verify-existence follow-links
                                                 nodes function))))))))
          ((member :up)

-            (let ((head (concatenate 'string head "..")))
+            (with-directory-node-removed (head)
+            (let ((head (concatenate 'base-string head "..")))

               (with-directory-node-noted (head)
               (with-directory-node-noted (head)

-                (%enumerate-directories (concatenate 'string head "/")
+                (%enumerate-directories (concatenate 'base-string head "/")

                                         (rest tail) pathname
                                         verify-existence follow-links
                                         (rest tail) pathname
                                         verify-existence follow-links

-                                        nodes function))))))
+                                        nodes function)))))))

        (%enumerate-files head pathname verify-existence function))))
 
 ;;; Call FUNCTION on files.
 (defun %enumerate-files (directory pathname verify-existence function)
   (declare (simple-string directory))
        (%enumerate-files head pathname verify-existence function))))
 
 ;;; Call FUNCTION on files.
 (defun %enumerate-files (directory pathname verify-existence function)
   (declare (simple-string directory))

-  (/show0 "entering %ENUMERATE-FILES")
+  (/noshow0 "entering %ENUMERATE-FILES")

   (let ((name (%pathname-name pathname))
        (type (%pathname-type pathname))
        (version (%pathname-version pathname)))
   (let ((name (%pathname-name pathname))
        (type (%pathname-type pathname))
        (version (%pathname-version pathname)))

-    (/show0 "computed NAME, TYPE, and VERSION")
+    (/noshow0 "computed NAME, TYPE, and VERSION")

     (cond ((member name '(nil :unspecific))
     (cond ((member name '(nil :unspecific))

-          (/show0 "UNSPECIFIC, more or less")
+          (/noshow0 "UNSPECIFIC, more or less")

           (when (or (not verify-existence)
                     (sb!unix:unix-file-kind directory))
             (funcall function directory)))
           (when (or (not verify-existence)
                     (sb!unix:unix-file-kind directory))
             (funcall function directory)))

@@ -638,7 +589,7 @@
               (pattern-p type)
               (eq name :wild)
               (eq type :wild))
               (pattern-p type)
               (eq name :wild)
               (eq type :wild))

-          (/show0 "WILD, more or less")
+          (/noshow0 "WILD, more or less")

           ;; I IGNORE-ERRORS here just because the original CMU CL
           ;; code did. I think the intent is that it's not an error
           ;; to request matches to a wild pattern when no matches
           ;; I IGNORE-ERRORS here just because the original CMU CL
           ;; code did. I think the intent is that it's not an error
           ;; to request matches to a wild pattern when no matches

@@ -657,29 +608,27 @@
                          (components-match file-type type)
                          (components-match file-version version))
                 (funcall function
                          (components-match file-type type)
                          (components-match file-version version))
                 (funcall function

-                         (concatenate 'string
+                         (concatenate 'base-string

                                       directory
                                       complete-filename))))))
          (t
                                       directory
                                       complete-filename))))))
          (t

-          (/show0 "default case")
-          (let ((file (concatenate 'string directory name)))
-            (/show0 "computed basic FILE=..")
-            (/primitive-print file)
+          (/noshow0 "default case")
+          (let ((file (concatenate 'base-string directory name)))
+            (/noshow "computed basic FILE")

             (unless (or (null type) (eq type :unspecific))
             (unless (or (null type) (eq type :unspecific))

-              (/show0 "tweaking FILE for more-or-less-:UNSPECIFIC case")
-              (setf file (concatenate 'string file "." type)))
-            (unless (member version '(nil :newest :wild))
-              (/show0 "tweaking FILE for more-or-less-:WILD case")
-              (setf file (concatenate 'string file "."
+              (/noshow0 "tweaking FILE for more-or-less-:UNSPECIFIC case")
+              (setf file (concatenate 'base-string file "." type)))
+            (unless (member version '(nil :newest :wild :unspecific))
+              (/noshow0 "tweaking FILE for more-or-less-:WILD case")
+              (setf file (concatenate 'base-string file "."

                                       (quick-integer-to-string version))))
                                       (quick-integer-to-string version))))

-            (/show0 "finished possibly tweaking FILE=..")
-            (/primitive-print file)
+            (/noshow0 "finished possibly tweaking FILE")

             (when (or (not verify-existence)
                       (sb!unix:unix-file-kind file t))
             (when (or (not verify-existence)
                       (sb!unix:unix-file-kind file t))

-              (/show0 "calling FUNCTION on FILE")
+              (/noshow0 "calling FUNCTION on FILE")

               (funcall function file)))))))
 
               (funcall function file)))))))
 

-(/show0 "filesys.lisp 603")
+(/noshow0 "filesys.lisp 603")

 
 ;;; FIXME: Why do we need this?
 (defun quick-integer-to-string (n)
 
 ;;; FIXME: Why do we need this?
 (defun quick-integer-to-string (n)

@@ -689,11 +638,11 @@
        ((zerop n) "0")
        ((eql n 1) "1")
        ((minusp n)
        ((zerop n) "0")
        ((eql n 1) "1")
        ((minusp n)

-        (concatenate 'simple-string "-"
-                     (the simple-string (quick-integer-to-string (- n)))))
+        (concatenate 'simple-base-string "-"
+                     (the simple-base-string (quick-integer-to-string (- n)))))

        (t
         (do* ((len (1+ (truncate (integer-length n) 3)))
        (t
         (do* ((len (1+ (truncate (integer-length n) 3)))

-              (res (make-string len))
+              (res (make-string len :element-type 'base-char))

               (i (1- len) (1- i))
               (q n)
               (r 0))
               (i (1- len) (1- i))
               (q n)
               (r 0))

@@ -708,72 +657,79 @@
 \f
 ;;;; UNIX-NAMESTRING
 
 \f
 ;;;; UNIX-NAMESTRING
 

-(defun unix-namestring (pathname &optional (for-input t) executable-only)
-  #!+sb-doc
-  "Convert PATHNAME into a string that can be used with UNIX system calls.
-   Search-lists and wild-cards are expanded."
-  ;; toy@rtp.ericsson.se: Let unix-namestring also handle logical
-  ;; pathnames too.
-  ;; FIXME: What does this ^ mean? A bug? A remark on a change already made?
-  (let ((path (let ((lpn (pathname pathname)))
-               (if (typep lpn 'logical-pathname)
-                   (namestring (translate-logical-pathname lpn))
-                   pathname))))
-    (enumerate-search-list
-      (pathname path)
-      (collect ((names))
-       (enumerate-matches (name pathname nil :verify-existence for-input)
-                          (when (or (not executable-only)
-                                    (and (eq (sb!unix:unix-file-kind name)
-                                             :file)
-                                         (sb!unix:unix-access name
-                                                              sb!unix:x_ok)))
-                            (names name)))
-       (let ((names (names)))
-         (when names
-           (when (cdr names)
-             (error 'simple-file-error
-                    :format-control "~S is ambiguous:~{~%  ~A~}"
-                    :format-arguments (list pathname names)))
-           (return (car names))))))))
+(defun empty-relative-pathname-spec-p (x)
+  (or (equal x "")
+      (and (pathnamep x)
+          (or (equal (pathname-directory x) '(:relative))
+              ;; KLUDGE: I'm not sure this second check should really
+              ;; have to be here. But on sbcl-0.6.12.7,
+              ;; (PATHNAME-DIRECTORY (PATHNAME "")) is NIL, and
+              ;; (PATHNAME "") seems to act like an empty relative
+              ;; pathname, so in order to work with that, I test
+              ;; for NIL here. -- WHN 2001-05-18
+              (null (pathname-directory x)))
+          (null (pathname-name x))
+          (null (pathname-type x)))
+      ;; (The ANSI definition of "pathname specifier" has 
+      ;; other cases, but none of them seem to admit the possibility
+      ;; of being empty and relative.)
+      ))
+
+;;; Convert PATHNAME into a string that can be used with UNIX system
+;;; calls, or return NIL if no match is found. Wild-cards are expanded.
+;;; FIXME this should signal file-error if the pathname is wild, whether
+;;; or not it turns out to have only one match.  Fix post 0.7.2
+(defun unix-namestring (pathname-spec &optional (for-input t))
+  (let* ((namestring (physicalize-pathname (merge-pathnames pathname-spec)))
+        (matches nil)) ; an accumulator for actual matches
+    (when (wild-pathname-p namestring)
+      (error 'simple-file-error
+            :pathname namestring
+            :format-control "bad place for a wild pathname"))
+    (!enumerate-matches (match namestring nil :verify-existence for-input)
+                       (push match matches))
+    (case (length matches)
+      (0 nil)
+      (1 (first matches))
+      (t (bug "!ENUMERATE-MATCHES returned more than one match on a non-wild pathname")))))

 \f
 ;;;; TRUENAME and PROBE-FILE
 
 \f
 ;;;; TRUENAME and PROBE-FILE
 

-;;; Another silly file function trivially different from another function.
+;;; This is only trivially different from PROBE-FILE, which is silly
+;;; but ANSI.

 (defun truename (pathname)
   #!+sb-doc
 (defun truename (pathname)
   #!+sb-doc

-  "Return the pathname for the actual file described by the pathname
-  An error of type file-error is signalled if no such file exists,
-  or the pathname is wild."
-  (if (wild-pathname-p pathname)
+  "Return the pathname for the actual file described by PATHNAME.
+  An error of type FILE-ERROR is signalled if no such file exists,
+  or the pathname is wild.
+
+  Under Unix, the TRUENAME of a broken symlink is considered to be
+  the name of the broken symlink itself."
+  (let ((result (probe-file pathname)))
+    (unless result

       (error 'simple-file-error
       (error 'simple-file-error

-            :format-control "bad place for a wild pathname"
-            :pathname pathname)
-      (let ((result (probe-file pathname)))
-       (unless result
-         (error 'simple-file-error
-                :pathname pathname
-                :format-control "The file ~S does not exist."
-                :format-arguments (list (namestring pathname))))
-       result)))
+            :pathname pathname
+            :format-control "The file ~S does not exist."
+            :format-arguments (list (namestring pathname))))
+    result))

 
 ;;; If PATHNAME exists, return its truename, otherwise NIL.
 (defun probe-file (pathname)
   #!+sb-doc
 
 ;;; If PATHNAME exists, return its truename, otherwise NIL.
 (defun probe-file (pathname)
   #!+sb-doc

-  "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, or NIL

   otherwise. An error of type FILE-ERROR is signaled if pathname is wild."
   otherwise. An error of type FILE-ERROR is signaled if pathname is wild."

-  (if (wild-pathname-p pathname)
-      (error 'simple-file-error
-            :pathname pathname
-            :format-control "bad place for a wild pathname")
-      (let ((namestring (unix-namestring pathname t)))
-       (when (and namestring (sb!unix:unix-file-kind namestring))
-         (let ((truename (sb!unix:unix-resolve-links
-                          (sb!unix:unix-maybe-prepend-current-directory
-                           namestring))))
-           (when truename
-             (let ((*ignore-wildcards* t))
-               (pathname (sb!unix:unix-simplify-pathname truename)))))))))
+  (let* ((defaulted-pathname (merge-pathnames
+                             pathname
+                             (sane-default-pathname-defaults)))
+        (namestring (unix-namestring defaulted-pathname t)))
+    (when (and namestring (sb!unix:unix-file-kind namestring t))
+      (let ((trueishname (sb!unix:unix-resolve-links namestring)))
+       (when trueishname
+         (let* ((*ignore-wildcards* t)
+                (name (sb!unix:unix-simplify-pathname trueishname))) 
+           (if (eq (sb!unix:unix-file-kind name) :directory)
+               (pathname (concatenate 'string name "/"))
+               (pathname name))))))))

 \f
 ;;;; miscellaneous other operations
 
 \f
 ;;;; miscellaneous other operations
 

@@ -821,165 +777,72 @@
   t)
 \f
 ;;; (This is an ANSI Common Lisp function.) 
   t)
 \f
 ;;; (This is an ANSI Common Lisp function.) 

-;;;
-;;; This is obtained from the logical name \"home:\", which is set
-;;; up for us at initialization time.

 (defun user-homedir-pathname (&optional host)
   "Return the home directory of the user as a pathname."
   (declare (ignore host))
 (defun user-homedir-pathname (&optional host)
   "Return the home directory of the user as a pathname."
   (declare (ignore host))

-  ;; Note: CMU CL did #P"home:" here instead of using a call to
-  ;; PATHNAME. Delaying construction of the pathname until we're
-  ;; running in a target Lisp lets us avoid figuring out how to dump
-  ;; cross-compilation host Lisp PATHNAME objects into a target Lisp
-  ;; object file. It also might have a small positive effect on
-  ;; efficiency, in that we don't allocate a PATHNAME we don't need,
-  ;; but it it could also have a larger negative effect. Hopefully
-  ;; it'll be OK. -- WHN 19990714
-  (pathname "home:"))
+  (pathname (sb!unix:uid-homedir (sb!unix:unix-getuid))))

 
 (defun file-write-date (file)
   #!+sb-doc
   "Return file's creation date, or NIL if it doesn't exist.
  An error of type file-error is signaled if file is a wild pathname"
 
 (defun file-write-date (file)
   #!+sb-doc
   "Return file's creation date, or NIL if it doesn't exist.
  An error of type file-error is signaled if file is a wild pathname"

-  (if (wild-pathname-p file)
-      ;; FIXME: This idiom appears many times in this file. Perhaps it
-      ;; should turn into (CANNOT-BE-WILD-PATHNAME FILE). (C-B-W-P
-      ;; should be a macro, not a function, so that the error message
-      ;; is reported as coming from e.g. FILE-WRITE-DATE instead of
-      ;; from CANNOT-BE-WILD-PATHNAME itself.)
-      (error 'simple-file-error
-            :pathname file
-            :format-control "bad place for a wild pathname")
-      (let ((name (unix-namestring file t)))
-       (when name
-         (multiple-value-bind
-             (res dev ino mode nlink uid gid rdev size atime mtime)
-             (sb!unix:unix-stat name)
-           (declare (ignore dev ino mode nlink uid gid rdev size atime))
-           (when res
-             (+ unix-to-universal-time mtime)))))))
+  (let ((name (unix-namestring file t)))
+    (when name
+      (multiple-value-bind
+           (res dev ino mode nlink uid gid rdev size atime mtime)
+         (sb!unix:unix-stat name)
+       (declare (ignore dev ino mode nlink uid gid rdev size atime))
+       (when res
+         (+ unix-to-universal-time mtime))))))

 
 (defun file-author (file)
   #!+sb-doc
 
 (defun file-author (file)
   #!+sb-doc

-  "Returns the file author as a string, or nil if the author cannot be
- determined. Signals an error of type file-error if file doesn't exist,
- or file is a wild pathname."
-  (if (wild-pathname-p file)
+  "Return the file author as a string, or NIL if the author cannot be
+ determined. Signal an error of type FILE-ERROR if FILE doesn't exist,
+ or FILE is a wild pathname."
+  (let ((name (unix-namestring (pathname file) t)))
+    (unless name

       (error 'simple-file-error
             :pathname file
       (error 'simple-file-error
             :pathname file

-            "bad place for a wild pathname")
-      (let ((name (unix-namestring (pathname file) t)))
-       (unless name
-         (error 'simple-file-error
-                :pathname file
-                :format-control "~S doesn't exist."
-                :format-arguments (list file)))
-       (multiple-value-bind (winp dev ino mode nlink uid)
-           (sb!unix:unix-stat name)
-         (declare (ignore dev ino mode nlink))
-         (if winp (lookup-login-name uid))))))
+            :format-control "~S doesn't exist."
+            :format-arguments (list file)))
+    (multiple-value-bind (winp dev ino mode nlink uid)
+       (sb!unix:unix-stat name)
+      (declare (ignore dev ino mode nlink))
+      (and winp (sb!unix:uid-username uid)))))

 \f
 ;;;; DIRECTORY
 
 (/show0 "filesys.lisp 800")
 
 \f
 ;;;; DIRECTORY
 
 (/show0 "filesys.lisp 800")
 

-(defun directory (pathname &key (all t) (check-for-subdirs t)
-                          (follow-links t))
-  #!+sb-doc
-  "Returns a list of pathnames, one for each file that matches the given
-   pathname. Supplying :ALL as NIL causes this to ignore Unix dot files. This
-   never includes Unix dot and dot-dot in the result. If :FOLLOW-LINKS is NIL,
-   then symbolic links in the result are not expanded. This is not the
-   default because TRUENAME does follow links, and the result pathnames are
-   defined to be the TRUENAME of the pathname (the truename of a link may well
-   be in another directory.)"
-  (let ((results nil))
-    (enumerate-search-list
-       (pathname (merge-pathnames pathname
-                                  (make-pathname :name :wild
-                                                 :type :wild
-                                                 :version :wild)))
-      (enumerate-matches (name pathname)
-       (when (or all
-                 (let ((slash (position #\/ name :from-end t)))
-                   (or (null slash)
-                       (= (1+ slash) (length name))
-                       (char/= (schar name (1+ slash)) #\.))))
-         (push name results))))
-    (let ((*ignore-wildcards* t))
-      (mapcar (lambda (name)
-               (let ((name (if (and check-for-subdirs
-                                    (eq (sb!unix:unix-file-kind name)
-                                        :directory))
-                               (concatenate 'string name "/")
-                               name)))
-                 (if follow-links (truename name) (pathname name))))
-             (sort (delete-duplicates results :test #'string=) #'string<)))))
-\f
-;;;; translating Unix uid's
-;;;;
-;;;; FIXME: should probably move into unix.lisp
-
-(defvar *uid-hash-table* (make-hash-table)
-  #!+sb-doc
-  "hash table for keeping track of uid's and login names")
-
-(/show0 "filesys.lisp 844")
-
-;;; 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 keeps the files from having to be
-;;; 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)))))
-
-;;; 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.
-;;;
-;;; FIXME: Now that we no longer have lookup-group-name, we no longer need
-;;; the GROUP-OR-USER argument.
-(defun get-group-or-user-name (group-or-user id)
+(defun directory (pathname &key)

   #!+sb-doc
   #!+sb-doc

-  "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)))))
-
-;;; FIXME: Isn't there now a POSIX routine to parse the passwd file?
-;;; getpwent? getpwuid?
-(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))))))))))))
+  "Return a list of PATHNAMEs, each the TRUENAME of a file that matched the
+   given pathname. Note that the interaction between this ANSI-specified
+   TRUENAMEing and the semantics of the Unix filesystem (symbolic links..)
+   means this function can sometimes return files which don't have the same
+   directory as PATHNAME."
+  (let (;; We create one entry in this hash table for each truename,
+       ;; as an asymptotically efficient way of removing duplicates
+       ;; (which can arise when e.g. multiple symlinks map to the
+       ;; same truename).
+       (truenames (make-hash-table :test #'equal))
+        (merged-pathname (merge-pathnames pathname)))
+    (!enumerate-matches (match merged-pathname)
+      (let* ((*ignore-wildcards* t)
+            (truename (truename match)))
+        (setf (gethash (namestring truename) truenames)
+             truename)))
+    (mapcar #'cdr
+           ;; Sorting isn't required by the ANSI spec, but sorting
+           ;; into some canonical order seems good just on the
+           ;; grounds that the implementation should have repeatable
+           ;; behavior when possible.
+            (sort (loop for name being each hash-key in truenames
+                       using (hash-value truename)
+                        collect (cons name truename))
+                  #'string<
+                 :key #'car))))

 \f
 (/show0 "filesys.lisp 899")
 
 \f
 (/show0 "filesys.lisp 899")
 

@@ -995,79 +858,37 @@
                (t t)))
        xn)))
 \f
                (t t)))
        xn)))
 \f

-;;;; DEFAULT-DIRECTORY stuff
-;;;;
-;;;; FIXME: *DEFAULT-DIRECTORY-DEFAULTS* seems to be the ANSI way to
-;;;; deal with this, so we should beef up *DEFAULT-DIRECTORY-DEFAULTS*
-;;;; and make all the old DEFAULT-DIRECTORY stuff go away. (At that
-;;;; time the need for UNIX-CHDIR will go away too, I think.)
-
-(defun default-directory ()
-  #!+sb-doc
-  "Returns the pathname for the default directory. This is the place where
-  a file will be written if no directory is specified. This may be changed
-  with setf."
-  (multiple-value-bind (gr dir-or-error) (sb!unix:unix-current-directory)
-    (if gr
-       (let ((*ignore-wildcards* t))
-         (pathname (concatenate 'simple-string dir-or-error "/")))
-       (error dir-or-error))))
-
-(defun %set-default-directory (new-val)
-  (let ((namestring (unix-namestring new-val t)))
-    (unless namestring
-      (error "~S doesn't exist." new-val))
-    (multiple-value-bind (gr error) (sb!unix:unix-chdir namestring)
-      (if gr
-         (setf (search-list "default:") (default-directory))
-         (simple-file-perror "couldn't set default directory to ~S"
-                             new-val
-                             error)))
-    new-val))
-
-(/show0 "filesys.lisp 934")
-
-(/show0 "entering what used to be !FILESYS-COLD-INIT")
-(defvar *default-pathname-defaults*
-  (%make-pathname *unix-host* nil nil nil nil :newest))
-(setf (search-list "default:") (default-directory))
-(/show0 "leaving what used to be !FILESYS-COLD-INIT")
-\f

 (defun ensure-directories-exist (pathspec &key verbose (mode #o777))
   #!+sb-doc
 (defun ensure-directories-exist (pathspec &key verbose (mode #o777))
   #!+sb-doc

-  "Tests whether the directories containing the specified file
-  actually exist, and attempts to create them if they do not.
-  Portable programs should avoid using the :MODE argument."
-  (let* ((pathname (pathname pathspec))
-        (pathname (if (typep pathname 'logical-pathname)
-                      (translate-logical-pathname pathname)
-                      pathname))
-        (created-p nil))
+  "Test whether the directories containing the specified file
+  actually exist, and attempt to create them if they do not.
+  The MODE argument is a CMUCL/SBCL-specific extension to control
+  the Unix permission bits."
+  (let ((pathname (physicalize-pathname (pathname pathspec)))
+       (created-p nil))

     (when (wild-pathname-p pathname)
       (error 'simple-file-error
             :format-control "bad place for a wild pathname"
             :pathname pathspec))
     (when (wild-pathname-p pathname)
       (error 'simple-file-error
             :format-control "bad place for a wild pathname"
             :pathname pathspec))

-    (enumerate-search-list (pathname pathname)
-       (let ((dir (pathname-directory pathname)))
-        (loop for i from 1 upto (length dir)
-              do (let ((newpath (make-pathname
-                                 :host (pathname-host pathname)
-                                 :device (pathname-device pathname)
-                                 :directory (subseq dir 0 i))))
-                   (unless (probe-file newpath)
-                     (let ((namestring (namestring newpath)))
-                       (when verbose
-                         (format *standard-output*
-                                 "~&creating directory: ~A~%"
-                                 namestring))
-                       (sb!unix:unix-mkdir namestring mode)
-                       (unless (probe-file namestring)
-                         (error 'simple-file-error
-                                :pathname pathspec
-                                :format-control "can't create directory ~A"
-                                :format-arguments (list namestring)))
-                       (setf created-p t)))))
-        ;; Only the first path in a search-list is considered.
-        (return (values pathname created-p))))))
+    (let ((dir (pathname-directory pathname)))
+      (loop for i from 1 upto (length dir)
+           do (let ((newpath (make-pathname
+                              :host (pathname-host pathname)
+                              :device (pathname-device pathname)
+                              :directory (subseq dir 0 i))))
+                (unless (probe-file newpath)
+                  (let ((namestring (namestring newpath)))
+                    (when verbose
+                      (format *standard-output*
+                              "~&creating directory: ~A~%"
+                              namestring))
+                    (sb!unix:unix-mkdir namestring mode)
+                    (unless (probe-file namestring)
+                      (error 'simple-file-error
+                             :pathname pathspec
+                             :format-control "can't create directory ~A"
+                             :format-arguments (list namestring)))
+                    (setf created-p t)))))
+      (values pathname created-p))))

 
 (/show0 "filesys.lisp 1000")
 
 (/show0 "filesys.lisp 1000")