X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffilesys.lisp;h=9349fe9f714d4c66492fa9e0dcdeb638f5600459;hb=fec3614baf361523a4fb154ed80d9b73e1452b2d;hp=214e5857175a7a39c61eaa5e880378529c4d223f;hpb=21bb73db9c3f333ead8a848f863b957a6db5a5c9;p=sbcl.git diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 214e585..9349fe9 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -53,29 +53,29 @@ "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)) + (type index start end)) + (let* ((result (make-string (- end start) :element-type 'base-char)) + (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))) + :complaint "backslash in a bad place" + :namestring namestr + :offset (1- end))) + (%shrink-vector result dst))) (defvar *ignore-wildcards* nil) @@ -83,115 +83,91 @@ (defun maybe-make-pattern (namestr start end) (declare (type simple-base-string namestr) - (type index start end)) + (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))))))) + (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))))))) (/show0 "filesys.lisp 160") (defun extract-name-type-and-version (namestr start end) (declare (type simple-base-string namestr) - (type index start end)) + (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))))) + :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 200") @@ -200,202 +176,186 @@ ;;; location. (defun split-at-slashes (namestr start end) (declare (type simple-base-string namestr) - (type index start end)) + (type index start end)) (let ((absolute (and (/= start end) - (char= (schar namestr start) #\/)))) + (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)))) + (let ((slash (position #\/ namestr :start start :end end))) + (pieces (cons start (or slash end))) + (unless slash + (return)) + (setf start (1+ slash)))) (values absolute (pieces))))) -;;; the thing before a colon in a logical path -(def!struct (logical-hostname (:make-load-form-fun - (lambda (x) - (values `(make-logical-hostname - ,(logical-hostname-name x)) - nil))) - (:copier nil) - (:constructor make-logical-hostname (name))) - (name (missing-arg) :type simple-string)) - -(defun maybe-extract-logical-hostname (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 (make-logical-hostname - (remove-backslashes namestr start index)) - (1+ index))))))))) - -(defun parse-unix-namestring (namestr start end) - (declare (type simple-base-string namestr) +(defun parse-unix-namestring (namestring start end) + (declare (type simple-string namestring) (type index start end)) - (multiple-value-bind (absolute pieces) (split-at-slashes namestr start end) - (let ((logical-hostname - (if absolute - nil - (let ((first (car pieces))) - (multiple-value-bind (logical-hostname new-start) - (maybe-extract-logical-hostname namestr - (car first) - (cdr first)) - (when logical-hostname - (setf absolute t) - (setf (car first) new-start)) - logical-hostname))))) - (declare (type (or null logical-hostname) logical-hostname)) - (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))) - - (when (stringp name) - (let ((position (position-if (lambda (char) - (or (char= char (code-char 0)) - (char= char #\/))) - name))) - (when position - (error 'namestring-parse-error - :complaint "can't embed #\\Nul or #\\/ in Unix namestring" - :namestring namestr - :offset position)))) - - ;; Now we have everything we want. So return it. - (values nil ; no host for Unix namestrings - nil ; no device for Unix namestrings - (collect ((dirs)) - (when logical-hostname - (dirs logical-hostname)) - (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))))) + (setf namestring (coerce namestring 'simple-base-string)) + (multiple-value-bind (absolute pieces) + (split-at-slashes namestring start end) + (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 namestring tail-start tail-end))) + + (when (stringp name) + (let ((position (position-if (lambda (char) + (or (char= char (code-char 0)) + (char= char #\/))) + name))) + (when position + (error 'namestring-parse-error + :complaint "can't embed #\\Nul or #\\/ in Unix namestring" + :namestring namestring + :offset position)))) + ;; Now we have everything we want. So return it. + (values nil ; no host for Unix namestrings + nil ; no device for Unix namestrings + (collect ((dirs)) + (dolist (piece pieces) + (let ((piece-start (car piece)) + (piece-end (cdr piece))) + (unless (= piece-start piece-end) + (cond ((string= namestring ".." + :start1 piece-start + :end1 piece-end) + (dirs :up)) + ((string= namestring "**" + :start1 piece-start + :end1 piece-end) + (dirs :wild-inferiors)) + (t + (dirs (maybe-make-pattern namestring + piece-start + piece-end))))))) + (cond (absolute + (cons :absolute (dirs))) + ((dirs) + (cons :relative (dirs))) + (t + nil))) + name + type + version)))) + +(defun parse-native-unix-namestring (namestring start end) + (declare (type simple-string namestring) + (type index start end)) + (setf namestring (coerce namestring 'simple-base-string)) + (multiple-value-bind (absolute ranges) + (split-at-slashes namestring start end) + (let* ((components (loop for ((start . end) . rest) on ranges + for piece = (subseq namestring start end) + collect (if (and (string= piece "..") rest) + :up + piece))) + (name-and-type + (let* ((end (first (last components))) + (dot (position #\. end :from-end t))) + ;; FIXME: can we get this dot-interpretation knowledge + ;; from existing code? EXTRACT-NAME-TYPE-AND-VERSION + ;; does slightly more work than that. + (cond + ((string= end "") + (list nil nil)) + ((and dot (> dot 0)) + (list (subseq end 0 dot) (subseq end (1+ dot)))) + (t + (list end nil)))))) + (values nil + nil + (cons (if absolute :absolute :relative) (butlast components)) + (first name-and-type) + (second name-and-type) + nil)))) (/show0 "filesys.lisp 300") (defun unparse-unix-host (pathname) (declare (type pathname pathname) - (ignore pathname)) - "Unix") + (ignore pathname)) + ;; this host designator needs to be recognized as a physical host in + ;; PARSE-NAMESTRING. Until sbcl-0.7.3.x, we had "Unix" here, but + ;; that's a valid Logical Hostname, so that's a bad choice. -- CSR, + ;; 2002-05-09 + "") (defun unparse-unix-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)) (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)))))) + (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)))))) + 'simple-base-string + (strings)))))) (defun unparse-unix-directory-list (directory) (declare (type list directory)) (collect ((pieces)) (when directory (ecase (pop directory) - (:absolute - (cond ((logical-hostname-p (car directory)) - ;; FIXME: The old CMU CL "search list" extension is - ;; gone, but the old machinery is still being used - ;; clumsily here and elsewhere, to represent anything - ;; which belongs before a colon prefix in the ANSI - ;; pathname machinery. This should be cleaned up, - ;; using simpler machinery with more mnemonic names. - (pieces (logical-hostname-name (pop directory))) - (pieces ":")) - (t - (pieces "/")))) - (:relative - ;; nothing special - )) + (:absolute + (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)))) + (typecase dir + ((member :up) + (pieces "../")) + ((member :back) + (error ":BACK cannot be represented in namestrings.")) + ((member :wild-inferiors) + (pieces "**/")) + ((or simple-string pattern (member :wild)) + (pieces (unparse-unix-piece dir)) + (pieces "/")) + (t + (error "invalid directory component: ~S" dir))))) + (apply #'concatenate 'simple-base-string (pieces)))) (defun unparse-unix-directory (pathname) (declare (type pathname pathname)) @@ -405,82 +365,116 @@ (declare (type pathname pathname)) (collect ((strings)) (let* ((name (%pathname-name pathname)) - (type (%pathname-type pathname)) - (type-supplied (not (or (null type) (eq type :unspecific))))) + (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 (and (null type) + (typep name 'string) + (> (length name) 0) + (position #\. name :start 1)) + (error "too many dots in the name: ~S" pathname)) + (when (and (typep name 'string) + (string= name "")) + (error "name is of length 0: ~S" pathname)) + (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)))) + (unless name + (error "cannot specify the type without a file: ~S" pathname)) + (when (typep type 'simple-string) + (when (position #\. type) + (error "type component can't have a #\. inside: ~S" pathname))) + (strings ".") + (strings (unparse-unix-piece type)))) + (apply #'concatenate 'simple-base-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))) + (concatenate 'simple-base-string + (unparse-unix-directory pathname) + (unparse-unix-file pathname))) + +(defun unparse-native-unix-namestring (pathname) + (declare (type pathname pathname)) + (let ((directory (pathname-directory pathname)) + (name (pathname-name pathname)) + (type (pathname-type pathname))) + (coerce + (with-output-to-string (s) + (ecase (car directory) + (:absolute (write-char #\/ s)) + (:relative)) + (dolist (piece (cdr directory)) + (typecase piece + ((member :up) (write-string ".." s)) + (string (write-string piece s)) + (t (error "ungood piece in NATIVE-NAMESTRING: ~S" piece))) + (write-char #\/ s)) + (when name + (unless (stringp name) + (error "non-STRING name in NATIVE-NAMESTRING: ~S" name)) + (write-string name s) + (when type + (unless (stringp type) + (error "non-STRING type in NATIVE-NAMESTRING: ~S" name)) + (write-char #\. s) + (write-string type s)))) + 'simple-base-string))) (defun unparse-unix-enough (pathname defaults) (declare (type pathname pathname defaults)) (flet ((lose () - (error "~S cannot be represented relative to ~S." - pathname defaults))) + (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))))) + (defaults-directory (%pathname-directory defaults)) + (prefix-len (length defaults-directory)) + (result-directory + (cond ((null pathname-directory) '(:relative)) + ((eq (car pathname-directory) :relative) + pathname-directory) + ((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 + (bug "Bad fallthrough in ~S" 'unparse-unix-enough))))) + (strings (unparse-unix-directory-list result-directory))) + (let* ((pathname-type (%pathname-type pathname)) + (type-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)) + (when (and (null pathname-type) + (position #\. pathname-name :start 1)) + (error "too many dots in the name: ~S" pathname)) + (strings (unparse-unix-piece pathname-name))) + (when type-needed + (when (or (null pathname-type) (eq pathname-type :unspecific)) + (lose)) + (when (typep pathname-type 'simple-base-string) + (when (position #\. pathname-type) + (error "type component can't have a #\. inside: ~S" pathname))) + (strings ".") + (strings (unparse-unix-piece pathname-type)))) (apply #'concatenate 'simple-string (strings))))) ;;;; wildcard matching stuff @@ -489,32 +483,32 @@ ;;; 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))) + (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))))) + (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) + &key (verify-existence t) + (follow-links t)) + &body body) `(block nil (%enumerate-matches (pathname ,pathname) - ,verify-existence - ,follow-links - (lambda (,var) ,@body)) + ,verify-existence + ,follow-links + (lambda (,var) ,@body)) ,result)) (/show0 "filesys.lisp 500") @@ -526,148 +520,175 @@ (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))) + (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)))) + (ecase (first directory) + (:absolute + (/noshow0 "absolute directory") + (%enumerate-directories "/" (rest directory) pathname + verify-existence follow-links + nil function)) + (:relative + (/noshow0 "relative directory") + (%enumerate-directories "" (rest directory) pathname + verify-existence follow-links + nil function))) + (%enumerate-files "" pathname verify-existence function)))) ;;; Call FUNCTION on directories. (defun %enumerate-directories (head tail pathname verify-existence - follow-links nodes function) + 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 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 "/") - (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)))) + (let ((piece (car tail))) + (etypecase piece + (simple-string + (let ((head (concatenate 'base-string head piece))) + (with-directory-node-noted (head) + (%enumerate-directories (concatenate 'base-string head "/") + (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 (ignore-errors (directory-lispy-filenames head))) + (let ((subdir (concatenate 'base-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 'base-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 'base-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 'base-string subdir "/"))) + (%enumerate-directories subdir (rest tail) pathname + verify-existence follow-links + nodes function)))))))) + ((member :up) + (when (string= head "/") + (error 'simple-file-error + :pathname pathname + :format-control "~@")) + (with-directory-node-removed (head) + (let ((head (concatenate 'base-string head ".."))) + (with-directory-node-noted (head) + (%enumerate-directories (concatenate 'base-string head "/") + (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 "/")) + (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))) + (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))) - (/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)) - (/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 "UNSPECIFIC, more or less") + (let ((directory (coerce directory 'base-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 'base-string + directory + complete-filename)))))) + (t + (/noshow0 "default case") + (let ((file (concatenate 'base-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 'base-string file "." type))) + (unless (member version '(nil :newest :wild :unspecific)) + (/noshow0 "tweaking FILE for more-or-less-:WILD case") + (setf file (concatenate 'base-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") @@ -675,43 +696,43 @@ (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)))))) + (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 + (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.) )) @@ -719,32 +740,18 @@ ;;; 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. (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))))))) + (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"))))) ;;;; TRUENAME and PROBE-FILE @@ -758,36 +765,30 @@ Under Unix, the TRUENAME of a broken symlink is considered to be the name of the broken symlink itself." - (if (wild-pathname-p pathname) + (let ((result (probe-file pathname))) + (unless result (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))) - -;;; If PATHNAME exists, return its truename, otherwise NIL. + :pathname pathname + :format-control "The file ~S does not exist." + :format-arguments (list (namestring pathname)))) + result)) + (defun probe-file (pathname) #!+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))) + 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)))))))) + (when trueishname + (let* ((*ignore-wildcards* t) + (name (sb!unix:unix-simplify-pathname trueishname))) + (if (eq (sb!unix:unix-file-kind name) :directory) + (pathname (concatenate 'string name "/")) + (pathname name)))))))) ;;;; miscellaneous other operations @@ -798,24 +799,24 @@ "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))) + (original-namestring (unix-namestring original t)) + (new-name (merge-pathnames new-name original)) + (new-namestring (unix-namestring new-name nil))) (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 "~@" - :format-arguments (list original new-name (strerror error)))) + :format-arguments (list original new-name (strerror error)))) (when (streamp file) - (file-name file new-namestring)) + (file-name file new-name)) (values new-name original (truename new-name))))) (defun delete-file (file) @@ -826,77 +827,195 @@ (close file :abort t)) (unless namestring (error 'simple-file-error - :pathname file - :format-control "~S doesn't exist." - :format-arguments (list file))) + :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)))) + (simple-file-perror "couldn't delete ~A" namestring err)))) t) -;;; (This is an ANSI Common Lisp function.) -;;; -;;; This is obtained from the logical name \"home:\", which is set -;;; up for us at initialization time. +;;; (This is an ANSI Common Lisp function.) (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:")) + (pathname (sb!unix:uid-homedir (sb!unix:unix-getuid)))) (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))))))) + (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 file-author (file) #!+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) + (let ((name (unix-namestring (pathname file) t))) + (unless name (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)) - (and winp (sb!unix:uid-username uid)))))) + :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)) + (and winp (sb!unix:uid-username uid))))) ;;;; DIRECTORY (/show0 "filesys.lisp 800") +;;; NOTE: There is a fair amount of hair below that is probably not +;;; strictly necessary. +;;; +;;; 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: 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. +(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 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))))))))) + (defun directory (pathname &key) #!+sb-doc "Return a list of PATHNAMEs, each the TRUENAME of a file that matched the @@ -905,46 +1024,63 @@ 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 fast way of removing duplicates (which - ;; can arise when e.g. multiple symlinks map to the same - ;; truename). - (truenames (make-hash-table :test #'equal)) - (merged-pathname (merge-pathnames pathname - (make-pathname :name :wild - :type :wild - :version :wild)))) - (!enumerate-matches (match merged-pathname) - (let ((*ignore-wildcards* t) - (truename (truename (if (eq (sb!unix:unix-file-kind match) - :directory) - (concatenate 'string match "/") - match)))) - (setf (gethash (namestring truename) truenames) - 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. + ;; 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) + using (hash-value truename) collect (cons name truename)) #'string< - :key #'car)))) + :key #'car)))) (/show0 "filesys.lisp 899") ;;; predicate to order pathnames by; goes by name (defun pathname-order (x y) (let ((xn (%pathname-name x)) - (yn (%pathname-name y))) + (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))) + (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 ensure-directories-exist (pathspec &key verbose (mode #o777)) #!+sb-doc @@ -953,30 +1089,36 @@ The MODE argument is a CMUCL/SBCL-specific extension to control the Unix permission bits." (let ((pathname (physicalize-pathname (pathname pathspec))) - (created-p nil)) + (created-p nil)) (when (wild-pathname-p pathname) (error 'simple-file-error - :format-control "bad place for a wild pathname" - :pathname pathspec)) + :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 (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))))) + 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 (namestring newpath) 'base-string))) + (when verbose + (format *standard-output* + "~&creating directory: ~A~%" + namestring)) + (sb!unix:unix-mkdir namestring mode) + (unless (probe-file namestring) + (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))))) (values pathname created-p)))) (/show0 "filesys.lisp 1000")