X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffilesys.lisp;h=145dae3fc1987569f66536877dce17ab5b504e67;hb=b5703d98da9ebfd688c87e14862ab4e26dc94d14;hp=89658f2940c56a80bc8bbd3030c6c9aaff997aa0;hpb=72408d179d7396904e25e9a3dc423d2634e65072;p=sbcl.git diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 89658f2..145dae3 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -529,7 +529,7 @@ ;;; 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,16 +537,16 @@ (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) (:absolute - (/show0 "absolute directory") + (/noshow0 "absolute directory") (%enumerate-directories "/" (cdr directory) pathname verify-existence follow-links nil function)) (:relative - (/show0 "relative directory") + (/noshow0 "relative directory") (%enumerate-directories "" (cdr directory) pathname verify-existence follow-links nil function))) @@ -624,13 +624,13 @@ ;;; 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 +638,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 @@ -661,25 +661,25 @@ directory complete-filename)))))) (t - (/show0 "default case") + (/noshow0 "default case") (let ((file (concatenate 'string directory name))) - (/show0 "computed basic FILE=..") + (/noshow0 "computed basic FILE=..") (/primitive-print file) (unless (or (null type) (eq type :unspecific)) - (/show0 "tweaking FILE for more-or-less-:UNSPECIFIC case") + (/noshow0 "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") + (/noshow0 "tweaking FILE for more-or-less-:WILD case") (setf file (concatenate 'string file "." (quick-integer-to-string version)))) - (/show0 "finished possibly tweaking FILE=..") + (/noshow0 "finished possibly tweaking FILE=..") (/primitive-print 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) @@ -708,46 +708,70 @@ ;;;; 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. Search-lists and +;;; wild-cards are expanded. +(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))))))) ;;;; 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." + "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." (if (wild-pathname-p pathname) (error 'simple-file-error - :format-control "bad place for a wild pathname" + :format-control "can't use a wild pathname here" :pathname pathname) (let ((result (probe-file pathname))) (unless result @@ -760,20 +784,21 @@ ;;; 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))))))))) + (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))) + (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)) + (pathname (sb!unix:unix-simplify-pathname trueishname)))))))) ;;;; miscellaneous other operations @@ -861,9 +886,9 @@ (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." + "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) (error 'simple-file-error :pathname file @@ -883,38 +908,34 @@ (/show0 "filesys.lisp 800") -(defun directory (pathname &key (all t) (check-for-subdirs t) - (follow-links t)) +(defun directory (pathname &key) #!+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)) + "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 ((truenames 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<))))) + (enumerate-matches (match 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 ;;;; @@ -995,54 +1016,14 @@ (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"