-;;;; file system interface functions -- fairly Unix-specific
+;;;; file system interface functions -- fairly Unix-centric, but with
+;;;; differences between Unix and Win32 papered over.
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
\f
;;;; Unix pathname host support
+;;; FIXME: the below shouldn't really be here, but in documentation
+;;; (chapter 19 makes a lot of requirements for documenting
+;;; implementation-dependent decisions), but anyway it's probably not
+;;; what we currently do.
+;;;
;;; Unix namestrings have the following format:
;;;
;;; namestring := [ directory ] [ file [ type [ version ]]]
-;;; directory := [ "/" | search-list ] { file "/" }*
-;;; search-list := [^:/]*:
+;;; directory := [ "/" ] { file "/" }*
;;; file := [^/]*
;;; type := "." [^/.]*
;;; version := "." ([0-9]+ | "*")
;;;
-;;; FIXME: Search lists are no longer supported.
-;;;
;;; Note: this grammar is ambiguous. The string foo.bar.5 can be
;;; parsed as either just the file specified or as specifying the
;;; file, type, and version. Therefore, we use the following rules
;;; - If the first character is a dot, it's part of the file. It is not
;;; considered a dot in the following rules.
;;;
-;;; - If there is only one dot, it separates the file and the type.
-;;;
-;;; - If there are multiple dots and the stuff following the last dot
-;;; is a valid version, then that is the version and the stuff between
-;;; the second to last dot and the last dot is the type.
+;;; - Otherwise, the last dot separates the file and the type.
;;;
;;; Wildcard characters:
;;;
;;; following characters, it is considered part of a wildcard pattern
;;; and has the following meaning.
;;;
-;;; ? - matches any character
+;;; ? - matches any one character
;;; * - matches any zero or more characters.
;;; [abc] - matches any of a, b, or c.
;;; {str1,str2,...,strn} - matches any of str1, str2, ..., or strn.
+;;; (FIXME: no it doesn't)
;;;
;;; Any of these special characters can be preceded by a backslash to
;;; cause it to be treated as a regular character.
#!+sb-doc
"Remove any occurrences of #\\ from the string because we've already
checked for whatever they may have protected."
- (declare (type simple-base-string namestr)
- (type index start end))
- (let* ((result (make-string (- end start)))
- (dst 0)
- (quoted nil))
+ (declare (type simple-string namestr)
+ (type index start end))
+ (let* ((result (make-string (- end start) :element-type 'character))
+ (dst 0)
+ (quoted nil))
(do ((src start (1+ src)))
- ((= src end))
+ ((= src end))
(cond (quoted
- (setf (schar result dst) (schar namestr src))
- (setf quoted nil)
- (incf dst))
- (t
- (let ((char (schar namestr src)))
- (cond ((char= char #\\)
- (setq quoted t))
- (t
- (setf (schar result dst) char)
- (incf dst)))))))
+ (setf (schar result dst) (schar namestr src))
+ (setf quoted nil)
+ (incf dst))
+ (t
+ (let ((char (schar namestr src)))
+ (cond ((char= char #\\)
+ (setq quoted t))
+ (t
+ (setf (schar result dst) char)
+ (incf dst)))))))
(when quoted
(error 'namestring-parse-error
- :complaint "backslash in a bad place"
- :namestring namestr
- :offset (1- end)))
- (shrink-vector result dst)))
-
-(defvar *ignore-wildcards* nil)
-
-(/show0 "filesys.lisp 86")
+ :complaint "backslash in a bad place"
+ :namestring namestr
+ :offset (1- end)))
+ (%shrink-vector result dst)))
(defun maybe-make-pattern (namestr start end)
- (declare (type simple-base-string namestr)
- (type index start end))
- (if *ignore-wildcards*
- (subseq namestr start end)
- (collect ((pattern))
- (let ((quoted nil)
- (any-quotes nil)
- (last-regular-char nil)
- (index start))
- (flet ((flush-pending-regulars ()
- (when last-regular-char
- (pattern (if any-quotes
- (remove-backslashes namestr
- last-regular-char
- index)
- (subseq namestr last-regular-char index)))
- (setf any-quotes nil)
- (setf last-regular-char nil))))
- (loop
- (when (>= index end)
- (return))
- (let ((char (schar namestr index)))
- (cond (quoted
- (incf index)
- (setf quoted nil))
- ((char= char #\\)
- (setf quoted t)
- (setf any-quotes t)
- (unless last-regular-char
- (setf last-regular-char index))
- (incf index))
- ((char= char #\?)
- (flush-pending-regulars)
- (pattern :single-char-wild)
- (incf index))
- ((char= char #\*)
- (flush-pending-regulars)
- (pattern :multi-char-wild)
- (incf index))
- ((char= char #\[)
- (flush-pending-regulars)
- (let ((close-bracket
- (position #\] namestr :start index :end end)))
- (unless close-bracket
- (error 'namestring-parse-error
- :complaint "#\\[ with no corresponding #\\]"
- :namestring namestr
- :offset index))
- (pattern (list :character-set
- (subseq namestr
- (1+ index)
- close-bracket)))
- (setf index (1+ close-bracket))))
- (t
- (unless last-regular-char
- (setf last-regular-char index))
- (incf index)))))
- (flush-pending-regulars)))
- (cond ((null (pattern))
- "")
- ((null (cdr (pattern)))
- (let ((piece (first (pattern))))
- (typecase piece
- ((member :multi-char-wild) :wild)
- (simple-string piece)
- (t
- (make-pattern (pattern))))))
- (t
- (make-pattern (pattern)))))))
-
-(/show0 "filesys.lisp 160")
-
-(defun extract-name-type-and-version (namestr start end)
- (declare (type simple-base-string namestr)
- (type index start end))
- (let* ((last-dot (position #\. namestr :start (1+ start) :end end
- :from-end t))
- (second-to-last-dot (and last-dot
- (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.
- (when second-to-last-dot
- (cond ((and (= (+ last-dot 2) end)
- (char= (schar namestr (1+ last-dot)) #\*))
- (setf version :wild))
- ((and (< (1+ last-dot) end)
- (do ((index (1+ last-dot) (1+ index)))
- ((= index end) t)
- (unless (char<= #\0 (schar namestr index) #\9)
- (return nil))))
- (setf version
- (parse-integer namestr :start (1+ last-dot) :end end)))
- (t
- (setf second-to-last-dot nil))))
- (cond (second-to-last-dot
- (values (maybe-make-pattern namestr start second-to-last-dot)
- (maybe-make-pattern namestr
- (1+ second-to-last-dot)
- last-dot)
- version))
- (last-dot
- (values (maybe-make-pattern namestr start last-dot)
- (maybe-make-pattern namestr (1+ last-dot) end)
- version))
- (t
- (values (maybe-make-pattern namestr start end)
- nil
- version)))))
-
-(/show0 "filesys.lisp 200")
+ (declare (type simple-string namestr)
+ (type index start end))
+ (collect ((pattern))
+ (let ((quoted nil)
+ (any-quotes nil)
+ (last-regular-char nil)
+ (index start))
+ (flet ((flush-pending-regulars ()
+ (when last-regular-char
+ (pattern (if any-quotes
+ (remove-backslashes namestr
+ last-regular-char
+ index)
+ (subseq namestr last-regular-char index)))
+ (setf any-quotes nil)
+ (setf last-regular-char nil))))
+ (loop
+ (when (>= index end)
+ (return))
+ (let ((char (schar namestr index)))
+ (cond (quoted
+ (incf index)
+ (setf quoted nil))
+ ((char= char #\\)
+ (setf quoted t)
+ (setf any-quotes t)
+ (unless last-regular-char
+ (setf last-regular-char index))
+ (incf index))
+ ((char= char #\?)
+ (flush-pending-regulars)
+ (pattern :single-char-wild)
+ (incf index))
+ ((char= char #\*)
+ (flush-pending-regulars)
+ (pattern :multi-char-wild)
+ (incf index))
+ ((char= char #\[)
+ (flush-pending-regulars)
+ (let ((close-bracket
+ (position #\] namestr :start index :end end)))
+ (unless close-bracket
+ (error 'namestring-parse-error
+ :complaint "#\\[ with no corresponding #\\]"
+ :namestring namestr
+ :offset index))
+ (pattern (cons :character-set
+ (subseq namestr
+ (1+ index)
+ close-bracket)))
+ (setf index (1+ close-bracket))))
+ (t
+ (unless last-regular-char
+ (setf last-regular-char index))
+ (incf index)))))
+ (flush-pending-regulars)))
+ (cond ((null (pattern))
+ "")
+ ((null (cdr (pattern)))
+ (let ((piece (first (pattern))))
+ (typecase piece
+ ((member :multi-char-wild) :wild)
+ (simple-string piece)
+ (t
+ (make-pattern (pattern))))))
+ (t
+ (make-pattern (pattern))))))
-;;; Take a string and return a list of cons cells that mark the char
-;;; 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))
- (let ((absolute (and (/= start end)
- (char= (schar namestr start) #\/))))
- (when absolute
- (incf start))
- ;; Next, split the remainder into slash-separated chunks.
- (collect ((pieces))
- (loop
- (let ((slash (position #\/ namestr :start start :end end)))
- (pieces (cons start (or slash end)))
- (unless slash
- (return))
- (setf start (1+ slash))))
- (values absolute (pieces)))))
-
-(defun maybe-extract-search-list (namestr start end)
- (declare (type simple-base-string namestr)
- (type index start end))
- (let ((quoted nil))
- (do ((index start (1+ index)))
- ((= index end)
- (values nil start))
- (if quoted
- (setf quoted nil)
- (case (schar namestr index)
- (#\\
- (setf quoted t))
- (#\:
- (return (values (remove-backslashes namestr start index)
- (1+ index)))))))))
-
-(defun parse-unix-namestring (namestr start end)
- (declare (type simple-base-string namestr)
- (type index start end))
- (multiple-value-bind (absolute pieces) (split-at-slashes namestr start end)
- (let ((search-list (if absolute
- nil
- (let ((first (car pieces)))
- (multiple-value-bind (search-list new-start)
- (maybe-extract-search-list namestr
- (car first)
- (cdr first))
- (when search-list
- (setf absolute t)
- (setf (car first) new-start))
- search-list)))))
- (multiple-value-bind (name type version)
- (let* ((tail (car (last pieces)))
- (tail-start (car tail))
- (tail-end (cdr tail)))
- (unless (= tail-start tail-end)
- (setf pieces (butlast pieces))
- (extract-name-type-and-version namestr tail-start tail-end)))
- ;; PVE: make sure there are no illegal characters in
- ;; the name, illegal being (code-char 0) and #\/
- #!+high-security
- (when (and (stringp name)
- (find-if #'(lambda (x) (or (char= x (code-char 0))
- (char= x #\/)))
- name))
- (error 'parse-error))
-
- ;; Now we have everything we want. So return it.
- (values nil ; no host for unix namestrings.
- nil ; no devices for unix namestrings.
- (collect ((dirs))
- (when search-list
- (dirs (intern-search-list search-list)))
- (dolist (piece pieces)
- (let ((piece-start (car piece))
- (piece-end (cdr piece)))
- (unless (= piece-start piece-end)
- (cond ((string= namestr ".." :start1 piece-start
- :end1 piece-end)
- (dirs :up))
- ((string= namestr "**" :start1 piece-start
- :end1 piece-end)
- (dirs :wild-inferiors))
- (t
- (dirs (maybe-make-pattern namestr
- piece-start
- piece-end)))))))
- (cond (absolute
- (cons :absolute (dirs)))
- ((dirs)
- (cons :relative (dirs)))
- (t
- nil)))
- name
- type
- version)))))
-
-(/show0 "filesys.lisp 300")
-
-(defun unparse-unix-host (pathname)
- (declare (type pathname pathname)
- (ignore pathname))
- "Unix")
-
-(defun unparse-unix-piece (thing)
+(defun unparse-physical-piece (thing)
(etypecase thing
((member :wild) "*")
(simple-string
(let* ((srclen (length thing))
- (dstlen srclen))
+ (dstlen srclen))
(dotimes (i srclen)
- (case (schar thing i)
- ((#\* #\? #\[)
- (incf dstlen))))
+ (case (schar thing i)
+ ((#\* #\? #\[)
+ (incf dstlen))))
(let ((result (make-string dstlen))
- (dst 0))
- (dotimes (src srclen)
- (let ((char (schar thing src)))
- (case char
- ((#\* #\? #\[)
- (setf (schar result dst) #\\)
- (incf dst)))
- (setf (schar result dst) char)
- (incf dst)))
- result)))
+ (dst 0))
+ (dotimes (src srclen)
+ (let ((char (schar thing src)))
+ (case char
+ ((#\* #\? #\[)
+ (setf (schar result dst) #\\)
+ (incf dst)))
+ (setf (schar result dst) char)
+ (incf dst)))
+ result)))
(pattern
- (collect ((strings))
+ (with-output-to-string (s)
(dolist (piece (pattern-pieces thing))
- (etypecase piece
- (simple-string
- (strings piece))
- (symbol
- (ecase piece
- (:multi-char-wild
- (strings "*"))
- (:single-char-wild
- (strings "?"))))
- (cons
- (case (car piece)
- (:character-set
- (strings "[")
- (strings (cdr piece))
- (strings "]"))
- (t
- (error "invalid pattern piece: ~S" piece))))))
- (apply #'concatenate
- 'simple-string
- (strings))))))
-
-(defun unparse-unix-directory-list (directory)
- (declare (type list directory))
- (collect ((pieces))
- (when directory
- (ecase (pop directory)
- (:absolute
- (cond ((search-list-p (car directory))
- (pieces (search-list-name (pop directory)))
- (pieces ":"))
- (t
- (pieces "/"))))
- (:relative
- ;; nothing special
- ))
- (dolist (dir directory)
- (typecase dir
- ((member :up)
- (pieces "../"))
- ((member :back)
- (error ":BACK cannot be represented in namestrings."))
- ((member :wild-inferiors)
- (pieces "**/"))
- ((or simple-string pattern)
- (pieces (unparse-unix-piece dir))
- (pieces "/"))
- (t
- (error "invalid directory component: ~S" dir)))))
- (apply #'concatenate 'simple-string (pieces))))
-
-(defun unparse-unix-directory (pathname)
- (declare (type pathname pathname))
- (unparse-unix-directory-list (%pathname-directory pathname)))
-
-(defun unparse-unix-file (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)))))
- ;; 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))))
- (apply #'concatenate 'simple-string (strings))))
-
-(/show0 "filesys.lisp 406")
-
-(defun unparse-unix-namestring (pathname)
- (declare (type pathname pathname))
- (concatenate 'simple-string
- (unparse-unix-directory pathname)
- (unparse-unix-file pathname)))
-
-(defun unparse-unix-enough (pathname defaults)
- (declare (type pathname pathname defaults))
- (flet ((lose ()
- (error "~S cannot be represented relative to ~S."
- pathname defaults)))
- (collect ((strings))
- (let* ((pathname-directory (%pathname-directory pathname))
- (defaults-directory (%pathname-directory defaults))
- (prefix-len (length defaults-directory))
- (result-directory
- (cond ((and (> prefix-len 1)
- (>= (length pathname-directory) prefix-len)
- (compare-component (subseq pathname-directory
- 0 prefix-len)
- defaults-directory))
- ;; Pathname starts with a prefix of default. So
- ;; just use a relative directory from then on out.
- (cons :relative (nthcdr prefix-len pathname-directory)))
- ((eq (car pathname-directory) :absolute)
- ;; We are an absolute pathname, so we can just use it.
- pathname-directory)
- (t
- ;; We are a relative directory. So we lose.
- (lose)))))
- (strings (unparse-unix-directory-list result-directory)))
- (let* ((pathname-version (%pathname-version pathname))
- (version-needed (and pathname-version
- (not (eq pathname-version :newest))))
- (pathname-type (%pathname-type pathname))
- (type-needed (or version-needed
- (and pathname-type
- (not (eq pathname-type :unspecific)))))
- (pathname-name (%pathname-name pathname))
- (name-needed (or type-needed
- (and pathname-name
- (not (compare-component pathname-name
- (%pathname-name
- defaults)))))))
- (when name-needed
- (unless pathname-name (lose))
- (strings (unparse-unix-piece pathname-name)))
- (when type-needed
- (when (or (null pathname-type) (eq pathname-type :unspecific))
- (lose))
- (strings ".")
- (strings (unparse-unix-piece pathname-type)))
- (when version-needed
- (typecase pathname-version
- ((member :wild)
- (strings ".*"))
- (integer
- (strings (format nil ".~D" pathname-version)))
- (t
- (lose)))))
- (apply #'concatenate 'simple-string (strings)))))
+ (etypecase piece
+ (simple-string
+ (write-string piece s))
+ (symbol
+ (ecase piece
+ (:multi-char-wild
+ (write-string "*" s))
+ (:single-char-wild
+ (write-string "?" s))))
+ (cons
+ (case (car piece)
+ (:character-set
+ (write-string "[" s)
+ (write-string (cdr piece) s)
+ (write-string "]" s))
+ (t
+ (error "invalid pattern piece: ~S" piece))))))))))
-(/show0 "filesys.lisp 471")
+(defun make-matcher (piece)
+ (cond ((eq piece :wild)
+ (constantly t))
+ ((typep piece 'pattern)
+ (lambda (other)
+ (when (stringp other)
+ (pattern-matches piece other))))
+ (t
+ (lambda (other)
+ (equal piece other)))))
-(def!struct (unix-host
- (:make-load-form-fun make-unix-host-load-form)
- (:include host
- (parse #'parse-unix-namestring)
- (unparse #'unparse-unix-namestring)
- (unparse-host #'unparse-unix-host)
- (unparse-directory #'unparse-unix-directory)
- (unparse-file #'unparse-unix-file)
- (unparse-enough #'unparse-unix-enough)
- (customary-case :lower))))
-
-(/show0 "filesys.lisp 486")
+(/show0 "filesys.lisp 160")
-(defvar *unix-host* (make-unix-host))
+(defun extract-name-type-and-version (namestr start end)
+ (declare (type simple-string namestr)
+ (type index start end))
+ (let* ((last-dot (position #\. namestr :start (1+ start) :end end
+ :from-end t)))
+ (cond
+ (last-dot
+ (values (maybe-make-pattern namestr start last-dot)
+ (maybe-make-pattern namestr (1+ last-dot) end)
+ :newest))
+ (t
+ (values (maybe-make-pattern namestr start end)
+ nil
+ :newest)))))
-(/show0 "filesys.lisp 488")
+(/show0 "filesys.lisp 200")
-(defun make-unix-host-load-form (host)
- (declare (ignore host))
- '*unix-host*)
\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)
- (follow-links t))
- &body body)
- (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")
-
-;;; Call FUNCTION on matches.
-(defun %enumerate-matches (pathname verify-existence follow-links function)
- (/noshow0 "entering %ENUMERATE-MATCHES")
- (when (pathname-type pathname)
- (unless (pathname-name pathname)
- (error "cannot supply a type without a name:~% ~S" pathname)))
- (when (and (integerp (pathname-version pathname))
- (member (pathname-type pathname) '(nil :unspecific)))
- (error "cannot supply a version without a type:~% ~S" pathname))
- (let ((directory (pathname-directory pathname)))
- (/noshow0 "computed DIRECTORY")
- (if directory
- (ecase (car directory)
- (:absolute
- (/noshow0 "absolute directory")
- (%enumerate-directories "/" (cdr directory) pathname
- verify-existence follow-links
- nil function))
- (:relative
- (/noshow0 "relative directory")
- (%enumerate-directories "" (cdr directory) pathname
- verify-existence follow-links
- nil function)))
- (%enumerate-files "" pathname verify-existence function))))
+;;;; Grabbing the kind of file when we have a namestring.
+(defun native-file-kind (namestring)
+ (multiple-value-bind (existsp errno ino mode)
+ #!-win32
+ (sb!unix:unix-lstat namestring)
+ #!+win32
+ (sb!unix:unix-stat namestring)
+ (declare (ignore errno ino))
+ (when existsp
+ (let ((ifmt (logand mode sb!unix:s-ifmt)))
+ (case ifmt
+ (#.sb!unix:s-ifreg :file)
+ (#.sb!unix:s-ifdir :directory)
+ #!-win32
+ (#.sb!unix:s-iflnk :symlink)
+ (t :special))))))
+\f
+;;;; TRUENAME, PROBE-FILE, FILE-AUTHOR, FILE-WRITE-DATE.
-;;; Call FUNCTION on directories.
-(defun %enumerate-directories (head tail pathname verify-existence
- follow-links nodes function)
- (declare (simple-string 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)))))
- (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)
- (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))))
+;;; Rewritten in 12/2007 by RMK, replacing 13+ year old CMU code that
+;;; made a mess of things in order to support search lists (which SBCL
+;;; has never had). These are now all relatively straightforward
+;;; wrappers around stat(2) and realpath(2), with the same basic logic
+;;; in all cases. The wrinkles to be aware of:
+;;;
+;;; * SBCL defines the truename of an existing, dangling or
+;;; self-referring symlink to be the symlink itself.
+;;; * The old version of PROBE-FILE merged the pathspec against
+;;; *DEFAULT-PATHNAME-DEFAULTS* twice, and so lost when *D-P-D*
+;;; was a relative pathname. Even if the case where *D-P-D* is a
+;;; relative pathname is problematic, there's no particular reason
+;;; to get that wrong, so let's try not to.
+;;; * Note that while stat(2) is probably atomic, getting the truename
+;;; for a filename involves poking all over the place, and so is
+;;; subject to race conditions if other programs mutate the file
+;;; system while we're resolving symlinks. So it's not implausible for
+;;; realpath(3) to fail even if stat(2) succeeded. There's nothing
+;;; obvious we can do about this, however.
+;;; * Windows' apparent analogue of realpath(3) is called
+;;; GetFullPathName, and it's a bit less useful than realpath(3).
+;;; In particular, while realpath(3) errors in case the file doesn't
+;;; exist, GetFullPathName seems to return a filename in all cases.
+;;; As realpath(3) is not atomic anyway, we only ever call it when
+;;; we think a file exists, so just be careful when rewriting this
+;;; routine.
+;;;
+;;; Given a pathname designator, some quality to query for, return one
+;;; of a pathname, a universal time, or a string (a file-author), or
+;;; NIL. QUERY-FOR may be one of :TRUENAME, :EXISTENCE, :WRITE-DATE,
+;;; :AUTHOR. If ERRORP is false, return NIL in case the file system
+;;; returns an error code; otherwise, signal an error. Accepts
+;;; logical pathnames, too (but never returns LPNs). For internal
+;;; use.
+(defun query-file-system (pathspec query-for &optional (errorp t))
+ (let ((pathname (translate-logical-pathname
+ (merge-pathnames
+ (pathname pathspec)
+ (sane-default-pathname-defaults)))))
+ (when (wild-pathname-p pathname)
+ (error 'simple-file-error
+ :pathname pathname
+ :format-control "~@<can't find the ~A of wild pathname ~A~
+ (physicalized from ~A).~:>"
+ :format-arguments (list query-for pathname pathspec)))
+ (flet ((fail (note-format pathname errno)
+ (if errorp
+ (simple-file-perror note-format pathname errno)
+ (return-from query-file-system nil))))
+ (let ((filename (native-namestring pathname :as-file t)))
+ #!+win32
+ (case query-for
+ ((:existence :truename)
+ (multiple-value-bind (file kind)
+ (sb!win32::native-probe-file-name filename)
+ (when (and (not file) kind)
+ (setf file filename))
+ ;; The following OR was an AND, but that breaks files like NUL,
+ ;; for which GetLongPathName succeeds yet GetFileAttributesEx
+ ;; fails to return the file kind. --DFL
+ (if (or file kind)
+ (values
+ (parse-native-namestring
+ file
+ (pathname-host pathname)
+ (sane-default-pathname-defaults)
+ :as-directory (eq :directory kind)))
+ (fail "couldn't resolve ~A" filename
+ (- (sb!win32:get-last-error))))))
+ (:write-date
+ (or (sb!win32::native-file-write-date filename)
+ (fail "couldn't query write date of ~A" filename
+ (- (sb!win32:get-last-error))))))
+ #!-win32
+ (multiple-value-bind (existsp errno ino mode nlink uid gid rdev size
+ atime mtime)
+ (sb!unix:unix-stat filename)
+ (declare (ignore ino nlink gid rdev size atime))
+ (labels ((parse (filename &key (as-directory
+ (eql (logand mode
+ sb!unix:s-ifmt)
+ sb!unix:s-ifdir)))
+ (values
+ (parse-native-namestring
+ filename
+ (pathname-host pathname)
+ (sane-default-pathname-defaults)
+ :as-directory as-directory)))
+ (resolve-problematic-symlink (&optional realpath-failed)
+ ;; SBCL has for many years had a policy that a pathname
+ ;; that names an existing, dangling or self-referential
+ ;; symlink denotes the symlink itself. stat(2) fails
+ ;; and sets errno to ENOENT or ELOOP respectively, but
+ ;; we must distinguish cases where the symlink exists
+ ;; from ones where there's a loop in the apparent
+ ;; containing directory.
+ ;; Also handles symlinks in /proc/pid/fd/ to
+ ;; pipes or sockets on Linux
+ (multiple-value-bind (linkp ignore ino mode nlink uid gid rdev
+ size atime mtime)
+ (sb!unix:unix-lstat filename)
+ (declare (ignore ignore ino mode nlink gid rdev size atime))
+ (when (and (or (= errno sb!unix:enoent)
+ (= errno sb!unix:eloop)
+ realpath-failed)
+ linkp)
+ (return-from query-file-system
+ (case query-for
+ (:existence
+ ;; We do this reparse so as to return a
+ ;; normalized pathname.
+ (parse filename :as-directory nil))
+ (:truename
+ ;; So here's a trick: since lstat succeded,
+ ;; FILENAME exists, so its directory exists and
+ ;; only the non-directory part is loopy. So
+ ;; let's resolve FILENAME's directory part with
+ ;; realpath(3), in order to get a canonical
+ ;; absolute name for the directory, and then
+ ;; return a pathname having PATHNAME's name,
+ ;; type, and version, but the rest from the
+ ;; truename of the directory. Since we turned
+ ;; PATHNAME into FILENAME "as a file", FILENAME
+ ;; does not end in a slash, and so we get the
+ ;; directory part of FILENAME by reparsing
+ ;; FILENAME and masking off its name, type, and
+ ;; version bits. But note not to call ourselves
+ ;; recursively, because we don't want to
+ ;; re-merge against *DEFAULT-PATHNAME-DEFAULTS*,
+ ;; since PATHNAME may be a relative pathname.
+ (merge-pathnames
+ (parse
+ (multiple-value-bind (realpath errno)
+ (sb!unix:unix-realpath
+ (native-namestring
+ (make-pathname
+ :name :unspecific
+ :type :unspecific
+ :version :unspecific
+ :defaults (parse filename
+ :as-directory nil))))
+ (or realpath
+ (fail "couldn't resolve ~A" filename errno)))
+ :as-directory t)
+ pathname))
+ (:author (sb!unix:uid-username uid))
+ (:write-date (+ unix-to-universal-time mtime))))))
+ ;; If we're still here, the file doesn't exist; error.
+ (fail
+ (format nil "failed to find the ~A of ~~A" query-for)
+ pathspec errno)))
+ (if existsp
+ (case query-for
+ (:existence (parse filename))
+ (:truename
+ ;; Note: in case the file is stat'able, POSIX
+ ;; realpath(3) gets us a canonical absolute
+ ;; filename, even if the post-merge PATHNAME
+ ;; is not absolute
+ (parse (or (sb!unix:unix-realpath filename)
+ (resolve-problematic-symlink t))))
+ (:author (sb!unix:uid-username uid))
+ (:write-date (+ unix-to-universal-time mtime)))
+ (resolve-problematic-symlink))))))))
-;;; Call FUNCTION on files.
-(defun %enumerate-files (directory pathname verify-existence function)
- (declare (simple-string directory))
- (/noshow0 "entering %ENUMERATE-FILES")
- (let ((name (%pathname-name pathname))
- (type (%pathname-type pathname))
- (version (%pathname-version pathname)))
- (/noshow0 "computed NAME, TYPE, and VERSION")
- (cond ((member name '(nil :unspecific))
- (/noshow0 "UNSPECIFIC, more or less")
- (when (or (not verify-existence)
- (sb!unix:unix-file-kind directory))
- (funcall function directory)))
- ((or (pattern-p name)
- (pattern-p type)
- (eq name :wild)
- (eq type :wild))
- (/noshow0 "WILD, more or less")
- ;; 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
- (/noshow0 "default case")
- (let ((file (concatenate 'string directory name)))
- (/noshow0 "computed basic FILE=..")
- (/primitive-print file)
- (unless (or (null type) (eq type :unspecific))
- (/noshow0 "tweaking FILE for more-or-less-:UNSPECIFIC case")
- (setf file (concatenate 'string file "." type)))
- (unless (member version '(nil :newest :wild))
- (/noshow0 "tweaking FILE for more-or-less-:WILD case")
- (setf file (concatenate 'string file "."
- (quick-integer-to-string version))))
- (/noshow0 "finished possibly tweaking FILE=..")
- (/primitive-print file)
- (when (or (not verify-existence)
- (sb!unix:unix-file-kind file t))
- (/noshow0 "calling FUNCTION on FILE")
- (funcall function file)))))))
-(/noshow0 "filesys.lisp 603")
+(defun probe-file (pathspec)
+ #!+sb-doc
+ "Return the truename of PATHSPEC if the truename can be found,
+or NIL otherwise. See TRUENAME for more information."
+ (query-file-system pathspec :truename nil))
-;;; FIXME: Why do we need this?
-(defun quick-integer-to-string (n)
- (declare (type integer n))
- (cond ((not (fixnump n))
- (write-to-string n :base 10 :radix nil))
- ((zerop n) "0")
- ((eql n 1) "1")
- ((minusp n)
- (concatenate 'simple-string "-"
- (the simple-string (quick-integer-to-string (- n)))))
- (t
- (do* ((len (1+ (truncate (integer-length n) 3)))
- (res (make-string len))
- (i (1- len) (1- i))
- (q n)
- (r 0))
- ((zerop q)
- (incf i)
- (replace res res :start2 i :end2 len)
- (shrink-vector res (- len i)))
- (declare (simple-string res)
- (fixnum len i r q))
- (multiple-value-setq (q r) (truncate q 10))
- (setf (schar res i) (schar "0123456789" r))))))
-\f
-;;;; UNIX-NAMESTRING
+(defun truename (pathspec)
+ #!+sb-doc
+ "If PATHSPEC is a pathname that names an existing file, return
+a pathname that denotes a canonicalized name for the file. If
+pathspec is a stream associated with a file, return a pathname
+that denotes a canonicalized name for the file associated with
+the stream.
-(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.)
- ))
+An error of type FILE-ERROR is signalled if no such file exists
+or if the file system is such that a canonicalized file name
+cannot be determined or if the pathname is wild.
-;;; 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* ((namestring (physicalize-pathname (pathname pathname-spec)))
- (matches nil)) ; an accumulator for actual matches
- (enumerate-matches (match namestring 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
+Under Unix, the TRUENAME of a symlink that links to itself or to
+a file that doesn't exist is considered to be the name of the
+broken symlink itself."
+ ;; Note that eventually this routine might be different for streams
+ ;; than for other pathname designators.
+ (if (streamp pathspec)
+ (query-file-system pathspec :truename)
+ (query-file-system pathspec :truename)))
-;;; This is only trivially different from PROBE-FILE, which is silly
-;;; but ANSI.
-(defun truename (pathname)
+(defun file-author (pathspec)
#!+sb-doc
- "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.
-
- Under Unix, the TRUENAME of a broken symlink is considered to be
- the name of the broken symlink itself."
- (if (wild-pathname-p pathname)
- (error 'simple-file-error
- :format-control "can't use a wild pathname here"
- :pathname pathname)
- (let ((result (probe-file pathname)))
- (unless result
- (error 'simple-file-error
- :pathname pathname
- :format-control "The file ~S does not exist."
- :format-arguments (list (namestring pathname))))
- result)))
+ "Return the author of the file specified by PATHSPEC. Signal an
+error of type FILE-ERROR if no such file exists, or if PATHSPEC
+is a wild pathname."
+ (query-file-system pathspec :author))
-;;; If PATHNAME exists, return its truename, otherwise NIL.
-(defun probe-file (pathname)
+(defun file-write-date (pathspec)
#!+sb-doc
- "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* ((defaulted-pathname (merge-pathnames
- pathname
- (sane-default-pathname-defaults)))
- (namestring (unix-namestring defaulted-pathname t)))
- (when (and namestring (sb!unix:unix-file-kind namestring t))
- (let ((trueishname (sb!unix:unix-resolve-links namestring)))
- (when trueishname
- (let ((*ignore-wildcards* t))
- (pathname (sb!unix:unix-simplify-pathname trueishname))))))))
+ "Return the write date of the file specified by PATHSPEC.
+An error of type FILE-ERROR is signaled if no such file exists,
+or if PATHSPEC is a wild pathname."
+ (query-file-system pathspec :write-date))
\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
- file, then the associated file is renamed."
- (let* ((original (truename file))
- (original-namestring (unix-namestring original t))
- (new-name (merge-pathnames new-name original))
- (new-namestring (unix-namestring new-name nil)))
+file, then the associated file is renamed."
+ (let* ((original (merge-pathnames file (sane-default-pathname-defaults)))
+ (old-truename (truename original))
+ (original-namestring (native-namestring (physicalize-pathname original)
+ :as-file t))
+ (new-name (merge-pathnames new-name original))
+ (new-namestring (native-namestring (physicalize-pathname new-name)
+ :as-file t)))
(unless new-namestring
(error 'simple-file-error
- :pathname new-name
- :format-control "~S can't be created."
- :format-arguments (list new-name)))
+ :pathname new-name
+ :format-control "~S can't be created."
+ :format-arguments (list new-name)))
(multiple-value-bind (res error)
- (sb!unix:unix-rename original-namestring new-namestring)
+ (sb!unix:unix-rename original-namestring new-namestring)
(unless res
- (error 'simple-file-error
- :pathname new-name
- :format-control "~@<couldn't rename ~2I~_~A ~I~_to ~2I~_~A: ~
+ (error 'simple-file-error
+ :pathname new-name
+ :format-control "~@<couldn't rename ~2I~_~A ~I~_to ~2I~_~A: ~
~I~_~A~:>"
- :format-arguments (list original new-name (strerror error))))
+ :format-arguments (list original new-name (strerror error))))
(when (streamp file)
- (file-name file new-namestring))
- (values new-name original (truename new-name)))))
+ (file-name file new-name))
+ (values new-name old-truename (truename new-name)))))
(defun delete-file (file)
#!+sb-doc
- "Delete the specified FILE."
- (let ((namestring (unix-namestring file t)))
+ "Delete the specified FILE.
+
+If FILE is a stream, on Windows the stream is closed immediately. On Unix
+plaforms the stream remains open, allowing IO to continue: the OS resources
+associated with the deleted file remain available till the stream is closed as
+per standard Unix unlink() behaviour."
+ (let* ((pathname (translate-logical-pathname
+ (merge-pathnames file (sane-default-pathname-defaults))))
+ (namestring (native-namestring pathname :as-file t)))
+ #!+win32
(when (streamp file)
- (close file :abort t))
- (unless namestring
- (error 'simple-file-error
- :pathname file
- :format-control "~S doesn't exist."
- :format-arguments (list file)))
- (multiple-value-bind (res err) (sb!unix:unix-unlink namestring)
- (unless res
- (simple-file-perror "couldn't delete ~A" namestring err))))
+ (close file))
+ (multiple-value-bind (res err)
+ #!-win32 (sb!unix:unix-unlink namestring)
+ #!+win32 (or (sb!win32::native-delete-file namestring)
+ (values nil (- (sb!win32:get-last-error))))
+ (unless res
+ (simple-file-perror "couldn't delete ~A" namestring err))))
t)
+
+(defun directorize-pathname (pathname)
+ (if (or (pathname-name pathname)
+ (pathname-type pathname))
+ (make-pathname :directory (append (pathname-directory pathname)
+ (list (file-namestring pathname)))
+ :host (pathname-host pathname)
+ :device (pathname-device pathname))
+ pathname))
+
+(defun delete-directory (pathspec &key recursive)
+ "Deletes the directory designated by PATHSPEC (a pathname designator).
+Returns the truename of the directory deleted.
+
+If RECURSIVE is false \(the default), signals an error unless the directory is
+empty. If RECURSIVE is true, first deletes all files and subdirectories. If
+RECURSIVE is true and the directory contains symbolic links, the links are
+deleted, not the files and directories they point to.
+
+Signals an error if PATHSPEC designates a file or a symbolic link instead of a
+directory, or if the directory could not be deleted for any reason.
+
+Both
+
+ \(DELETE-DIRECTORY \"/tmp/foo\")
+ \(DELETE-DIRECTORY \"/tmp/foo/\")
+
+delete the \"foo\" subdirectory of \"/tmp\", or signal an error if it does not
+exist or if is a file or a symbolic link."
+ (declare (type pathname-designator pathspec))
+ (let ((physical (directorize-pathname
+ (physicalize-pathname
+ (merge-pathnames
+ pathspec (sane-default-pathname-defaults))))))
+ (labels ((recurse-merged (dir)
+ (lambda (sub)
+ (recurse (merge-pathnames sub dir))))
+ (delete-merged (dir)
+ (lambda (file)
+ (delete-file (merge-pathnames file dir))))
+ (recurse (dir)
+ (map-directory (recurse-merged dir) dir
+ :files nil
+ :directories t
+ :classify-symlinks nil)
+ (map-directory (delete-merged dir) dir
+ :files t
+ :directories nil
+ :classify-symlinks nil)
+ (delete-dir dir))
+ (delete-dir (dir)
+ (let ((namestring (native-namestring dir :as-file t)))
+ (multiple-value-bind (res errno)
+ #!+win32
+ (or (sb!win32::native-delete-directory namestring)
+ (values nil (- (sb!win32:get-last-error))))
+ #!-win32
+ (values
+ (not (minusp (alien-funcall
+ (extern-alien "rmdir"
+ (function int c-string))
+ namestring)))
+ (get-errno))
+ (if res
+ dir
+ (simple-file-perror
+ "Could not delete directory ~A"
+ namestring errno))))))
+ (if recursive
+ (recurse physical)
+ (delete-dir physical)))))
+
\f
-;;; (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)
- "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
- ;; running in a target Lisp lets us avoid figuring out how to dump
- ;; cross-compilation host Lisp PATHNAME objects into a target Lisp
- ;; object file. It also might have a small positive effect on
- ;; efficiency, in that we don't allocate a PATHNAME we don't need,
- ;; but it it could also have a larger negative effect. Hopefully
- ;; it'll be OK. -- WHN 19990714
- (pathname "home:"))
+(defun sbcl-homedir-pathname ()
+ (let ((sbcl-home (posix-getenv "SBCL_HOME")))
+ ;; SBCL_HOME isn't set for :EXECUTABLE T embedded cores
+ (when (and sbcl-home (not (string= sbcl-home "")))
+ (parse-native-namestring sbcl-home
+ *physical-host*
+ *default-pathname-defaults*
+ :as-directory t))))
-(defun file-write-date (file)
- #!+sb-doc
- "Return file's creation date, or NIL if it doesn't exist.
- An error of type file-error is signaled if file is a wild pathname"
- (if (wild-pathname-p file)
- ;; FIXME: This idiom appears many times in this file. Perhaps it
- ;; should turn into (CANNOT-BE-WILD-PATHNAME FILE). (C-B-W-P
- ;; should be a macro, not a function, so that the error message
- ;; is reported as coming from e.g. FILE-WRITE-DATE instead of
- ;; from CANNOT-BE-WILD-PATHNAME itself.)
- (error 'simple-file-error
- :pathname file
- :format-control "bad place for a wild pathname")
- (let ((name (unix-namestring file t)))
- (when name
- (multiple-value-bind
- (res dev ino mode nlink uid gid rdev size atime mtime)
- (sb!unix:unix-stat name)
- (declare (ignore dev ino mode nlink uid gid rdev size atime))
- (when res
- (+ unix-to-universal-time mtime)))))))
+(defun user-homedir-namestring (&optional username)
+ (if username
+ (sb!unix:user-homedir username)
+ (let ((env-home (posix-getenv "HOME")))
+ (if (and env-home (not (string= env-home "")))
+ env-home
+ #!-win32
+ (sb!unix:uid-homedir (sb!unix:unix-getuid))))))
-(defun file-author (file)
+;;; (This is an ANSI Common Lisp function.)
+(defun user-homedir-pathname (&optional host)
#!+sb-doc
- "Return the file author as a string, or nil if the author cannot be
- determined. Signal an error of type FILE-ERROR if FILE doesn't exist,
- or FILE is a wild pathname."
- (if (wild-pathname-p file)
- (error 'simple-file-error
- :pathname file
- "bad place for a wild pathname")
- (let ((name (unix-namestring (pathname file) t)))
- (unless name
- (error 'simple-file-error
- :pathname file
- :format-control "~S doesn't exist."
- :format-arguments (list file)))
- (multiple-value-bind (winp dev ino mode nlink uid)
- (sb!unix:unix-stat name)
- (declare (ignore dev ino mode nlink))
- (if winp (lookup-login-name uid))))))
+ "Return the home directory of the user as a pathname. If the HOME
+environment variable has been specified, the directory it designates
+is returned; otherwise obtains the home directory from the operating
+system. HOST argument is ignored by SBCL."
+ (declare (ignore host))
+ (values
+ (parse-native-namestring
+ (or (user-homedir-namestring)
+ #!+win32
+ (sb!win32::get-folder-namestring sb!win32::csidl_profile))
+ *physical-host*
+ *default-pathname-defaults*
+ :as-directory t)))
+
\f
;;;; DIRECTORY
-(/show0 "filesys.lisp 800")
-
-(defun directory (pathname &key)
+(defun directory (pathspec &key (resolve-symlinks t))
#!+sb-doc
"Return a list of PATHNAMEs, each the TRUENAME of a file that matched the
- given pathname. Note that the interaction between this ANSI-specified
- TRUENAMEing and the semantics of the Unix filesystem (symbolic links..)
- means this function can sometimes return files which don't have the same
- directory as PATHNAME."
- (let ((truenames nil))
- (enumerate-search-list
- (pathname (merge-pathnames pathname
- (make-pathname :name :wild
- :type :wild
- :version :wild)))
- (enumerate-matches (match pathname)
- (let ((*ignore-wildcards* t))
- (push (truename (if (eq (sb!unix:unix-file-kind match) :directory)
- (concatenate 'string match "/")
- match))
- truenames))))
- ;; FIXME: The DELETE-DUPLICATES here requires quadratic time,
- ;; which is unnecessarily slow. That might not be an issue,
- ;; though, since the time constant for doing TRUENAME on every
- ;; directory entry is likely to be (much) larger, and the cost of
- ;; all those TRUENAMEs on a huge directory might even be quadratic
- ;; in the directory size. Someone who cares about enormous
- ;; directories might want to check this. -- WHN 2001-06-19
- (sort (delete-duplicates truenames :test #'string= :key #'pathname-name)
- #'string< :key #'pathname-name)))
-\f
-;;;; translating Unix uid's
-;;;;
-;;;; FIXME: should probably move into unix.lisp
+given pathname. Note that the interaction between this ANSI-specified
+TRUENAMEing and the semantics of the Unix filesystem (symbolic links..) means
+this function can sometimes return files which don't have the same directory
+as PATHNAME. If :RESOLVE-SYMLINKS is NIL, don't resolve symbolic links in
+matching filenames."
+ (let (;; We create one entry in this hash table for each truename,
+ ;; as an asymptotically efficient way of removing duplicates
+ ;; (which can arise when e.g. multiple symlinks map to the
+ ;; same truename).
+ (truenames (make-hash-table :test #'equal)))
+ (labels ((record (pathname)
+ (let ((truename (if resolve-symlinks
+ ;; FIXME: Why not not TRUENAME? As reported by
+ ;; Milan Zamazal sbcl-devel 2003-10-05, using
+ ;; TRUENAME causes a race condition whereby
+ ;; removal of a file during the directory
+ ;; operation causes an error. It's not clear
+ ;; what the right thing to do is, though. --
+ ;; CSR, 2003-10-13
+ (query-file-system pathname :truename nil)
+ (query-file-system pathname :existence nil))))
+ (when truename
+ (setf (gethash (namestring truename) truenames)
+ truename))))
+ (do-physical-pathnames (pathname)
+ (aver (not (logical-pathname-p pathname)))
+ (let* (;; KLUDGE: Since we don't canonize pathnames on construction,
+ ;; we really have to do it here to get #p"foo/." mean the same
+ ;; as #p"foo/./".
+ (pathname (canonicalize-pathname pathname))
+ (name (pathname-name pathname))
+ (type (pathname-type pathname))
+ (match-name (make-matcher name))
+ (match-type (make-matcher type)))
+ (map-matching-directories
+ (if (or name type)
+ (lambda (directory)
+ (map-matching-entries #'record
+ directory
+ match-name
+ match-type))
+ #'record)
+ pathname)))
+ (do-pathnames (pathname)
+ (if (logical-pathname-p pathname)
+ (let ((host (intern-logical-host (pathname-host pathname))))
+ (dolist (x (logical-host-canon-transls host))
+ (destructuring-bind (from to) x
+ (let ((intersections
+ (pathname-intersections pathname from)))
+ (dolist (p intersections)
+ (do-pathnames (translate-pathname p from to)))))))
+ (do-physical-pathnames pathname))))
+ (declare (truly-dynamic-extent #'record))
+ (do-pathnames (merge-pathnames pathspec)))
+ (mapcar #'cdr
+ ;; Sorting isn't required by the ANSI spec, but sorting into some
+ ;; canonical order seems good just on the grounds that the
+ ;; implementation should have repeatable behavior when possible.
+ (sort (loop for namestring being each hash-key in truenames
+ using (hash-value truename)
+ collect (cons namestring truename))
+ #'string<
+ :key #'car))))
+
+(defun canonicalize-pathname (pathname)
+ ;; We're really only interested in :UNSPECIFIC -> NIL, :BACK and :UP,
+ ;; and dealing with #p"foo/.." and #p"foo/."
+ (labels ((simplify (piece)
+ (unless (eq :unspecific piece)
+ piece))
+ (canonicalize-directory (directory)
+ (let (pieces)
+ (dolist (piece directory)
+ (cond
+ ((and pieces (member piece '(:back :up)))
+ ;; FIXME: We should really canonicalize when we construct
+ ;; pathnames. This is just wrong.
+ (case (car pieces)
+ ((:absolute :wild-inferiors)
+ (error 'simple-file-error
+ :format-control "Invalid use of ~S after ~S."
+ :format-arguments (list piece (car pieces))
+ :pathname pathname))
+ ((:relative :up :back)
+ (push piece pieces))
+ (t
+ (pop pieces))))
+ ((equal piece ".")
+ ;; This case only really matters on Windows,
+ ;; because on POSIX, our call site (TRUENAME via
+ ;; QUERY-FILE-SYSTEM) only passes in pathnames from
+ ;; realpath(3), in which /./ has been removed
+ ;; already. Windows, however, depends on us to
+ ;; perform this fixup. -- DFL
+ )
+ (t
+ (push piece pieces))))
+ (nreverse pieces))))
+ (let ((name (simplify (pathname-name pathname)))
+ (type (simplify (pathname-type pathname)))
+ (dir (canonicalize-directory (pathname-directory pathname))))
+ (cond ((equal "." name)
+ (cond ((not type)
+ (make-pathname :name nil :defaults pathname))
+ ((equal "" type)
+ (make-pathname :name nil
+ :type nil
+ :directory (butlast dir)
+ :defaults pathname))))
+ (t
+ (make-pathname :name name :type type
+ :directory dir
+ :defaults pathname))))))
+
+;;; Given a native namestring, provides a WITH-HASH-TABLE-ITERATOR style
+;;; interface to mapping over namestrings of entries in the corresponding
+;;; directory.
+(defmacro with-native-directory-iterator ((iterator namestring &key errorp) &body body)
+ (with-unique-names (one-iter)
+ `(dx-flet
+ ((iterate (,one-iter)
+ (declare (type function ,one-iter))
+ (macrolet ((,iterator ()
+ `(funcall ,',one-iter)))
+ ,@body)))
+ #!+win32
+ (sb!win32::native-call-with-directory-iterator
+ #'iterate ,namestring ,errorp)
+ #!-win32
+ (call-with-native-directory-iterator #'iterate ,namestring ,errorp))))
-(defvar *uid-hash-table* (make-hash-table)
+(defun call-with-native-directory-iterator (function namestring errorp)
+ (declare (type (or null string) namestring)
+ (function function))
+ (let (dp)
+ (when namestring
+ (dx-flet
+ ((one-iter ()
+ (tagbody
+ :next
+ (let ((ent (sb!unix:unix-readdir dp nil)))
+ (when ent
+ (let ((name (sb!unix:unix-dirent-name ent)))
+ (when name
+ (cond ((equal "." name)
+ (go :next))
+ ((equal ".." name)
+ (go :next))
+ (t
+ (return-from one-iter name))))))))))
+ (unwind-protect
+ (progn
+ (setf dp (sb!unix:unix-opendir namestring errorp))
+ (when dp
+ (funcall function #'one-iter)))
+ (when dp
+ (sb!unix:unix-closedir dp nil)))))))
+
+;;; This is our core directory access interface that we use to implement
+;;; DIRECTORY.
+(defun map-directory (function directory &key (files t) (directories t)
+ (classify-symlinks t) (errorp t))
#!+sb-doc
- "hash table for keeping track of uid's and login names")
+ "Map over entries in DIRECTORY. Keyword arguments specify which entries to
+map over, and how:
+
+ :FILES
+ If true, call FUNCTION with the pathname of each file in DIRECTORY.
+ Defaults to T.
+
+ :DIRECTORIES
+ If true, call FUNCTION with a pathname for each subdirectory of DIRECTORY.
+ If :AS-FILES, the pathname used is a pathname designating the subdirectory
+ as a file in DIRECTORY. Otherwise the pathname used is a directory
+ pathname. Defaults to T.
+
+ :CLASSIFY-SYMLINKS
+ If true, the decision to call FUNCTION with the pathname of a symbolic link
+ depends on the resolution of the link: if it points to a directory, it is
+ considered a directory entry, otherwise a file entry. If false, all
+ symbolic links are considered file entries. In both cases the pathname used
+ for the symbolic link is not fully resolved, but names it as an immediate
+ child of DIRECTORY. Defaults to T.
+
+ :ERRORP
+ If true, signal an error if DIRECTORY does not exist, cannot be read, etc.
+ Defaults to T.
+
+Experimental: interface subject to change."
+ (declare (pathname-designator directory))
+ (let* ((fun (%coerce-callable-to-fun function))
+ (as-files (eq :as-files directories))
+ (physical (physicalize-pathname directory))
+ (realname (query-file-system physical :existence nil))
+ (canonical (if realname
+ (parse-native-namestring realname
+ (pathname-host physical)
+ (sane-default-pathname-defaults)
+ :as-directory t)
+ (return-from map-directory nil)))
+ (dirname (native-namestring canonical)))
+ (flet ((map-it (name dirp)
+ (funcall fun
+ (merge-pathnames (parse-native-namestring
+ name nil physical
+ :as-directory (and dirp (not as-files)))
+ physical))))
+ (with-native-directory-iterator (next dirname :errorp errorp)
+ (loop
+ ;; provision for FindFirstFileExW-based iterator that should be used
+ ;; on Windows: file kind is known instantly there, so we'll have it
+ ;; returned by (next) soon.
+ (multiple-value-bind (name kind) (next)
+ (unless (or name kind) (return))
+ (unless kind
+ (setf kind (native-file-kind
+ (concatenate 'string dirname name))))
+ (when kind
+ (case kind
+ (:directory
+ (when directories
+ (map-it name t)))
+ (:symlink
+ (if classify-symlinks
+ (let* ((tmpname (merge-pathnames
+ (parse-native-namestring
+ name nil physical :as-directory nil)
+ physical))
+ (truename (query-file-system tmpname :truename nil)))
+ (if (or (not truename)
+ (or (pathname-name truename) (pathname-type truename)))
+ (when files
+ (funcall fun tmpname))
+ (when directories
+ (map-it name t))))
+ (when files
+ (map-it name nil))))
+ (t
+ ;; Anything else parses as a file.
+ (when files
+ (map-it name nil)))))))))))
+
+;;; Part of DIRECTORY: implements matching the directory spec. Calls FUNCTION
+;;; with all DIRECTORIES that match the directory portion of PATHSPEC.
+(defun map-matching-directories (function pathspec)
+ (let* ((dir (pathname-directory pathspec))
+ (length (length dir))
+ (wild (position-if (lambda (elt)
+ (or (eq :wild elt) (typep elt 'pattern)))
+ dir))
+ (wild-inferiors (position :wild-inferiors dir))
+ (end (cond ((and wild wild-inferiors)
+ (min wild wild-inferiors))
+ (t
+ (or wild wild-inferiors length))))
+ (rest (subseq dir end))
+ (starting-point (make-pathname :directory (subseq dir 0 end)
+ :device (pathname-device pathspec)
+ :host (pathname-host pathspec)
+ :name nil
+ :type nil
+ :version nil)))
+ (cond (wild-inferiors
+ (map-wild-inferiors function rest starting-point))
+ (wild
+ (map-wild function rest starting-point))
+ (t
+ ;; Nothing wild -- the directory matches itself.
+ (funcall function starting-point))))
+ nil)
+
+(defun last-directory-piece (pathname)
+ (car (last (pathname-directory pathname))))
-(/show0 "filesys.lisp 844")
+;;; Part of DIRECTORY: implements iterating over a :WILD or pattern component
+;;; in the directory spec.
+(defun map-wild (function more directory)
+ (let ((this (pop more))
+ (next (car more)))
+ (flet ((cont (subdirectory)
+ (cond ((not more)
+ ;; end of the line
+ (funcall function subdirectory))
+ ((or (eq :wild next) (typep next 'pattern))
+ (map-wild function more subdirectory))
+ ((eq :wild-inferiors next)
+ (map-wild-inferiors function more subdirectory))
+ (t
+ (let ((this (pathname-directory subdirectory)))
+ (map-matching-directories
+ function
+ (make-pathname :directory (append this more)
+ :defaults subdirectory)))))))
+ (map-directory
+ (if (eq :wild this)
+ #'cont
+ (lambda (sub)
+ (when (pattern-matches this (last-directory-piece sub))
+ (funcall #'cont sub))))
+ directory
+ :files nil
+ :directories t
+ :errorp nil))))
-;;; LOOKUP-LOGIN-NAME translates a user id into a login name. Previous
-;;; lookups are cached in a hash table since groveling the passwd(s)
-;;; files is somewhat expensive. The table may hold NIL for id's that
-;;; cannot be looked up since this keeps the files from having to be
-;;; searched in their entirety each time this id is translated.
-(defun lookup-login-name (uid)
- (multiple-value-bind (login-name foundp) (gethash uid *uid-hash-table*)
- (if foundp
- login-name
- (setf (gethash uid *uid-hash-table*)
- (get-group-or-user-name :user uid)))))
+;;; Part of DIRECTORY: implements iterating over a :WILD-INFERIORS component
+;;; in the directory spec.
+(defun map-wild-inferiors (function more directory)
+ (loop while (member (car more) '(:wild :wild-inferiors))
+ do (pop more))
+ (let ((next (car more))
+ (rest (cdr more)))
+ (unless more
+ (funcall function directory))
+ (map-directory
+ (cond ((not more)
+ (lambda (pathname)
+ (funcall function pathname)
+ (map-wild-inferiors function more pathname)))
+ (t
+ (lambda (pathname)
+ (let ((this (pathname-directory pathname)))
+ (when (equal next (car (last this)))
+ (map-matching-directories
+ function
+ (make-pathname :directory (append this rest)
+ :defaults pathname)))
+ (map-wild-inferiors function more pathname)))))
+ directory
+ :files nil
+ :directories t
+ :errorp nil)))
-;;; GET-GROUP-OR-USER-NAME first tries "/etc/passwd" ("/etc/group")
-;;; since it is a much smaller file, contains all the local id's, and
-;;; most uses probably involve id's on machines one would login into.
-;;; Then if necessary, we look in "/etc/passwds" ("/etc/groups") which
-;;; is really long and has to be fetched over the net.
+;;; Part of DIRECTORY: implements iterating over entries in a directory, and
+;;; matching them.
+(defun map-matching-entries (function directory match-name match-type)
+ (map-directory
+ (lambda (file)
+ (when (and (funcall match-name (pathname-name file))
+ (funcall match-type (pathname-type file)))
+ (funcall function file)))
+ directory
+ :files t
+ :directories :as-files
+ :errorp nil))
+
+;;; NOTE: There is a fair amount of hair below that is probably not
+;;; strictly necessary.
;;;
-;;; FIXME: Now that we no longer have lookup-group-name, we no longer need
-;;; the GROUP-OR-USER argument.
-(defun get-group-or-user-name (group-or-user id)
- #!+sb-doc
- "Returns the simple-string user or group name of the user whose uid or gid
- is id, or NIL if no such user or group exists. Group-or-user is either
- :group or :user."
- (let ((id-string (let ((*print-base* 10)) (prin1-to-string id))))
- (declare (simple-string id-string))
- (multiple-value-bind (file1 file2)
- (ecase group-or-user
- (:group (values "/etc/group" "/etc/groups"))
- (:user (values "/etc/passwd" "/etc/passwd")))
- (or (get-group-or-user-name-aux id-string file1)
- (get-group-or-user-name-aux id-string file2)))))
+;;; The issue is the following: what does (DIRECTORY "SYS:*;") mean?
+;;; Until 2004-01, SBCL's behaviour was unquestionably wrong, as it
+;;; did not translate the logical pathname at all, but instead treated
+;;; it as a physical one. Other Lisps seem to to treat this call as
+;;; equivalent to (DIRECTORY (TRANSLATE-LOGICAL-PATHNAME "SYS:*;")),
+;;; which is fine as far as it goes, but not very interesting, and
+;;; arguably counterintuitive. (PATHNAME-MATCH-P "SYS:SRC;" "SYS:*;")
+;;; is true, so why should "SYS:SRC;" not show up in the call to
+;;; DIRECTORY? (assuming the physical pathname corresponding to it
+;;; exists, of course).
+;;;
+;;; So, the interpretation that I am pushing is for all pathnames
+;;; matching the input pathname to be queried. This means that we
+;;; need to compute the intersection of the input pathname and the
+;;; logical host FROM translations, and then translate the resulting
+;;; pathname using the host to the TO translation; this treatment is
+;;; recursively invoked until we get a physical pathname, whereupon
+;;; our physical DIRECTORY implementation takes over.
-;;; FIXME: Isn't there now a POSIX routine to parse the passwd file?
-;;; getpwent? getpwuid?
-(defun get-group-or-user-name-aux (id-string passwd-file)
- (with-open-file (stream passwd-file)
- (loop
- (let ((entry (read-line stream nil)))
- (unless entry (return nil))
- (let ((name-end (position #\: (the simple-string entry)
- :test #'char=)))
- (when name-end
- (let ((id-start (position #\: (the simple-string entry)
- :start (1+ name-end) :test #'char=)))
- (when id-start
- (incf id-start)
- (let ((id-end (position #\: (the simple-string entry)
- :start id-start :test #'char=)))
- (when (and id-end
- (string= id-string entry
- :start2 id-start :end2 id-end))
- (return (subseq entry 0 name-end))))))))))))
-\f
-(/show0 "filesys.lisp 899")
+;;; FIXME: this is an incomplete implementation. It only works when
+;;; both are logical pathnames (which is OK, because that's the only
+;;; case when we call it), but there are other pitfalls as well: see
+;;; the DIRECTORY-HELPER below for some, but others include a lack of
+;;; pattern handling.
+
+;;; The above was written by CSR, I (RMK) believe. The argument that
+;;; motivates the interpretation is faulty, however: PATHNAME-MATCH-P
+;;; returns true for (PATHNAME-MATCH-P #P"/tmp/*/" #P"/tmp/../"), but
+;;; the latter pathname is not in the result of DIRECTORY on the
+;;; former. Indeed, if DIRECTORY were constrained to return the
+;;; truename for every pathname for which PATHNAME-MATCH-P returned
+;;; true and which denoted a filename that named an existing file,
+;;; (DIRECTORY #P"/tmp/**/") would be required to list every file on a
+;;; Unix system, since any file can be named as though it were "below"
+;;; /tmp, given the dotdot entries. So I think the strongest
+;;; "consistency" we can define between PATHNAME-MATCH-P and DIRECTORY
+;;; is that PATHNAME-MATCH-P returns true of everything DIRECTORY
+;;; returns, but not vice versa.
+
+;;; In any case, even if the motivation were sound, DIRECTORY on a
+;;; wild logical pathname has no portable semantics. I see nothing in
+;;; ANSI that requires implementations to support wild physical
+;;; pathnames, and so there need not be any translation of a wild
+;;; logical pathname to a phyiscal pathname. So a program that calls
+;;; DIRECTORY on a wild logical pathname is doing something
+;;; non-portable at best. And if the only sensible semantics for
+;;; DIRECTORY on a wild logical pathname is something like the
+;;; following, it would be just as well if it signaled an error, since
+;;; a program can't possibly rely on the result of an intersection of
+;;; user-defined translations with a file system probe. (Potentially
+;;; useful kinds of "pathname" that might not support wildcards could
+;;; include pathname hosts that model unqueryable namespaces like HTTP
+;;; URIs, or that model namespaces that it's not convenient to
+;;; investigate, such as the namespace of TCP ports that some network
+;;; host listens on. I happen to think it a bad idea to try to
+;;; shoehorn such namespaces into a pathnames system, but people
+;;; sometimes claim to want pathnames for these things.) -- RMK
+;;; 2007-12-31.
-;;; predicate to order pathnames by; goes by name
-(defun pathname-order (x y)
- (let ((xn (%pathname-name x))
- (yn (%pathname-name y)))
- (if (and xn yn)
- (let ((res (string-lessp xn yn)))
- (cond ((not res) nil)
- ((= res (length (the simple-string xn))) t)
- ((= res (length (the simple-string yn))) nil)
- (t t)))
- xn)))
+(defun pathname-intersections (one two)
+ (aver (logical-pathname-p one))
+ (aver (logical-pathname-p two))
+ (labels
+ ((intersect-version (one two)
+ (aver (typep one '(or null (member :newest :wild :unspecific)
+ integer)))
+ (aver (typep two '(or null (member :newest :wild :unspecific)
+ integer)))
+ (cond
+ ((eq one :wild) two)
+ ((eq two :wild) one)
+ ((or (null one) (eq one :unspecific)) two)
+ ((or (null two) (eq two :unspecific)) one)
+ ((eql one two) one)
+ (t nil)))
+ (intersect-name/type (one two)
+ (aver (typep one '(or null (member :wild :unspecific) string)))
+ (aver (typep two '(or null (member :wild :unspecific) string)))
+ (cond
+ ((eq one :wild) two)
+ ((eq two :wild) one)
+ ((or (null one) (eq one :unspecific)) two)
+ ((or (null two) (eq two :unspecific)) one)
+ ((string= one two) one)
+ (t (return-from pathname-intersections nil))))
+ (intersect-directory (one two)
+ (aver (typep one '(or null (member :wild :unspecific) list)))
+ (aver (typep two '(or null (member :wild :unspecific) list)))
+ (cond
+ ((eq one :wild) two)
+ ((eq two :wild) one)
+ ((or (null one) (eq one :unspecific)) two)
+ ((or (null two) (eq two :unspecific)) one)
+ (t (aver (eq (car one) (car two)))
+ (mapcar
+ (lambda (x) (cons (car one) x))
+ (intersect-directory-helper (cdr one) (cdr two)))))))
+ (let ((version (intersect-version
+ (pathname-version one) (pathname-version two)))
+ (name (intersect-name/type
+ (pathname-name one) (pathname-name two)))
+ (type (intersect-name/type
+ (pathname-type one) (pathname-type two)))
+ (host (pathname-host one)))
+ (mapcar (lambda (d)
+ (make-pathname :host host :name name :type type
+ :version version :directory d))
+ (intersect-directory
+ (pathname-directory one) (pathname-directory two))))))
+
+;;; FIXME: written as its own function because I (CSR) don't
+;;; understand it, so helping both debuggability and modularity. In
+;;; case anyone is motivated to rewrite it, it returns a list of
+;;; sublists representing the intersection of the two input directory
+;;; paths (excluding the initial :ABSOLUTE or :RELATIVE).
+;;;
+;;; FIXME: Does not work with :UP or :BACK
+;;; FIXME: Does not work with patterns
+;;;
+;;; FIXME: PFD suggests replacing this implementation with a DFA
+;;; conversion of a NDFA. Find out (a) what this means and (b) if it
+;;; turns out to be worth it.
+(defun intersect-directory-helper (one two)
+ (flet ((simple-intersection (cone ctwo)
+ (cond
+ ((eq cone :wild) ctwo)
+ ((eq ctwo :wild) cone)
+ (t (aver (typep cone 'string))
+ (aver (typep ctwo 'string))
+ (if (string= cone ctwo) cone nil)))))
+ (macrolet
+ ((loop-possible-wild-inferiors-matches
+ (lower-bound bounding-sequence order)
+ (let ((index (gensym)) (g2 (gensym)) (g3 (gensym)) (l (gensym)))
+ `(let ((,l (length ,bounding-sequence)))
+ (loop for ,index from ,lower-bound to ,l
+ append (mapcar (lambda (,g2)
+ (append
+ (butlast ,bounding-sequence (- ,l ,index))
+ ,g2))
+ (mapcar
+ (lambda (,g3)
+ (append
+ (if (eq (car (nthcdr ,index ,bounding-sequence))
+ :wild-inferiors)
+ '(:wild-inferiors)
+ nil) ,g3))
+ (intersect-directory-helper
+ ,@(if order
+ `((nthcdr ,index one) (cdr two))
+ `((cdr one) (nthcdr ,index two)))))))))))
+ (cond
+ ((and (eq (car one) :wild-inferiors)
+ (eq (car two) :wild-inferiors))
+ (delete-duplicates
+ (append (mapcar (lambda (x) (cons :wild-inferiors x))
+ (intersect-directory-helper (cdr one) (cdr two)))
+ (loop-possible-wild-inferiors-matches 2 one t)
+ (loop-possible-wild-inferiors-matches 2 two nil))
+ :test 'equal))
+ ((eq (car one) :wild-inferiors)
+ (delete-duplicates (loop-possible-wild-inferiors-matches 0 two nil)
+ :test 'equal))
+ ((eq (car two) :wild-inferiors)
+ (delete-duplicates (loop-possible-wild-inferiors-matches 0 one t)
+ :test 'equal))
+ ((and (null one) (null two)) (list nil))
+ ((null one) nil)
+ ((null two) nil)
+ (t (and (simple-intersection (car one) (car two))
+ (mapcar (lambda (x) (cons (simple-intersection
+ (car one) (car two)) x))
+ (intersect-directory-helper (cdr one) (cdr two)))))))))
\f
+
+(defun directory-pathname-p (pathname)
+ (and (pathnamep pathname)
+ (null (pathname-name pathname))
+ (null (pathname-type pathname))))
+
(defun ensure-directories-exist (pathspec &key verbose (mode #o777))
#!+sb-doc
"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 (physicalize-pathname (pathname pathspec)))
- (created-p nil))
+ (let ((pathname (physicalize-pathname (merge-pathnames (pathname pathspec))))
+ (created-p nil))
(when (wild-pathname-p pathname)
(error 'simple-file-error
- :format-control "bad place for a wild pathname"
- :pathname pathspec))
- (enumerate-search-list (pathname pathname)
- (let ((dir (pathname-directory pathname)))
- (loop for i from 1 upto (length dir)
- do (let ((newpath (make-pathname
- :host (pathname-host pathname)
- :device (pathname-device pathname)
- :directory (subseq dir 0 i))))
- (unless (probe-file newpath)
- (let ((namestring (namestring newpath)))
- (when verbose
- (format *standard-output*
- "~&creating directory: ~A~%"
- namestring))
- (sb!unix:unix-mkdir namestring mode)
- (unless (probe-file namestring)
- (error 'simple-file-error
- :pathname pathspec
- :format-control "can't create directory ~A"
- :format-arguments (list namestring)))
- (setf created-p t)))))
- ;; Only the first path in a search-list is considered.
- (return (values pathname created-p))))))
+ :format-control "bad place for a wild pathname"
+ :pathname pathspec))
+ (let* ((dir (pathname-directory pathname))
+ (*default-pathname-defaults*
+ (make-pathname :directory dir :device (pathname-device pathname)))
+ (dev (pathname-device pathname)))
+ (loop for i from (case dev (:unc 3) (otherwise 2))
+ upto (length dir)
+ do
+ (let* ((newpath (make-pathname
+ :host (pathname-host pathname)
+ :device dev
+ :directory (subseq dir 0 i)))
+ (probed (probe-file newpath)))
+ (unless (directory-pathname-p probed)
+ (let ((namestring (coerce (native-namestring newpath)
+ 'string)))
+ (when verbose
+ (format *standard-output*
+ "~&creating directory: ~A~%"
+ namestring))
+ (sb!unix:unix-mkdir namestring mode)
+ (unless (directory-pathname-p (probe-file newpath))
+ (restart-case
+ (error
+ 'simple-file-error
+ :pathname pathspec
+ :format-control
+ (if (and probed
+ (not (directory-pathname-p probed)))
+ "Can't create directory ~A,~
+ ~%a file with the same name already exists."
+ "Can't create directory ~A")
+ :format-arguments (list namestring))
+ (retry ()
+ :report "Retry directory creation."
+ (ensure-directories-exist
+ pathspec
+ :verbose verbose :mode mode))
+ (continue ()
+ :report
+ "Continue as if directory creation was successful."
+ nil)))
+ (setf created-p t)))))
+ (values pathspec created-p))))
(/show0 "filesys.lisp 1000")
projects / sbcl.git / blobdiff