X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffilesys.lisp;h=1d243d88ba9e3626bbfce96255c55c9a40c9a8ea;hb=b3f188843330c56bd4d17a3c930e73f573b1c71f;hp=c34f73267a3525575573cad0554ae8fb5a7e28c4;hpb=26148f0c8d7d35e1c5e1d363ade79552cbeb0386;p=sbcl.git diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index c34f732..1d243d8 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -54,7 +54,7 @@ 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))) @@ -158,40 +158,16 @@ (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") @@ -362,10 +338,21 @@ ;; 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-base-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)))) @@ -403,13 +390,9 @@ ;; 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))))) + (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 @@ -418,20 +401,18 @@ 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))))) ;;;; wildcard matching stuff @@ -521,18 +502,25 @@ (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 "~@." + :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)) @@ -543,14 +531,14 @@ (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)) @@ -558,18 +546,29 @@ (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 "~@")) + (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 "~@")))) (%enumerate-files head pathname verify-existence function)))) ;;; Call FUNCTION on files. @@ -608,19 +607,19 @@ (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))) + (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) @@ -638,11 +637,11 @@ ((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)) @@ -677,8 +676,6 @@ ;;; 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 @@ -713,7 +710,6 @@ :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 @@ -757,7 +753,7 @@ ~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) @@ -815,6 +811,148 @@ (/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 @@ -827,12 +965,35 @@ ;; (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))) - (!enumerate-matches (match merged-pathname) - (let* ((*ignore-wildcards* t) - (truename (truename match))) - (setf (gethash (namestring truename) truenames) - truename))) + (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