Changeset 314

Timestamp:

Jan 17, 2004, 7:46:12 PM (21 years ago)

Author:

Gary Byers

Message:

Quote dots in namestring components. Catch a few bogus cases, like
(:ABSOLUTE :UP) in directory.

File:

• trunk/ccl/level-1/l1-files.lisp (modified) (4 diffs)

trunk/ccl/level-1/l1-files.lisp

@@ -181 +181 @@
 
 
-#|
-(defstruct (pattern
-            (:constructor make-pattern (pieces)))
-  (pieces nil :type list))
-
-(defmethod make-load-form ((p pattern))
-  (make-load-form-saving-slots p))
-
-(defmethod print-object ((p pattern) stream)
-  (print-unreadable-object (p stream :type t)
-    (let* ((pieces (pattern-pieces p)))
-      (if *print-pretty*
-        (let ((*print-escape* t))
-          (pprint-fill stream pieces nil))
-        (prin1 pieces stream)))))
-
-(defvar *ignore-wildcards* nil)
-
-
-(defun remove-backslashes (namestr start end)
-  "Remove and occurences of \\ from the string because we've already
-   checked for whatever they may have been backslashed."
-  (declare (type simple-base-string namestr)
-           (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))
-      (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)))))))
-    (when quoted
-      (error 'namestring-parse-error
-             :complaint "Backslash in bad place."
-             :namestring namestr
-             :offset (1- end)))
-    (shrink-vector result dst)))
-
-(defun maybe-make-pattern (namestr start end)
-  (declare (type simple-base-string namestr)
-           (type index start end))
-  (if *ignore-wildcards*
-      (subseq namestr start end)
-      (let* ((pattern ()))
-        (let* ((quoted nil)
-              (any-quotes nil)
-              (last-regular-char nil)
-              (index start))
-          (flet ((flush-pending-regulars ()
-                   (when last-regular-char
-                     (push (if any-quotes
-                               (remove-backslashes namestr
-                                                   last-regular-char
-                                                   index)
-                               (subseq namestr last-regular-char index)) 
-                           pattern)
-                     (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)
-                       (push :single-char-wild pattern)
-                       (incf index))
-                      ((char= char #\*)
-                       (flush-pending-regulars)
-                       (push :multi-char-wild pattern)
-                       (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))
-                         (push (list :character-set
-                                        (subseq namestr
-                                                (1+ index)
-                                                close-bracket))
-                          pattern)
-                         (setf index (1+ close-bracket))))
-                      (t
-                       (unless last-regular-char
-                         (setf last-regular-char index))
-                       (incf index)))))
-            (flush-pending-regulars)))
-        (cond ((null (setq pattern (nreverse 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 extract-name-type-and-version (namestr start end)
-  (declare (type simple-base-string namestr)
-           (type index start end))
-  (let* ((last-dot (position #\. namestr :start (1+ start) :end end
-                             :from-end t))
-         (second-to-last-dot (and last-dot
-                                  (position #\. namestr :start (1+ start)
-                                            :end last-dot :from-end t)))
-         (version nil))
-    ;; If there is a second-to-last dot, check to see if 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)))))
-
-;;; Take a string and return a list of cons cells that mark the char
-;;; separated subseq. The first value t if absolute directories location.
-;;;
-(defun split-at-slashes (namestr start end)
-  (declare (type simple-base-string namestr)
-           (type index start end))
-  (let ((absolute (and (/= start end)
-                       (char= (schar namestr start) #\/))))
-    (when absolute
-      (incf start))
-    ;; Next, split the remainder into slash seperated chunks.
-    (let* ((pieces ()))
-      (loop
-        (let ((slash (position #\/ namestr :start start :end end)))
-          (push (cons start (or slash end)) pieces)
-          (unless slash
-            (return))
-          (setf start (1+ slash))))
-      (values absolute (nreverse pieces)))))
-
-(defun parse-unix-namestring (namestr start end)
-  (declare (type simple-base-string namestr)
-           (type index start end))
-  (multiple-value-bind
-      (absolute pieces)
-      (split-at-slashes namestr start end)
-    (multiple-value-bind
-          (name type)
-        (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)))
-      ;; Now we have everything we want.  So return it.
-      (values nil ; no host for unix namestrings.
-              (let* ((dirs ()))
-                (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)
-                             (push :up dirs))
-                            ((string= namestr "**" :start1 piece-start
-                                      :end1 piece-end)
-                             (push :wild-inferiors dirs))
-                            (t
-                             (push (maybe-make-pattern namestr
-                                                       piece-start
-                                                       piece-end) 
-                              dirs))))))
-                (setq dirs (nreverse dirs))
-                (cond (absolute
-                       (cons :absolute dirs))
-                      (dirs
-                       (cons :relative dirs))
-                      (t
-                       nil)))
-              name
-              type
-              nil))))
-
-(defun unparse-unix-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 :element-type 'base-char))
-             (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
-     (let* ((strings ()))
-       (dolist (piece (pattern-pieces thing))
-         (etypecase piece
-           (simple-string
-            (push piece strings))
-           (symbol
-            (ecase piece
-              (:multi-char-wild
-               (push "*" strings))
-              (:single-char-wild
-               (push "?" strings))))
-           (cons
-            (case (car piece)
-              (:character-set
-               (push "[" strings)
-               (push (cdr piece) strings)
-               (push "]" strings))
-              (t
-               (error "Invalid pattern piece: ~S" piece))))))
-       (apply #'concatenate
-              'simple-string
-              (nreverse strings))))))
-
-(defun unparse-unix-directory-list (directory)
-  (declare (type list directory))
-  (let* ((pieces ()))
-    (when directory
-      (ecase (pop directory)
-        (:absolute
-         (push "/" pieces))
-        (:relative
-         ;; Nothing special.
-         ))
-      (dolist (dir directory)
-        (typecase dir
-          ((member :up)
-           (push "../" pieces))
-          ((member :back)
-           (error ":BACK cannot be represented in namestrings."))
-          ((member :wild-inferiors)
-           (push "**/" pieces))
-          ((or simple-string pattern)
-           (push (unparse-unix-piece dir) pieces)
-           (push "/" pieces))
-          (t
-           (error "Invalid directory component: ~S" dir)))))
-    (apply #'concatenate 'simple-string (nreverse pieces))))
-
-(defun %pathname-host (pathname)
-  (if (logical-pathname-p pathname)
-      (%logical-pathname-host pathname)
-      :unspecific))
-
-(defun %pathname-version (pathname)
-  (if (logical-pathname-p pathname)
-      (%logical-pathname-version pathname)
-      :newest))
-
-(defun unparse-unix-file (pathname)
-  (declare (type pathname pathname))
-  (let* ((strings ()))
-    (let* ((name (%pathname-name pathname))
-           (type (%pathname-type pathname))
-           (type-supplied (not (or (null type) (eq type :unspecific))))
-           (version (%pathname-version pathname))
-           (version-supplied (not (or (null version) (eq version :newest)))))
-      (when name
-        (push (unparse-unix-piece name) strings))
-      (when type-supplied
-        (push "." strings)
-        (push (unparse-unix-piece type) strings))
-      (when version-supplied
-        (unless type-supplied
-          (error "Cannot specify the version without a type: ~S" pathname))
-        (push (if (eq version :wild)
-             ".*"
-             (format nil ".~D" version)) 
-         strings)))
-    (apply #'concatenate 'simple-string (nreverse strings))))
-
-(defun unparse-unix-namestring (pathname)
-  (declare (type pathname pathname))
-  (concatenate 'simple-string
-               (unparse-unix-directory-list (%pathname-directory pathname))
-               (unparse-unix-file pathname)))
-
-(defun unparse-logical-piece (thing)
-  (etypecase thing
-    (simple-string thing)
-    (pattern
-     (let* ((strings ()))
-       (dolist (piece (pattern-pieces thing))
-         (etypecase piece
-           (simple-string (push piece strings))
-           (keyword
-            (cond ((eq piece :wild-inferiors)
-                   (push "**" strings))
-                  ((eq piece :multi-char-wild)
-                   (push "*" strings))
-                  (t (error "Invalid keyword: ~S" piece))))))
-       (apply #'concatenate 'simple-string (nreverse strings))))))
-
-(defun unparse-logical-directory (pathname)
-  (declare (type pathname pathname))
-  (let* ((pieces ()))
-    (let ((directory (%pathname-directory pathname)))
-      (when directory
-        (ecase (pop directory)
-          (:absolute)    ;; Nothing special.
-          (:relative (push ";" pieces)))
-        (dolist (dir directory)
-          (cond ((or (stringp dir) (pattern-p dir))
-                 (push (unparse-logical-piece dir) pieces)
-                 (push ";" pieces))
-                ((eq dir :wild)
-                 (push "*;" pieces))
-                ((eq dir :wild-inferiors)
-                 (push "**;" pieces))
-                (t
-                 (error "Invalid directory component: ~S" dir))))))
-    (apply #'concatenate 'simple-string (nreverse pieces))))
-
-(defun unparse-logical-namestring (pathname)
-  (declare (type logical-pathname pathname))
-  (concatenate 'simple-string
-               (%pathname-host pathname) ":"
-               (unparse-logical-directory pathname)
-               (unparse-unix-file pathname)))
-
-(defun maybe-make-logical-pattern (namestring chunks)
-  (let* ((chunk (caar chunks)))
-    (let* ((pattern ()))
-      (let* ((last-pos 0)
-             (len (length chunk)))
-        (declare (fixnum last-pos))
-        (loop
-          (when (= last-pos len) (return))
-          (let ((pos (or (position #\* chunk :start last-pos) len)))
-            (if (= pos last-pos)
-                (when pattern
-                  (error 'namestring-parse-error
-                         :complaint "Double asterisk inside of logical ~
-                                     word: ~S"
-                         :arguments (list chunk)
-                         :namestring namestring
-                         :offset (+ (cdar chunks) pos)))
-                (push (subseq chunk last-pos pos) pattern))
-            (if (= pos len)
-                (return)
-                (push :multi-char-wild pattern))
-            (setq last-pos (1+ pos)))))
-      (setq pattern (nreverse pattern))
-        (if (cdr pattern)
-            (make-pattern pattern)
-            (let ((x (car pattern)))
-              (if (eq x :multi-char-wild)
-                  :wild
-                  x))))))
-
-(defun logical-chunkify (namestr start end)
-  (let* ((chunks nil))
-    (do ((i start (1+ i))
-         (prev 0))
-        ((= i end)
-         (when (> end prev)
-            (push (cons (subseq namestr prev end) prev) chunks)))
-      (let ((ch (schar namestr i)))
-        (unless (or (alpha-char-p ch) (digit-char-p ch)
-                    (member ch '(#\- #\*)))
-          (when (> i prev)
-            (push (cons (subseq namestr prev i) prev) chunks))
-          (setq prev (1+ i))
-          (unless (member ch '(#\; #\: #\.))
-            (error 'namestring-parse-error
-                   :complaint "Illegal character for logical pathname:~%  ~S"
-                   :arguments (list ch)
-                   :namestring namestr
-                   :offset i))
-          (push (cons ch i) chunks))))
-    (nreverse chunks)))
-
-(defun find-logical-host (hostname &optional (errorp t))
-  (let* ((found (%str-assoc hostname %logical-host-translations%)))
-    (unless (or found (not errorp))
-      (error "Logical host not yet defined: ~S" hostname))
-    (car found)))
-
-(defun parse-logical-namestring (namestr start end)
-  (declare (type simple-base-string namestr)
-           (type index start end))
-  (let* ((directory ()))
-    (let* ((host nil)
-           (name nil)
-           (type nil)
-           (version nil))
-      (labels ((expecting (what chunks)
-                 (unless (and chunks (simple-string-p (caar chunks)))
-                   (error 'namestring-parse-error
-                          :complaint "Expecting ~A, got ~:[nothing~;~S~] ."
-                          :arguments (list what (caar chunks) (caar chunks))
-                          :namestring namestr
-                          :offset (if chunks (cdar chunks) end)))
-                 (caar chunks))
-               (parse-host (chunks)
-                 (case (caadr chunks)
-                   (#\:
-                    (setq host
-                          (find-logical-host (expecting "a host name" chunks)))
-                    (parse-relative (cddr chunks)))
-                   (t
-                    (parse-relative chunks))))
-               (parse-relative (chunks)
-                 (case (caar chunks)
-                   (#\;
-                    (push :relative directory)
-                    (parse-directory (cdr chunks)))
-                   (t
-                    (push :absolute directory) ; Assumption! Maybe revoked later.
-                    (parse-directory chunks))))
-               (parse-directory (chunks)
-                 (case (caadr chunks)
-                   (#\;
-                    (push
-                     (let ((res (expecting "a directory name" chunks)))
-                       (cond ((string= res "..") :up)
-                             ((string= res "**") :wild-inferiors)
-                             (t
-                              (maybe-make-logical-pattern namestr chunks))))
-                     directory)
-                    (parse-directory (cddr chunks)))
-                   (t
-                    (parse-name chunks))))
-               (parse-name (chunks)
-                 (when chunks
-                   (expecting "a file name" chunks)
-                   (setq name (maybe-make-logical-pattern namestr chunks))
-                   (expecting-dot (cdr chunks))))
-               (expecting-dot (chunks)
-                 (when chunks
-                   (unless (eql (caar chunks) #\.)
-                     (error 'namestring-parse-error
-                            :complaint "Expecting a dot, got ~S."
-                            :arguments (list (caar chunks))
-                            :namestring namestr
-                            :offset (cdar chunks)))
-                   (if type
-                     (parse-version (cdr chunks))
-                     (parse-type (cdr chunks)))))
-               (parse-type (chunks)
-                 (expecting "a file type" chunks)
-                 (setq type (maybe-make-logical-pattern namestr chunks))
-                 (expecting-dot (cdr chunks)))
-               (parse-version (chunks)
-                 (let ((str (expecting "a positive integer, * or NEWEST"
-                                       chunks)))
-                   (cond
-                     ((string= str "*") (setq version :wild))
-                     ((string= str "NEWEST") (setq version :newest))
-                     (t
-                      (multiple-value-bind
-                          (res pos)
-                          (parse-integer str :junk-allowed t)
-                        (unless (and res (plusp res))
-                          (error 'namestring-parse-error
-                                 :complaint "Expected a positive integer, ~
-    got ~S"
-                                 :arguments (list str)
-                                 :namestring namestr
-                                 :offset (+ pos (cdar chunks))))
-                        (setq version res)))))
-                 (when (cdr chunks)
-                   (error 'namestring-parse-error
-                          :complaint "Extra stuff after end of file name."
-                          :namestring namestr
-                          :offset (cdadr chunks)))))
-        (parse-host (logical-chunkify namestr start end)))
-      (setq directory (nreverse directory))
-      (values host
-              (and (not (equal directory '(:absolute)))directory)
-              name type version))))
-
-(defun extract-logical-host-prefix (namestr start end)
-  (declare (type simple-base-string namestr)
-           (type index start end)
-           (values (or logical-host null)))
-  (let ((colon-pos (position #\: namestr :start start :end end)))
-    (if colon-pos
-        (%str-assoc (subseq namestr start colon-pos)
-                    %logical-host-translations%)
-        nil)))
-
-(defun %parse-namestring (namestr host defaults start end junk-allowed)
-  (declare  (type string namestr)
-           (type index start) (type (or index null) end))
-  (if junk-allowed
-      (handler-case
-          (%parse-namestring namestr host defaults start end nil)
-        (namestring-parse-error (condition)
-          (values nil (namestring-parse-error-offset condition))))
-      (let* ((end (or end (length namestr)))
-             (logical-host (car (extract-logical-host-prefix namestr start end)))
-             (parse-host (or host logical-host (pathname-host defaults))))
-        (unless parse-host
-          (error "When Host arg is not supplied, Defaults arg must ~
-                  have a non-null PATHNAME-HOST."))
-        (if (eq host :unspecific)
-            (setq host nil))
-        (setq host (or host logical-host))
-        (multiple-value-bind
-            (new-host directory name type version)
-            (if host
-                (parse-logical-namestring namestr start end)
-                (parse-unix-namestring namestr start end))
-          (when (and host new-host (not (equal new-host host)))
-            (error "Host in namestring: ~S~@
-                    does not match explicit host argument: ~S"
-                   (subseq namestr start end)
-                   host))
-          (cons-pathname directory name type host version)))))
-
-
-(defun parse-namestring (thing
-                         &optional host (defaults *default-pathname-defaults*)
-                         &key (start 0) end junk-allowed)
-  (declare (type pathname defaults)
-           (type index start)
-           (type (or index null) end)
-           (type (or t null) junk-allowed)
-           (values (or null pathname) (or null index)))
-    (typecase thing
-      (simple-string
-       (%parse-namestring thing host defaults start end junk-allowed))
-      (string
-       (%parse-namestring (coerce thing 'simple-string)
-                          host defaults start end junk-allowed))
-      (pathname
-       (let ((host (if host host (%pathname-host defaults))))
-         (unless (equal host (%pathname-host thing))
-           (error "Hosts do not match: ~S and ~S."
-                  host (%pathname-host thing))))
-       (values thing start))
-      (stream
-       (let ((name (stream-pathname thing)))
-         (unless name
-           (error "Can't figure out the file associated with stream:~%  ~S"
-                  thing))
-         name))))
-
-(defun namestring (path &key)
-  (typecase path
-    (logical-pathname (unparse-logical-namestring path))
-    (pathname (unparse-unix-namestring path))
-    (t (namestring (pathname path)))))
-
-|#
-
 ;; The following assumptions are deeply embedded in all our pathname code:
 ;; (1) Non-logical pathname host is always :unspecific.
@@ -842 +242 @@
   dirlist)
 
-; ? is (:absolute "a" :up "b") = (:absolute "b") - seems reasonable
 ; destructively mungs dir
 (defun remove-up (dir)
@@ -938 +337 @@
               ((nil :unspecific) "")
               (:wild "*")
-              (t name))
+              (t (%path-std-quotes name nil ".")))
             (if (or type version)
               (%str-cat (case type
                           ((nil) ".")
                           (:wild ".*")
-                          (t (%str-cat "." type)))
+                          (t (%str-cat "." (%path-std-quotes type nil "."))))
                         (case version
                           ((nil) "")
@@ -1098 +497 @@
                (unless directory-p '(:absolute)))
            name type host version)))
+  (when (and (eq (car directory) :absolute)
+             (member (cadr directory) '(:up :back)))
+    (error 'simple-file-error :pathname path :error-type "Second element of absolute directory component in ~s is ~s" :format-arguments (list (cadr directory))))
+  (let* ((after-wif (cadr (member :wild-inferiors directory))))
+    (when (member after-wif '(:up :back))
+          (error 'simple-file-error :pathname path :error-type "Directory component in ~s contains :WILD-INFERIORS followed by ~s" :format-arguments (list after-wif))))
+         
   (when (and case (neq case :local))
     (setf (%pathname-directory path) (%reverse-component-case (%pathname-directory path) case)