(pieces "/"))
(t
(error "invalid directory component: ~S" dir)))))
- (unless (null (pieces))
- (apply #'concatenate 'simple-string (pieces)))))
+ (apply #'concatenate 'simple-string (pieces))))
(defun unparse-unix-directory (pathname)
(declare (type pathname pathname))
(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)))))
- (unless (null (strings))
- (apply #'concatenate 'simple-string (strings)))))
+ (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
(follow-links t))
#!+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
+ 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 symblolic links in the result are not expanded. This is not the
+ 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.)"
(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))))
+ (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<)))))
\f
;;;; translating Unix uid's
\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