X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffilesys.lisp;h=bde23dcb7fb2d6a1640cdd4ad8d011f73fdea31b;hb=8fa3b333d2b37f45c3702f478f784b8c6f491080;hp=d36f8c963f60dc4e991c4d42668383419cd8ee0f;hpb=4eb1a6d3ad2b7dcc19ac0ec979a1eb1eb049659a;p=sbcl.git diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index d36f8c9..bde23dc 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -215,107 +215,68 @@ (setf start (1+ slash)))) (values absolute (pieces))))) -;;; the thing before a colon in a logical path -(def!struct (logical-hostname (:make-load-form-fun - (lambda (x) - (values `(make-logical-hostname - ,(logical-hostname-name x)) - nil))) - (:copier nil) - (:constructor make-logical-hostname (name))) - (name (missing-arg) :type simple-string)) - -(defun maybe-extract-logical-hostname (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 (make-logical-hostname - (remove-backslashes namestr start index)) - (1+ index))))))))) - (defun parse-unix-namestring (namestr start end) (declare (type simple-base-string namestr) (type index start end)) (multiple-value-bind (absolute pieces) (split-at-slashes namestr start end) - (let ((logical-hostname - (if absolute - nil - (let ((first (car pieces))) - (multiple-value-bind (logical-hostname new-start) - (maybe-extract-logical-hostname namestr - (car first) - (cdr first)) - (when logical-hostname - (setf absolute t) - (setf (car first) new-start)) - logical-hostname))))) - (declare (type (or null logical-hostname) logical-hostname)) - (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)) - (when logical-hostname - (dirs logical-hostname)) - (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 @@ -368,17 +329,7 @@ (when directory (ecase (pop directory) (:absolute - (cond ((logical-hostname-p (car directory)) - ;; FIXME: The old CMU CL "search list" extension is - ;; gone, but the old machinery is still being used - ;; clumsily here and elsewhere, to represent anything - ;; which belongs before a colon prefix in the ANSI - ;; pathname machinery. This should be cleaned up, - ;; using simpler machinery with more mnemonic names. - (pieces (logical-hostname-name (pop directory))) - (pieces ":")) - (t - (pieces "/")))) + (pieces "/")) (:relative ;; nothing special )) @@ -531,15 +482,15 @@ (let ((directory (pathname-directory pathname))) (/noshow0 "computed DIRECTORY") (if directory - (ecase (car directory) + (ecase (first directory) (:absolute (/noshow0 "absolute directory") - (%enumerate-directories "/" (cdr directory) pathname + (%enumerate-directories "/" (rest directory) pathname verify-existence follow-links nil function)) (:relative (/noshow0 "relative directory") - (%enumerate-directories "" (cdr directory) pathname + (%enumerate-directories "" (rest directory) pathname verify-existence follow-links nil function))) (%enumerate-files "" pathname verify-existence function)))) @@ -558,6 +509,13 @@ (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))) @@ -605,12 +563,13 @@ verify-existence follow-links nodes function)))))))) ((member :up) + (with-directory-node-removed (head) (let ((head (concatenate 'string head ".."))) (with-directory-node-noted (head) (%enumerate-directories (concatenate 'string head "/") (rest tail) pathname verify-existence follow-links - nodes function)))))) + nodes function))))))) (%enumerate-files head pathname verify-existence function)))) ;;; Call FUNCTION on files. @@ -655,8 +614,7 @@ (t (/noshow0 "default case") (let ((file (concatenate 'string directory name))) - (/noshow0 "computed basic FILE=..") - (/primitive-print file) + (/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))) @@ -664,8 +622,7 @@ (/noshow0 "tweaking FILE for more-or-less-:WILD case") (setf file (concatenate 'string file "." (quick-integer-to-string version)))) - (/noshow0 "finished possibly tweaking FILE=..") - (/primitive-print file) + (/noshow0 "finished possibly tweaking FILE") (when (or (not verify-existence) (sb!unix:unix-file-kind file t)) (/noshow0 "calling FUNCTION on FILE") @@ -720,33 +677,21 @@ ;;; 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)) - ;; The ordinary rules of converting Lispy paths to Unix paths break - ;; down for the current working directory, which Lisp thinks of as - ;; "" (more or less, and modulo ANSI's *DEFAULT-PATHNAME-DEFAULTS*, - ;; which unfortunately SBCL, as of sbcl-0.6.12.8, basically ignores) - ;; and Unix thinks of as ".". Since we're at the interface between - ;; Unix system calls and things like ENSURE-DIRECTORIES-EXIST which - ;; think the Lisp way, we perform the conversion. - ;; - ;; (FIXME: The *right* way to deal with this special case is to - ;; merge PATHNAME-SPEC with *DEFAULT-PATHNAME-DEFAULTS* here, after - ;; which it's not a relative pathname any more so the special case - ;; is no longer an issue. But until *DEFAULT-PATHNAME-DEFAULTS* - ;; works, we use this hack.) - (if (empty-relative-pathname-spec-p pathname-spec) - "." - ;; Otherwise, the ordinary rules apply. - (let* ((namestring (physicalize-pathname (pathname pathname-spec))) - (matches nil)) ; an accumulator for actual matches - (!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))))))) + (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 @@ -760,27 +705,19 @@ 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))) + :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, 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))) @@ -837,63 +774,39 @@ 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 - "Return the file author as a string, or nil if the author cannot be + "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)) - (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 @@ -907,14 +820,12 @@ 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 fast way of removing duplicates (which - ;; can arise when e.g. multiple symlinks map to the same - ;; 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 - (make-pathname :name :wild - :type :wild - :version :wild)))) + *default-pathname-defaults*))) (!enumerate-matches (match merged-pathname) (let ((*ignore-wildcards* t) (truename (truename (if (eq (sb!unix:unix-file-kind match) @@ -934,71 +845,6 @@ #'string< :key #'car)))) -;;;; 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. -;;; -;;; The result is a SIMPLE-STRING or NIL. -;;; -;;; 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) - (declare (type (member :group :user) group-or-user)) - (declare (type index id)) - (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)))))))))))) - (/show0 "filesys.lisp 899") ;;; predicate to order pathnames by; goes by name