X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffilesys.lisp;h=32a48ef84e080379d735d977da94f2ee0f5c5046;hb=f8893c7c658bf9d9e0757c63e47af2fdea810f04;hp=05809d304df882ba130ca32e3566db1a67073911;hpb=b48a0ada03337a26f59744ed1df794b21420ea90;p=sbcl.git diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 05809d3..32a48ef 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -54,7 +54,7 @@ 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))) @@ -272,7 +272,11 @@ (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 @@ -517,9 +521,9 @@ (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) - (%enumerate-directories (concatenate 'string head "/") + (%enumerate-directories (concatenate 'base-string head "/") (cdr tail) pathname verify-existence follow-links nodes function)))) @@ -528,7 +532,7 @@ 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)) @@ -539,14 +543,14 @@ (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)) - (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)) @@ -554,15 +558,15 @@ (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) (with-directory-node-removed (head) - (let ((head (concatenate 'string head ".."))) + (let ((head (concatenate 'base-string head ".."))) (with-directory-node-noted (head) - (%enumerate-directories (concatenate 'string head "/") + (%enumerate-directories (concatenate 'base-string head "/") (rest tail) pathname verify-existence follow-links nodes function))))))) @@ -604,19 +608,19 @@ (components-match file-type type) (components-match file-version version)) (funcall function - (concatenate 'string + (concatenate 'base-string directory complete-filename)))))) (t (/noshow0 "default case") - (let ((file (concatenate 'string directory name))) + (let ((file (concatenate 'base-string directory name))) (/noshow "computed basic FILE") (unless (or (null type) (eq type :unspecific)) (/noshow0 "tweaking FILE for more-or-less-:UNSPECIFIC case") - (setf file (concatenate 'string file "." type))) - (unless (member version '(nil :newest :wild)) + (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 'string file "." + (setf file (concatenate 'base-string file "." (quick-integer-to-string version)))) (/noshow0 "finished possibly tweaking FILE") (when (or (not verify-existence) @@ -634,11 +638,11 @@ ((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))) - (res (make-string len)) + (res (make-string len :element-type 'base-char)) (i (1- len) (1- i)) (q n) (r 0)) @@ -678,14 +682,16 @@ (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 (error 'simple-file-error - :format-control "~S is ambiguous:~{~% ~A~}" - :format-arguments (list pathname-spec matches)))))) + (t (bug "!ENUMERATE-MATCHES returned more than one match on a non-wild pathname"))))) ;;;; TRUENAME and PROBE-FILE @@ -699,27 +705,18 @@ Under Unix, the TRUENAME of a broken symlink is considered to be the name of the broken symlink itself." - (if (wild-pathname-p pathname) + (let ((result (probe-file pathname))) + (unless result (error 'simple-file-error - :format-control "can't use a wild pathname here" - :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))) - -;;; If PATHNAME exists, return its truename, otherwise NIL. + :pathname pathname + :format-control "The file ~S does not exist." + :format-arguments (list (namestring pathname)))) + result)) + (defun probe-file (pathname) #!+sb-doc "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." - (when (wild-pathname-p pathname) - (error 'simple-file-error - :pathname pathname - :format-control "can't use a wild pathname here")) (let* ((defaulted-pathname (merge-pathnames pathname (sane-default-pathname-defaults))) @@ -727,8 +724,11 @@ (when (and namestring (sb!unix:unix-file-kind namestring t)) (let ((trueishname (sb!unix:unix-resolve-links namestring))) (when trueishname - (let ((*ignore-wildcards* t)) - (pathname (sb!unix:unix-simplify-pathname 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)))))))) ;;;; miscellaneous other operations @@ -785,43 +785,30 @@ #!+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 "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." - (if (wild-pathname-p file) + (let ((name (unix-namestring (pathname file) t))) + (unless name (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)) - (and winp (sb!unix:uid-username 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))))) ;;;; DIRECTORY @@ -839,16 +826,19 @@ ;; (which can arise when e.g. multiple symlinks map to the ;; same truename). (truenames (make-hash-table :test #'equal)) - (merged-pathname (merge-pathnames pathname - *default-pathname-defaults*))) + (merged-pathname (merge-pathnames pathname))) (!enumerate-matches (match merged-pathname) - (let ((*ignore-wildcards* t) - (truename (truename (if (eq (sb!unix:unix-file-kind match) - :directory) - (concatenate 'string match "/") - match)))) - (setf (gethash (namestring truename) truenames) - truename))) + (let* ((*ignore-wildcards* t) + ;; FIXME: Why not TRUENAME? As reported by Milan Zamazal + ;; sbcl-devel 2003-10-05, using TRUENAME causes a race + ;; condition whereby removal of a file during the + ;; directory operation causes an error. It's not clear + ;; what the right thing to do is, though. -- CSR, + ;; 2003-10-13 + (truename (probe-file match))) + (when truename + (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