checked for whatever they may have protected."
(declare (type simple-base-string namestr)
(type index start end))
- (let* ((result (make-string (- end start)))
+ (let* ((result (make-string (- end start) :element-type 'base-char))
(dst 0)
(quoted nil))
(do ((src start (1+ src)))
(declare (type simple-base-string namestr)
(type index start end))
(let* ((last-dot (position #\. namestr :start (1+ start) :end end
- :from-end t))
- (second-to-last-dot (and last-dot
- (position #\. namestr :start (1+ start)
- :end last-dot :from-end t)))
- (version :newest))
- ;; If there is a second-to-last dot, check to see whether there is
- ;; a valid version after the last dot.
- (when second-to-last-dot
- (cond ((and (= (+ last-dot 2) end)
- (char= (schar namestr (1+ last-dot)) #\*))
- (setf version :wild))
- ((and (< (1+ last-dot) end)
- (do ((index (1+ last-dot) (1+ index)))
- ((= index end) t)
- (unless (char<= #\0 (schar namestr index) #\9)
- (return nil))))
- (setf version
- (parse-integer namestr :start (1+ last-dot) :end end)))
- (t
- (setf second-to-last-dot nil))))
- (cond (second-to-last-dot
- (values (maybe-make-pattern namestr start second-to-last-dot)
- (maybe-make-pattern namestr
- (1+ second-to-last-dot)
- last-dot)
- version))
- (last-dot
- (values (maybe-make-pattern namestr start last-dot)
- (maybe-make-pattern namestr (1+ last-dot) end)
- version))
- (t
- (values (maybe-make-pattern namestr start end)
- nil
- version)))))
+ :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")
(values absolute (pieces)))))
(defun parse-unix-namestring (namestr start end)
- (declare (type simple-base-string namestr)
+ (declare (type simple-string namestr)
(type index start end))
+ (setf namestr (coerce namestr 'simple-base-string))
(multiple-value-bind (absolute pieces) (split-at-slashes namestr start end)
(multiple-value-bind (name type version)
(let* ((tail (car (last pieces)))
(t
(error "invalid pattern piece: ~S" piece))))))
(apply #'concatenate
- 'simple-string
+ 'simple-base-string
(strings))))))
(defun unparse-unix-directory-list (directory)
(pieces "/"))
(t
(error "invalid directory component: ~S" dir)))))
- (apply #'concatenate 'simple-string (pieces))))
+ (apply #'concatenate 'simple-base-string (pieces))))
(defun unparse-unix-directory (pathname)
(declare (type pathname pathname))
;; translating logical pathnames to a filesystem without
;; versions (like Unix).
(when 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))
+ (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-string (strings))))
+ (apply #'concatenate 'simple-base-string (strings))))
(/show0 "filesys.lisp 406")
(defun unparse-unix-namestring (pathname)
(declare (type pathname pathname))
- (concatenate 'simple-string
+ (concatenate 'simple-base-string
(unparse-unix-directory pathname)
(unparse-unix-file pathname)))
(defaults-directory (%pathname-directory defaults))
(prefix-len (length defaults-directory))
(result-directory
- (cond ((and (> prefix-len 1)
+ (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)
;; We are an absolute pathname, so we can just use it.
pathname-directory)
(t
- ;; We are a relative directory. So we lose.
- (lose)))))
+ (bug "Bad fallthrough in ~S" 'unparse-unix-enough)))))
(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)))))
+ (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
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)))
- (when version-needed
- (typecase pathname-version
- ((member :wild)
- (strings ".*"))
- (integer
- (strings (format nil ".~D" pathname-version)))
- (t
- (lose)))))
+ (strings (unparse-unix-piece pathname-type))))
(apply #'concatenate 'simple-string (strings)))))
\f
;;;; wildcard matching stuff
(let ((piece (car tail)))
(etypecase piece
(simple-string
- (let ((head (concatenate 'string head piece)))
+ (let ((head (concatenate 'base-string head piece)))
(with-directory-node-noted (head)
- (%enumerate-directories (concatenate 'string 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 "~@<invalid use of ~S after :WILD-INFERIORS~@:>."
+ :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 'string head name)))
+ (let ((subdir (concatenate 'base-string head name)))
(multiple-value-bind (res dev ino mode)
(unix-xstat subdir)
(declare (type (or fixnum null) mode))
(eql (cdr dir) ino))
(return t)))
(let ((nodes (cons (cons dev ino) nodes))
- (subdir (concatenate 'string subdir "/")))
+ (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 'string head name)))
+ (let ((subdir (concatenate 'base-string head name)))
(multiple-value-bind (res dev ino mode)
(unix-xstat subdir)
(declare (type (or fixnum null) mode))
(eql (logand mode sb!unix:s-ifmt)
sb!unix:s-ifdir))
(let ((nodes (cons (cons dev ino) nodes))
- (subdir (concatenate 'string subdir "/")))
+ (subdir (concatenate 'base-string subdir "/")))
(%enumerate-directories subdir (rest tail) pathname
verify-existence follow-links
nodes function))))))))
((member :up)
- (with-directory-node-removed (head)
- (let ((head (concatenate 'string head "..")))
+ (when (string= head "/")
+ (error 'simple-file-error
+ :pathname pathname
+ :format-control "~@<invalid use of :UP after :ABSOLUTE.~@:>"))
+ (with-directory-node-removed (head)
+ (let ((head (concatenate 'base-string head "..")))
(with-directory-node-noted (head)
- (%enumerate-directories (concatenate 'string head "/")
+ (%enumerate-directories (concatenate 'base-string head "/")
(rest tail) pathname
verify-existence follow-links
- nodes function)))))))
+ 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 "~@<invalid use of :BACK after :ABSOLUTE.~@:>"))))
(%enumerate-files head pathname verify-existence function))))
;;; Call FUNCTION on files.
(/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)))
+ (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)
(components-match file-type type)
(components-match file-version version))
(funcall function
- (concatenate 'string
+ (concatenate 'base-string
directory
complete-filename))))))
(t
(/noshow0 "default case")
- (let ((file (concatenate 'string directory name)))
+ (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 'string file "." type)))
- (unless (member version '(nil :newest :wild))
+ (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 'string file "."
+ (setf file (concatenate 'base-string file "."
(quick-integer-to-string version))))
(/noshow0 "finished possibly tweaking FILE")
(when (or (not verify-existence)
((zerop n) "0")
((eql n 1) "1")
((minusp n)
- (concatenate 'simple-string "-"
- (the simple-string (quick-integer-to-string (- 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))
+ (res (make-string len :element-type 'base-char))
(i (1- len) (1- i))
(q n)
(r 0))
;;; 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 this should signal file-error if the pathname is wild, whether
-;;; or not it turns out to have only one match. Fix post 0.7.2
(defun unix-namestring (pathname-spec &optional (for-input t))
(let* ((namestring (physicalize-pathname (merge-pathnames pathname-spec)))
(matches nil)) ; an accumulator for actual matches
:format-arguments (list (namestring pathname))))
result))
-;;; If PATHNAME exists, return its truename, otherwise NIL.
(defun probe-file (pathname)
#!+sb-doc
"Return a pathname which is the truename of the file if it exists, or NIL
(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))))))))
+ (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))))))))
\f
;;;; miscellaneous other operations
~I~_~A~:>"
: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)
(/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
;; (which can arise when e.g. multiple symlinks map to the
;; same truename).
(truenames (make-hash-table :test #'equal))
- (merged-pathname (merge-pathnames pathname
- *default-pathname-defaults*)))
- (!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)))
+ ;; 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
:device (pathname-device pathname)
:directory (subseq dir 0 i))))
(unless (probe-file newpath)
- (let ((namestring (namestring newpath)))
+ (let ((namestring (coerce (namestring newpath) 'base-string)))
(when verbose
(format *standard-output*
"~&creating directory: ~A~%"
projects / sbcl.git / blobdiff