(collect ((strings))
(let* ((name (%pathname-name pathname))
(type (%pathname-type pathname))
- (type-supplied (not (or (null type) (eq type :unspecific))))
- (version (%pathname-version pathname))
- (version-supplied (not (or (null version) (eq version :newest)))))
+ (type-supplied (not (or (null type) (eq type :unspecific)))))
+ ;; Note: by ANSI 19.3.1.1.5, we ignore the version slot when
+ ;; translating logical pathnames to a filesystem without
+ ;; versions (like Unix).
(when name
(strings (unparse-unix-piece name)))
(when type-supplied
(unless name
(error "cannot specify the type without a file: ~S" pathname))
(strings ".")
- (strings (unparse-unix-piece type)))
- (when version-supplied
- (unless type-supplied
- (error "cannot specify the version without a type: ~S" pathname))
- (strings (if (eq version :wild)
- ".*"
- (format nil ".~D" version)))))
+ (strings (unparse-unix-piece type))))
(apply #'concatenate 'simple-string (strings))))
(/show0 "filesys.lisp 406")
(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
(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))))
\f
;;;; 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 "~@<couldn't read directory ~S: ~2I~_~A~:>"
+ :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)
&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
(/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)
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))
(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
(%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)
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)
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")
(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)))
(/show0 "computed basic FILE=..")
- #!+sb-show (%primitive print file)
+ (/primitive-print file)
(unless (or (null type) (eq type :unspecific))
(/show0 "tweaking FILE for more-or-less-:UNSPECIFIC case")
(setf file (concatenate 'string file "." type)))
(setf file (concatenate 'string file "."
(quick-integer-to-string version))))
(/show0 "finished possibly tweaking FILE=..")
- #!+sb-show (%primitive print file)
+ (/primitive-print file)
(when (or (not verify-existence)
(sb!unix:unix-file-kind file t))
(/show0 "calling FUNCTION on FILE")
(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))
(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 "~@<couldn't rename ~2I~_~A ~I~_to ~2I~_~A: ~
+ ~I~_~A~:>"
+ :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))
: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)
\f
-;;; 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
\f
(/show0 "filesys.lisp 899")
-;;; Predicate to order pathnames by. Goes by name.
+;;; predicate to order pathnames by; goes by name
(defun pathname-order (x y)
(let ((xn (%pathname-name x))
(yn (%pathname-name y)))
(t t)))
xn)))
\f
+;;;; 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
(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")
#!+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 keyword argument."
+ Portable programs should avoid using the :MODE argument."
(let* ((pathname (pathname pathspec))
(pathname (if (typep pathname 'logical-pathname)
(translate-logical-pathname pathname)
projects / sbcl.git / blobdiff