X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffilesys.lisp;h=b51c6014e5ce9f48f0f0db989472da93cbf87830;hb=7f1e94ae961a198e00daf281eb1dc858e5b2dcc7;hp=fb62f42036e9a672c73ce4af974ed9b8b7eba798;hpb=b76dac3d5f89700f3a076403157eae3c52e4c118;p=sbcl.git diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index fb62f42..b51c601 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -80,80 +80,127 @@ :offset (1- end))) (%shrink-vector result dst))) -(defvar *ignore-wildcards* nil) - -(/show0 "filesys.lisp 86") - (defun maybe-make-pattern (namestr start end) (declare (type simple-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 (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)))))) + (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)))))) + +(defun unparse-physical-piece (thing) + (etypecase thing + ((member :wild) "*") + (simple-string + (let* ((srclen (length thing)) + (dstlen srclen)) + (dotimes (i srclen) + (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))) + (pattern + (with-output-to-string (s) + (dolist (piece (pattern-pieces thing)) + (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 - (make-pattern (pattern))))))) + (error "invalid pattern piece: ~S" piece)))))))))) + +(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))))) (/show0 "filesys.lisp 160") @@ -175,306 +222,22 @@ (/show0 "filesys.lisp 200") -;;;; 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 "~@" - :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") - -(defmacro !enumerate-matches ((var pathname &optional result - &key (verify-existence t) - (follow-links t)) - &body body) - `(block nil - (%enumerate-matches (pathname ,pathname) - ,verify-existence - ,follow-links - (lambda (,var) ,@body)) - ,result)) - -(/show0 "filesys.lisp 500") - -;;; Call FUNCTION on matches. -;;; -;;; KLUDGE: this assumes that an absolute pathname is indicated to the -;;; operating system by having a directory separator as the first -;;; character in the directory part. This is true for Win32 pathnames -;;; and for Unix pathnames, but it isn't true for LispM pathnames (and -;;; their bastard offspring, logical pathnames. Also it assumes that -;;; Unix pathnames have an empty or :unspecific device, and that -;;; windows drive letters are the only kinds of non-empty/:UNSPECIFIC -;;; devices. -(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 ((host (pathname-host pathname)) - (device (pathname-device pathname)) - (directory (pathname-directory pathname))) - (/noshow0 "computed HOST and DIRECTORY") - (let* ((dirstring (if directory - (ecase (first directory) - (:absolute (host-unparse-directory-separator host)) - (:relative "")) - "")) - (devstring (if (and device (not (eq device :unspecific))) - (concatenate 'simple-string (string device) (string #\:)) - "")) - (headstring (concatenate 'simple-string devstring dirstring))) - (if directory - (%enumerate-directories headstring (rest directory) pathname - verify-existence follow-links nil function) - (%enumerate-files headstring pathname verify-existence function))))) - -;;; Call FUNCTION on directories. -(defun %enumerate-directories (head tail pathname verify-existence - follow-links nodes function - &aux (host (pathname-host pathname))) - (declare (simple-string head)) - #!+win32 - (setf follow-links nil) - (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)))) - (with-directory-node-removed ((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 (remove (cons dev ino) nodes :test #'equal))) - ,@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 - (host-unparse-directory-separator host)) - (cdr tail) pathname - verify-existence follow-links - nodes function)))) - ((member :wild-inferiors) - ;; now with extra error case handling from CLHS - ;; 19.2.2.4.3 -- CSR, 2004-01-24 - (when (member (cadr tail) '(:up :back)) - (error 'simple-file-error - :pathname pathname - :format-control "~@." - :format-arguments (list (cadr tail)))) - (%enumerate-directories head (rest tail) pathname - verify-existence follow-links - nodes function) - (dolist (name (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) - #!+win32 ;; KLUDGE - (not (zerop ino)) - (eql (cdr dir) ino)) - (return t))) - (let ((nodes (cons (cons dev ino) nodes)) - (subdir (concatenate 'string subdir (host-unparse-directory-separator host)))) - (%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 (host-unparse-directory-separator host)))) - (%enumerate-directories subdir (rest tail) pathname - verify-existence follow-links - nodes function)))))))) - ((member :up) - (when (string= head (host-unparse-directory-separator host)) - (error 'simple-file-error - :pathname pathname - :format-control "~@")) - (with-directory-node-removed (head) - (let ((head (concatenate 'string head ".."))) - (with-directory-node-noted (head) - (%enumerate-directories (concatenate 'string head (host-unparse-directory-separator host)) - (rest tail) pathname - verify-existence follow-links - nodes function))))) - ((member :back) - ;; :WILD-INFERIORS is handled above, so the only case here - ;; should be (:ABSOLUTE :BACK) - (aver (string= head (host-unparse-directory-separator host))) - (error 'simple-file-error - :pathname pathname - :format-control "~@")))) - (%enumerate-files head pathname verify-existence function)))) - -;;; 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") - (let ((directory (coerce directory 'string))) - (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))) - (/noshow "computed basic 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 :unspecific)) - (/noshow0 "tweaking FILE for more-or-less-:WILD case") - (setf file (concatenate 'string file "." - (quick-integer-to-string version)))) - (/noshow0 "finished possibly tweaking 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") - -;;; 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-base-string "-" - (the simple-base-string (quick-integer-to-string (- n))))) - (t - (do* ((len (1+ (truncate (integer-length n) 3))) - (res (make-string len :element-type 'base-char)) - (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)))))) - -;;;; UNIX-NAMESTRING - -(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. Wild-cards are expanded. -;;; -;;; FIXME: apart from the error checking (for wildness and for -;;; existence) and conversion to physical pathanme, this is redundant -;;; with UNPARSE-NATIVE-UNIX-NAMESTRING; one should probably be -;;; written in terms of the other. -;;; -;;; FIXME: actually this (I think) works not just for Unix. -(defun unix-namestring (pathname-spec &optional (for-input t)) - (let* ((namestring (physicalize-pathname (merge-pathnames pathname-spec))) - (matches nil)) ; an accumulator for actual matches - (when (wild-pathname-p namestring) - (error 'simple-file-error - :pathname namestring - :format-control "bad place for a wild pathname")) - (!enumerate-matches (match namestring nil :verify-existence for-input) - (push match matches)) - (case (length matches) - (0 nil) - (1 (first matches)) - (t (bug "!ENUMERATE-MATCHES returned more than one match on a non-wild pathname"))))) +;;;; 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)))))) ;;;; TRUENAME, PROBE-FILE, FILE-AUTHOR, FILE-WRITE-DATE. @@ -504,7 +267,15 @@ ;;; 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. -(defun query-file-system (pathspec query-for enoent-errorp) +;;; +;;; 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) @@ -515,110 +286,133 @@ :format-control "~@" :format-arguments (list query-for pathname pathspec))) - (let ((filename (native-namestring pathname :as-file t))) - (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)) - (if existsp - (case query-for - (:truename (parse-native-namestring - ;; 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... - (multiple-value-bind (realpath errno) - (sb!unix:unix-realpath filename) - (if realpath - realpath - (simple-file-perror "couldn't resolve ~A" - filename errno))) - (pathname-host pathname) - (sane-default-pathname-defaults) - ;; ... but without any trailing slash. - :as-directory (eql (logand mode sb!unix:s-ifmt) - sb!unix:s-ifdir))) - (:author (sb!unix:uid-username uid)) - (:write-date (+ unix-to-universal-time mtime))) - (progn - ;; 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 ELOOP in this case, but we must - ;; distinguish cases where the symlink exists from ones - ;; where there's a loop in the apparent containing - ;; directory. - #!-win32 - (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)) - linkp) - (return-from query-file-system - (case query-for - (: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-native-namestring - (multiple-value-bind (realpath errno) - (sb!unix:unix-realpath - (native-namestring - (make-pathname - :name :unspecific - :type :unspecific - :version :unspecific - :defaults (parse-native-namestring - filename - (pathname-host pathname) - (sane-default-pathname-defaults))))) - (if realpath - realpath - (simple-file-perror "couldn't resolve ~A" - filename errno))) - (pathname-host pathname) - (sane-default-pathname-defaults) - :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; return - ;; NIL or error. - (if (and (= errno sb!unix:enoent) (not enoent-errorp)) - nil - (simple-file-perror - (format nil "failed to find the ~A of ~~A" query-for) - pathspec errno)))))))) + (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)))))))) (defun probe-file (pathspec) #!+sb-doc - "Return the truename of PATHSPEC if such a file exists, the -coercion of PATHSPEC to a pathname if PATHSPEC names a symlink -that links to itself or to a file that doesn't exist, or NIL if -errno is set to ENOENT after trying to stat(2) the file. An -error of type FILE-ERROR is signaled if PATHSPEC is a wild -pathname, or for any other circumstance where stat(2) fails." + "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)) - (defun truename (pathspec) #!+sb-doc "If PATHSPEC is a pathname that names an existing file, return @@ -637,22 +431,22 @@ 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 t) - (query-file-system pathspec :truename t))) + (query-file-system pathspec :truename) + (query-file-system pathspec :truename))) (defun file-author (pathspec) #!+sb-doc "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 :write-date t)) + (query-file-system pathspec :author)) (defun file-write-date (pathspec) #!+sb-doc "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 t)) + (query-file-system pathspec :write-date)) ;;;; miscellaneous other operations @@ -661,11 +455,14 @@ or if PATHSPEC is a wild pathname." (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)) +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 (unix-namestring new-name nil))) + (new-namestring (native-namestring (physicalize-pathname new-name) + :as-file t))) (unless new-namestring (error 'simple-file-error :pathname new-name @@ -681,61 +478,490 @@ or if PATHSPEC is a wild pathname." :format-arguments (list original new-name (strerror error)))) (when (streamp file) (file-name file new-name)) - (values new-name original (truename 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))))) + (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 - #-win32 sb!impl::*unix-host* - #+win32 sb!impl::*win32-host* + #!-win32 sb!impl::*unix-host* + #!+win32 sb!impl::*win32-host* *default-pathname-defaults* :as-directory t)))) +(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)))))) + ;;; (This is an ANSI Common Lisp function.) (defun user-homedir-pathname (&optional host) #!+sb-doc "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." +system. HOST argument is ignored by SBCL." (declare (ignore host)) - (let ((env-home (posix-getenv "HOME"))) - (parse-native-namestring - (if (and env-home (not (string= env-home ""))) - env-home - #!-win32 - (sb!unix:uid-homedir (sb!unix:unix-getuid)) - #!+win32 - ;; Needs to bypass PARSE-NATIVE-NAMESTRING & ENSURE-TRAILING-SLASH - ;; What?! -- RMK, 2007-12-31 - (return-from user-homedir-pathname - (sb!win32::get-folder-pathname sb!win32::csidl_profile))) - #-win32 sb!impl::*unix-host* - #+win32 sb!impl::*win32-host* - *default-pathname-defaults* - :as-directory t))) + (values + (parse-native-namestring + (or (user-homedir-namestring) + #!+win32 + (sb!win32::get-folder-namestring sb!win32::csidl_profile)) + #!-win32 sb!impl::*unix-host* + #!+win32 sb!impl::*win32-host* + *default-pathname-defaults* + :as-directory t))) + ;;;; DIRECTORY -(/show0 "filesys.lisp 800") +(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. 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)))) + +(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 + "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)))) + +;;; 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)))) + +;;; 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))) + +;;; 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. @@ -824,7 +1050,7 @@ system." ((or (null one) (eq one :unspecific)) two) ((or (null two) (eq two :unspecific)) one) ((string= one two) one) - (t nil))) + (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))) @@ -913,75 +1139,13 @@ system." (mapcar (lambda (x) (cons (simple-intersection (car one) (car two)) x)) (intersect-directory-helper (cdr one) (cdr two))))))))) - -(defun directory (pathname &key) - #!+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 (;; 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)) - ;; FIXME: Possibly this MERGE-PATHNAMES call should only - ;; happen once we get a physical pathname. - (merged-pathname (merge-pathnames pathname))) - (labels ((do-physical-directory (pathname) - (aver (not (logical-pathname-p pathname))) - (!enumerate-matches (match pathname) - (let* ((*ignore-wildcards* t) - ;; FIXME: Why 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 - (truename (probe-file match))) - (when truename - (setf (gethash (namestring truename) truenames) - truename))))) - (do-directory (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-directory (translate-pathname p from to))))))) - (do-physical-directory pathname)))) - (do-directory merged-pathname)) - (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 name being each hash-key in truenames - using (hash-value truename) - collect (cons name truename)) - #'string< - :key #'car)))) -(/show0 "filesys.lisp 899") -;;; predicate to order pathnames by; goes by name -;; FIXME: Does anything use this? It's not exported, and I don't find -;; the name anywhere else. -(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 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 @@ -994,37 +1158,48 @@ system." (error 'simple-file-error :format-control "bad place for a wild pathname" :pathname pathspec)) - (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 (coerce (native-namestring newpath) - 'string))) - (when verbose - (format *standard-output* - "~&creating directory: ~A~%" - namestring)) - (sb!unix:unix-mkdir namestring mode) - (unless (probe-file newpath) - (restart-case (error - 'simple-file-error - :pathname pathspec - :format-control - "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))))) + (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")