X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffilesys.lisp;h=6985a3d0ff6fb0bb9f3df92761bfccb8bbdeaad1;hb=7e6637658236983ecbabea50f167fb9d3c5ed505;hp=6cd4c4094fecd5de496e8d4365671fd3d25350af;hpb=1c347eae5ec81b6f41db9d27c1fe6d34abe1d3ca;p=sbcl.git diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 6cd4c40..6985a3d 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -415,7 +415,7 @@ (let* ((pathname-directory (%pathname-directory pathname)) (defaults-directory (%pathname-directory defaults)) (prefix-len (length defaults-directory)) - (result-dir + (result-directory (cond ((and (> prefix-len 1) (>= (length pathname-directory) prefix-len) (compare-component (subseq pathname-directory @@ -430,7 +430,7 @@ (t ;; We are a relative directory. So we lose. (lose))))) - (strings (unparse-unix-directory-list result-dir))) + (strings (unparse-unix-directory-list result-directory))) (let* ((pathname-version (%pathname-version pathname)) (version-needed (and pathname-version (not (eq pathname-version :newest)))) @@ -487,6 +487,25 @@ ;;;; wildcard matching stuff +;;; Return a list of all the Lispy filenames (not including e.g. the +;;; Unix magic "." and "..") in the directory named by DIRECTORY-NAME. +(defun directory-lispy-filenames (directory-name) + (with-alien ((adlf (* c-string) + (alien-funcall (extern-alien + "alloc_directory_lispy_filenames" + (function (* c-string) c-string)) + directory-name))) + (if (null-alien adlf) + (error 'simple-file-error + :pathname directory-name + :format-control "~@" + :format-arguments (list directory-name (strerror))) + (unwind-protect + (c-strings->string-list adlf) + (alien-funcall (extern-alien "free_directory_lispy_filenames" + (function void (* c-string))) + adlf))))) + (/show0 "filesys.lisp 498") ;;; FIXME: could maybe be EVAL-WHEN (COMPILE EVAL) @@ -495,10 +514,11 @@ &key (verify-existence t) (follow-links t)) &body body) - (let ((body-name (gensym))) + (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 @@ -507,6 +527,7 @@ (/show0 "filesys.lisp 500") +;;; Call FUNCTION on matches. (defun %enumerate-matches (pathname verify-existence follow-links function) (/show0 "entering %ENUMERATE-MATCHES") (when (pathname-type pathname) @@ -531,6 +552,7 @@ nil function))) (%enumerate-files "" pathname verify-existence function)))) +;;; Call FUNCTION on directories. (defun %enumerate-directories (head tail pathname verify-existence follow-links nodes function) (declare (simple-string head)) @@ -544,20 +566,7 @@ (when (and res (eql (logand mode sb!unix:s-ifmt) sb!unix:s-ifdir)) (let ((nodes (cons (cons dev ino) nodes))) - ,@body)))) - (do-directory-entries ((name directory) &body body) - `(let ((dir (sb!unix:open-dir ,directory))) - (when dir - (unwind-protect - (loop - (let ((,name (sb!unix:read-dir dir))) - (cond ((null ,name) - (return)) - ((string= ,name ".")) - ((string= ,name "..")) - (t - ,@body)))) - (sb!unix:close-dir dir)))))) + ,@body))))) (if tail (let ((piece (car tail))) (etypecase piece @@ -572,7 +581,7 @@ (%enumerate-directories head (rest tail) pathname verify-existence follow-links nodes function) - (do-directory-entries (name head) + (dolist (name (ignore-errors (directory-lispy-filenames head))) (let ((subdir (concatenate 'string head name))) (multiple-value-bind (res dev ino mode) (unix-xstat subdir) @@ -589,7 +598,7 @@ verify-existence follow-links nodes function)))))))) ((or pattern (member :wild)) - (do-directory-entries (name head) + (dolist (name (directory-lispy-filenames head)) (when (or (eq piece :wild) (pattern-matches piece name)) (let ((subdir (concatenate 'string head name))) (multiple-value-bind (res dev ino mode) @@ -612,6 +621,7 @@ 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") @@ -629,30 +639,27 @@ (eq name :wild) (eq type :wild)) (/show0 "WILD, more or less") - (let ((dir (sb!unix:open-dir directory))) - (when dir - (unwind-protect - (loop - (/show0 "at head of LOOP") - (let ((file (sb!unix:read-dir dir))) - (if file - (unless (or (string= file ".") - (string= file "..")) - (multiple-value-bind - (file-name file-type file-version) - (let ((*ignore-wildcards* t)) - (extract-name-type-and-version - file 0 (length file))) - (when (and (components-match file-name name) - (components-match file-type type) - (components-match file-version - version)) - (funcall function - (concatenate 'string - directory - file))))) - (return)))) - (sb!unix:close-dir dir))))) + ;; 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 + ;; exist, but I haven't tried to figure out whether + ;; everything is kosher. (E.g. what if we try to match a + ;; wildcard but we don't have permission to read one of the + ;; relevant directories?) -- WHN 2001-04-17 + (dolist (complete-filename (ignore-errors + (directory-lispy-filenames directory))) + (multiple-value-bind + (file-name file-type file-version) + (let ((*ignore-wildcards* t)) + (extract-name-type-and-version + complete-filename 0 (length complete-filename))) + (when (and (components-match file-name name) + (components-match file-type type) + (components-match file-version version)) + (funcall function + (concatenate 'string + directory + complete-filename)))))) (t (/show0 "default case") (let ((file (concatenate 'string directory name))) @@ -701,46 +708,73 @@ ;;;; 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* ((possibly-logical-pathname (pathname pathname-spec)) + (physical-pathname (if (typep possibly-logical-pathname + 'logical-pathname) + (namestring (translate-logical-pathname + possibly-logical-pathname)) + possibly-logical-pathname)) + (matches nil)) ; an accumulator for actual matches + (enumerate-matches (match physical-pathname 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, + "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." (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 @@ -753,20 +787,20 @@ ;;; 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 ((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)))))))) ;;;; miscellaneous other operations @@ -774,7 +808,7 @@ (defun rename-file (file new-name) #!+sb-doc - "Rename File to have the specified New-Name. If file is a stream open to a + "Rename FILE to have the specified NEW-NAME. If FILE is a stream open to a file, then the associated file is renamed." (let* ((original (truename file)) (original-namestring (unix-namestring original t)) @@ -790,16 +824,16 @@ (unless res (error 'simple-file-error :pathname new-name - :format-control "failed to rename ~A to ~A: ~A" - :format-arguments (list original new-name - (sb!unix:get-unix-error-msg error)))) + :format-control "~@" + :format-arguments (list original new-name (strerror error)))) (when (streamp file) (file-name file new-namestring)) (values new-name original (truename new-name))))) (defun delete-file (file) #!+sb-doc - "Delete the specified file." + "Delete the specified FILE." (let ((namestring (unix-namestring file t))) (when (streamp file) (close file :abort t)) @@ -808,21 +842,17 @@ :pathname file :format-control "~S doesn't exist." :format-arguments (list file))) - (multiple-value-bind (res err) (sb!unix:unix-unlink namestring) (unless res - (error 'simple-file-error - :pathname namestring - :format-control "could not delete ~A: ~A" - :format-arguments (list namestring - (sb!unix:get-unix-error-msg err)))))) + (simple-file-perror "couldn't delete ~A" namestring err)))) t) -;;; Return Home:, which is set up for us at initialization time. +;;; (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) - #!+sb-doc - "Returns the home directory of the logged in user as a pathname. - This is obtained from the logical name \"home:\"." + "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 @@ -992,11 +1022,18 @@ (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 + "Return 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." + with SETF." (multiple-value-bind (gr dir-or-error) (sb!unix:unix-current-directory) (if gr (let ((*ignore-wildcards* t)) @@ -1010,7 +1047,9 @@ (multiple-value-bind (gr error) (sb!unix:unix-chdir namestring) (if gr (setf (search-list "default:") (default-directory)) - (error (sb!unix:get-unix-error-msg error)))) + (simple-file-perror "couldn't set default directory to ~S" + new-val + error))) new-val)) (/show0 "filesys.lisp 934") @@ -1023,9 +1062,10 @@ (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." + "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 (pathname pathspec)) (pathname (if (typep pathname 'logical-pathname) (translate-logical-pathname pathname)