X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffilesys.lisp;h=849d66ed4baaa9a4e7ca1b9699e18e0b9fd5a4a2;hb=5d0643d3b70aade43037e8b7cdf39b7e12f5d3fd;hp=89658f2940c56a80bc8bbd3030c6c9aaff997aa0;hpb=72408d179d7396904e25e9a3dc423d2634e65072;p=sbcl.git diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 89658f2..849d66e 100644 --- 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 ]]] -;;; directory := [ "/" | search-list ] { file "/" }* -;;; search-list := [^:/]*: +;;; directory := [ "/" ] { file "/" }* ;;; 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 @@ -57,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))) @@ -218,89 +215,68 @@ (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) - (type index start end)) + (type index 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)) - "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 @@ -353,11 +329,7 @@ (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 )) @@ -461,29 +433,6 @@ (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*) ;;;; wildcard matching stuff @@ -508,28 +457,22 @@ (/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 "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))) @@ -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))) - (/show0 "computed DIRECTORY") + (/noshow0 "computed DIRECTORY") (if directory - (ecase (car directory) + (ecase (first directory) (:absolute - (/show0 "absolute directory") - (%enumerate-directories "/" (cdr directory) pathname + (/noshow0 "absolute directory") + (%enumerate-directories "/" (rest directory) pathname 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)))) @@ -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))) + ,@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 - (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)))) @@ -582,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)) @@ -593,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)) @@ -608,29 +558,30 @@ (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) - (let ((head (concatenate 'string head ".."))) + (with-directory-node-removed (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)))))) + 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)) - (/show0 "entering %ENUMERATE-FILES") + (/noshow0 "entering %ENUMERATE-FILES") (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)) - (/show0 "UNSPECIFIC, more or less") + (/noshow0 "UNSPECIFIC, more or less") (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)) - (/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 @@ -657,29 +608,27 @@ (components-match file-type type) (components-match file-version version)) (funcall function - (concatenate 'string + (concatenate 'base-string 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)) - (/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)))) - (/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)) - (/show0 "calling FUNCTION on FILE") + (/noshow0 "calling FUNCTION on FILE") (funcall function file))))))) -(/show0 "filesys.lisp 603") +(/noshow0 "filesys.lisp 603") ;;; 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) - (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)) @@ -708,72 +657,79 @@ ;;;; 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"))))) ;;;; 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 - "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 - :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 - "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." - (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)))))))) ;;;; miscellaneous other operations @@ -821,165 +777,72 @@ t) ;;; (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)) - ;; 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" - (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 - "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 - "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))))) ;;;; 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<))))) - -;;;; 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 - "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)))) (/show0 "filesys.lisp 899") @@ -995,79 +858,37 @@ (t t))) xn))) -;;;; 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") - (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)) - (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")