;;;; 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")
(/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)))
`(block nil
,@body))
(%enumerate-matches (pathname ,pathname)
,verify-existence
+ ,follow-links
#',body-name)
,result))))
(/show0 "filesys.lisp 500")
-(defun %enumerate-matches (pathname verify-existence function)
+(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)
+(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)))
+ (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))))
+ (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)
+ (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)))))
+ ((string= ,name "."))
+ ((string= ,name ".."))
+ (t
+ ,@body))))
+ (sb!unix:close-dir dir))))))
+ (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)
+ (do-directory-entries (name 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))
+ (do-directory-entries (name 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)))
+ (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))))
(defun %enumerate-files (directory pathname verify-existence function)
(declare (simple-string directory))
(/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")
;; 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)
(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))))))))
\f
;;;; TRUENAME and PROBE-FILE
(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")
+ 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)))
- (/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)))))))))
\f
(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)))
(/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."
+ 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