X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffilesys.lisp;h=89658f2940c56a80bc8bbd3030c6c9aaff997aa0;hb=4cf50b1896b25f5337e7c258b0b560da00d47993;hp=540fe553df0541d297b807a8309f1544e37c1f82;hpb=9c79328c5c2bb1233089126fe9c69af69435b837;p=sbcl.git diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 540fe55..89658f2 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) @@ -508,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) @@ -532,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)) @@ -545,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 @@ -573,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) @@ -590,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) @@ -613,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") @@ -630,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))) @@ -775,7 +781,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)) @@ -791,16 +797,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)) @@ -809,21 +815,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 @@ -993,6 +995,13 @@ (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 @@ -1011,7 +1020,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")