X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffilesys.lisp;h=ca9a19f067872caeec2a6d1a297f2d21d845a9d3;hb=80304981972c91c1b3f3fca75f36dacf1fecf307;hp=746db696bd37ec078d38451cda56bd8b4b16a955;hpb=416152f084604094445a758ff399871132dff2bd;p=sbcl.git diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 746db69..ca9a19f 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -223,7 +223,7 @@ nil))) (:copier nil) (:constructor make-logical-hostname (name))) - (name (required-argument) :type simple-string)) + (name (missing-arg) :type simple-string)) (defun maybe-extract-logical-hostname (namestr start end) (declare (type simple-base-string namestr) @@ -482,29 +482,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 @@ -554,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)))) @@ -581,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))) @@ -628,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. @@ -678,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))) @@ -687,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") @@ -900,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) @@ -916,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 @@ -929,91 +912,31 @@ 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 ((truenames nil) - (merged-pathname (merge-pathnames pathname - (make-pathname :name :wild - :type :wild - :version :wild)))) + (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 + *default-pathname-defaults*))) (!enumerate-matches (match merged-pathname) - (let ((*ignore-wildcards* t)) - (push (truename (if (eq (sb!unix:unix-file-kind match) :directory) - (concatenate 'string match "/") - match)) - truenames))) - ;; FIXME: The DELETE-DUPLICATES here requires quadratic time, - ;; which is unnecessarily slow. That might not be an issue, - ;; though, since the time constant for doing TRUENAME on every - ;; directory entry is likely to be (much) larger, and the cost of - ;; all those TRUENAMEs on a huge directory might even be quadratic - ;; in the directory size. Someone who cares about enormous - ;; directories might want to check this. -- WHN 2001-06-19 - (sort (delete-duplicates truenames :test #'string= :key #'pathname-name) - #'string< :key #'pathname-name))) - -;;;; 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) - #!+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)))))))))))) + (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))) + (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")