X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffilesys.lisp;h=ca9a19f067872caeec2a6d1a297f2d21d845a9d3;hb=74a48d09e08aead6f67204878bdf9be4f448e1e8;hp=31cb86cc9b48f06470e2294dc923e46ac81bd5f6;hpb=718b3ccc610d1255f928fa75059f035638b57f94;p=sbcl.git diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 31cb86c..ca9a19f 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -531,15 +531,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 +558,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 +612,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 +663,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 +671,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") @@ -787,13 +793,9 @@ (namestring (unix-namestring defaulted-pathname t))) (when (and namestring (sb!unix:unix-file-kind namestring t)) (let ((trueishname (sb!unix:unix-resolve-links namestring))) - (/show0 "back from UNIX-RESOLVE-LINKS in PROBE-FILE") (when trueishname (let ((*ignore-wildcards* t)) - (/show0 "calling UNIX-SIMPLIFY-PATHNAME in PROBE-FILE") - (prog1 - (pathname (sb!unix:unix-simplify-pathname trueishname)) - (/show0 "back from UNIX-SIMPLIFY-PATHNAME in PROBE-FILE")))))))) + (pathname (sb!unix:unix-simplify-pathname trueishname)))))))) ;;;; miscellaneous other operations @@ -881,7 +883,7 @@ (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) @@ -897,7 +899,7 @@ (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)))))) + (and winp (sb!unix:uid-username uid)))))) ;;;; DIRECTORY @@ -911,14 +913,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) @@ -938,71 +938,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