;;;; files for more information.
(in-package "SB!IMPL")
-
-(file-comment
- "$Header$")
\f
;;;; Unix pathname host support
(position #\. namestr :start (1+ start)
:end last-dot :from-end t)))
(version :newest))
- ;; If there is a second-to-last dot, check to see whether there is a valid
- ;; version after the last dot.
+ ;; If there is a second-to-last dot, check to see whether there is
+ ;; a valid version after the last dot.
(when second-to-last-dot
(cond ((and (= (+ last-dot 2) end)
(char= (schar namestr (1+ last-dot)) #\*))
(/show0 "filesys.lisp 200")
;;; Take a string and return a list of cons cells that mark the char
-;;; separated subseq. The first value t if absolute directories location.
+;;; separated subseq. The first value is true if absolute directories
+;;; location.
(defun split-at-slashes (namestr start end)
(declare (type simple-base-string namestr)
(type index start end))
(t
(pieces "/"))))
(:relative
- ;; Nothing special.
+ ;; nothing special
))
(dolist (dir directory)
(typecase dir
(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)
+
(defmacro enumerate-matches ((var pathname &optional result
- &key (verify-existence t))
+ &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
#',body-name)
,result))))
(/show0 "filesys.lisp 500")
-(defun %enumerate-matches (pathname verify-existence function)
+;;; Call FUNCTION on matches.
+(defun %enumerate-matches (pathname verify-existence follow-links function)
(/show0 "entering %ENUMERATE-MATCHES")
(when (pathname-type pathname)
(unless (pathname-name pathname)
(:absolute
(/show0 "absolute directory")
(%enumerate-directories "/" (cdr directory) pathname
- verify-existence function))
+ verify-existence follow-links
+ nil function))
(:relative
(/show0 "relative directory")
(%enumerate-directories "" (cdr directory) pathname
- verify-existence function)))
+ verify-existence follow-links
+ nil function)))
(%enumerate-files "" pathname verify-existence function))))
-(defun %enumerate-directories (head tail pathname verify-existence function)
+;;; Call FUNCTION on directories.
+(defun %enumerate-directories (head tail pathname verify-existence
+ follow-links nodes function)
(declare (simple-string head))
- (if tail
- (let ((piece (car tail)))
- (etypecase piece
- (simple-string
- (%enumerate-directories (concatenate 'string head piece "/")
- (cdr tail) pathname verify-existence
- function))
- ((or pattern (member :wild :wild-inferiors))
- (let ((dir (sb!unix:open-dir head)))
- (when dir
- (unwind-protect
- (loop
- (let ((name (sb!unix:read-dir dir)))
- (cond ((null name)
- (return))
- ((string= name "."))
- ((string= name ".."))
- ((pattern-matches piece name)
- (let ((subdir (concatenate 'string
- head name "/")))
- (when (eq (sb!unix:unix-file-kind subdir)
- :directory)
- (%enumerate-directories
- subdir (cdr tail) pathname verify-existence
- function)))))))
- (sb!unix:close-dir dir)))))
+ (macrolet ((unix-xstat (name)
+ `(if follow-links
+ (sb!unix:unix-stat ,name)
+ (sb!unix:unix-lstat ,name)))
+ (with-directory-node-noted ((head) &body body)
+ `(multiple-value-bind (res dev ino mode)
+ (unix-xstat ,head)
+ (when (and res (eql (logand mode sb!unix:s-ifmt)
+ sb!unix:s-ifdir))
+ (let ((nodes (cons (cons dev ino) nodes)))
+ ,@body)))))
+ (if tail
+ (let ((piece (car tail)))
+ (etypecase piece
+ (simple-string
+ (let ((head (concatenate 'string head piece)))
+ (with-directory-node-noted (head)
+ (%enumerate-directories (concatenate 'string head "/")
+ (cdr tail) pathname
+ verify-existence follow-links
+ nodes function))))
+ ((member :wild-inferiors)
+ (%enumerate-directories head (rest tail) pathname
+ verify-existence follow-links
+ nodes function)
+ (dolist (name (ignore-errors (directory-lispy-filenames head)))
+ (let ((subdir (concatenate 'string head name)))
+ (multiple-value-bind (res dev ino mode)
+ (unix-xstat subdir)
+ (declare (type (or fixnum null) mode))
+ (when (and res (eql (logand mode sb!unix:s-ifmt)
+ sb!unix:s-ifdir))
+ (unless (dolist (dir nodes nil)
+ (when (and (eql (car dir) dev)
+ (eql (cdr dir) ino))
+ (return t)))
+ (let ((nodes (cons (cons dev ino) nodes))
+ (subdir (concatenate 'string subdir "/")))
+ (%enumerate-directories subdir tail pathname
+ verify-existence follow-links
+ nodes function))))))))
+ ((or pattern (member :wild))
+ (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)
+ (unix-xstat subdir)
+ (declare (type (or fixnum null) mode))
+ (when (and res
+ (eql (logand mode sb!unix:s-ifmt)
+ sb!unix:s-ifdir))
+ (let ((nodes (cons (cons dev ino) nodes))
+ (subdir (concatenate 'string subdir "/")))
+ (%enumerate-directories subdir (rest tail) pathname
+ verify-existence follow-links
+ nodes function))))))))
((member :up)
- (%enumerate-directories (concatenate 'string head "../")
- (cdr tail) pathname verify-existence
- function))))
- (%enumerate-files head pathname verify-existence function)))
-
-;;; REMOVEME after finding bug.
-#!+sb-show (defvar *show-directory*)
-#!+sb-show (defvar *show-name*)
+ (let ((head (concatenate 'string head "..")))
+ (with-directory-node-noted (head)
+ (%enumerate-directories (concatenate 'string head "/")
+ (rest tail) pathname
+ verify-existence follow-links
+ 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")
-
- ;; Put DIRECTORY and NAME somewhere we can find them even when
- ;; things are too screwed up for the debugger.
- #!+sb-show (progn
- (setf *show-directory* directory
- *show-name* name))
-
(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")
\f
;;;; 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?
- (/show0 "entering UNIX-NAMESTRING")
- (let ((path (let ((lpn (pathname pathname)))
- (if (typep lpn 'logical-pathname)
- (namestring (translate-logical-pathname lpn))
- pathname))))
- (/show0 "PATH computed, enumerating search list")
- (enumerate-search-list
- (pathname path)
- (collect ((names))
- (/show0 "collecting 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)))
- (/show0 "NAMES collected")
- (let ((names (names)))
- (when names
- (/show0 "NAMES is true.")
- (when (cdr names)
- (/show0 "Alas! CDR NAMES")
- (error 'simple-file-error
- :format-control "~S is ambiguous:~{~% ~A~}"
- :format-arguments (list pathname names)))
- (/show0 "returning from UNIX-NAMESTRING")
- (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)))))))
\f
;;;; 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
;;; 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
- otherwise. An error of type file-error is signaled if pathname is wild."
- (/show0 "entering PROBE-FILE")
- (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)))
- (/show0 "NAMESTRING computed")
- (when (and namestring (sb!unix:unix-file-kind namestring))
- (/show0 "NAMESTRING is promising.")
- (let ((truename (sb!unix:unix-resolve-links
- (sb!unix:unix-maybe-prepend-current-directory
- namestring))))
- (/show0 "TRUENAME computed")
- (when truename
- (/show0 "TRUENAME is true.")
- (let ((*ignore-wildcards* t))
- (pathname (sb!unix:unix-simplify-pathname truename)))))))))
+ "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."
+ (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))))))))
\f
;;;; miscellaneous other operations
(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
+ "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))
(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")
-(defun !filesys-cold-init ()
- (/show0 "entering !FILESYS-COLD-INIT")
- (setf *default-pathname-defaults*
- (%make-pathname *unix-host* nil nil nil nil :newest))
- (setf (search-list "default:") (default-directory))
- (/show0 "leaving !FILESYS-COLD-INIT")
- nil)
+(/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")
\f
(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 keyword 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)
projects / sbcl.git / blobdiff