Changeset 15837


Ignore:
Timestamp:
Jun 14, 2013, 3:51:03 PM (7 years ago)
Author:
gz
Message:

Lost checkin... Fix some pathname bugs, I no longer remember which ones.

Location:
trunk/source
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-files.lisp

    r15776 r15837  
    8585
    8686(defun native-translated-namestring (path)
    87   (let ((name (let ((*default-pathname-defaults* #P""))
    88                 (translated-namestring path))))
    89     ;; Check that no quoted /'s
    90     (when (%path-mem-last-quoted "/" name)
    91       (signal-file-error $xbadfilenamechar name #\/))
     87  (let ((name (namestring (translate-logical-pathname path))))
     88    ;; Check that no quoted /'s (or :'s on windows)
     89    (when (%path-mem-last-quoted #-windows-target "/" #+windows-target "/:" name)
     90      (signal-file-error $xbadfilenamechar name
     91                         #-windows-target #\/
     92                         #+windows-target (if (%path-mem-last-quoted ":" name) #\: #\/)))
    9293    ;; Check that no unquoted wildcards.
    9394    (when (%path-mem-last "*" name)
     
    9596    (namestring-unquote name)))
    9697
     98;; TODO: change callers and get rid of this.
    9799(defun native-untranslated-namestring (path)
    98   (let ((name (namestring (translate-logical-pathname path))))
    99     ;; Check that no quoted /'s
    100     (when (%path-mem-last-quoted "/" name)
    101       (signal-file-error $xbadfilenamechar name #\/))
    102     ;; Check that no unquoted wildcards.
    103     (when (%path-mem-last "*" name)
    104       (signal-file-error $xillwild name))
    105     (namestring-unquote name)))
     100  (native-translated-namestring path))
    106101
    107102;; Reverse of above, take native namestring and make a Lisp pathname.
     
    113108  ;; I -think- that that's true for all callers of this function.
    114109  (let* ((*default-pathname-defaults* #p""))
    115     (pathname (%path-std-quotes name nil
    116                                    #+windows-target "*;"
    117                                    #-windows-target "*;:"))))
     110    (pathname (native-to-namestring name))))
     111
     112;; this is used to quote full namestrings, so do not quote /'s, and on windows do not quote :'s either,
     113;; since those are syntactic.  See also native-to-filename.
     114(defun native-to-namestring (native)
     115  (%path-std-quotes native nil #+windows-target "*;" #-windows-target "*;:"))
    118116
    119117(defun native-to-directory-pathname (name)
    120   #+windows-target
    121   (let* ((len (length name)))
    122     (when (and (> len 1) (not (or (eql (schar name (1- len)) #\/)
    123                                   (eql (schar name (1- len)) #\\))))
    124       (setq name (%str-cat name "/")))
    125     (string-to-pathname name))
    126   #-windows-target
    127   (make-directory-pathname  :device nil :directory (%path-std-quotes name nil "*;:")))
     118  (let* ((*default-pathname-defaults* #p""))
     119    #+windows-target
     120    (let* ((len (length name)))
     121      (when (and (> len 1) (not (or (eql (schar name (1- len)) #\/)
     122                                    (eql (schar name (1- len)) #\\))))
     123        (setq name (%str-cat name "/")))
     124      (string-to-pathname (native-to-namestring name)))
     125    #-windows-target
     126    (make-directory-pathname  :device nil :directory (native-to-namestring name))))
     127
     128;; This is used to quote a single native filename component, so directory/device
     129;; markers have been removed.  See also native-to-namestring.
     130(defun native-to-filename (native)
     131  (%path-std-quotes native nil "/:;*"))
     132
     133(defun %std-filename-quotes (name &optional quote-period)
     134  (if quote-period
     135    (%path-std-quotes name "./:;*" "./:;")
     136    (%path-std-quotes name "/:;*" "/:;")))
     137
    128138
    129139;;; Make a pathname which names the specified directory; use
     
    170180                      ((eq ch esc) (setq quote-next t)))))))))))
    171181
    172 (defun translated-namestring (path)
    173   (namestring (translate-logical-pathname (merge-pathnames path))))
    174 
    175 
    176182(defun truename (path)
    177183  "Return the pathname for the actual file described by PATHNAME.
     
    441447              ((nil :unspecific) "")
    442448              (:wild "*")
    443               (t (%path-std-quotes name "*;:" ".")))
     449              ;; Quote periods if there is no type/version following, so don't get mistaken for a type.
     450              ;; Otherwise there is no need to quote them.
     451              (t (%std-filename-quotes name (null (or type version)))))
    444452            (if (or type version)
    445453              (%str-cat (case type
    446454                          ((nil) ".")
    447455                          (:wild ".*")
    448                           (t (%str-cat "." (%path-std-quotes type "*;:" "."))))
     456                          (t (%str-cat "." (%std-filename-quotes type t))))
    449457                        (case version
    450458                          ((nil) "")
     
    550558    (if (and (> end start)
    551559             (eql (schar sstr start) #\~))
    552       (setq sstr (tilde-expand (subseq sstr start end))
     560      (setq sstr (namestring-unquote (tilde-expand (subseq sstr start end)))
    553561            start 0
    554562            end (length sstr)))
     
    719727             ((string= name "**") :wild-inferiors)
    720728             ((string= name "..") :up)
    721              (t (%path-std-quotes name "/:;*" "/:;"))))))
     729             (t (%std-filename-quotes name))))))
    722730
    723731; this will allow creation of garbage pathname "foo:bar;bas:" do we care?
     
    938946        ((string-equal v "newest") :newest)
    939947        ((every #'digit-char-p v) (parse-integer v))
    940         (t (%path-std-quotes v "./:;*" "./:;"))))
     948        (t (%std-filename-quotes v t))))
    941949
    942950
     
    975983  (cond ((or (null name) (eq name :unspecific) (eq name :wild)) name)
    976984        ((equal name "*") :wild)
    977         (t (%path-std-quotes name "/:;*" "/:;"))))
     985        (t (%std-filename-quotes name))))
    978986
    979987;A type is either NIL or a (possibly wildcarded, possibly empty) string.
     
    10161024  (cond ((or (null type) (eq type :unspecific) (eq type :wild)) type)
    10171025        ((equal type "*") :wild)
    1018         (t (%path-std-quotes type "./:;*" "./:;"))))
     1026        (t (%std-filename-quotes type t))))
    10191027
    10201028(defun %std-name-and-type (native)
    10211029  (let* ((end (length native))
    10221030         (pos (position #\. native :from-end t))
    1023          (type (and pos
    1024                     (%path-std-quotes (%substr native (%i+ 1 pos) end)
    1025                                       nil "/:;*")))
     1031         (type (and pos (native-to-filename (%substr native (%i+ 1 pos) end))))
    10261032         (name (unless (eq (or pos end) 0)
    1027                  (%path-std-quotes (if pos (%substr native 0 pos) native)
    1028                                    nil "/:;*"))))
     1033                 (native-to-filename (if pos (%substr native 0 pos) native)))))
    10291034    (values name type)))
    10301035
  • trunk/source/level-1/l1-pathnames.lisp

    r15442 r15837  
    124124        ((not (and (stringp name) (stringp wild)))
    125125         (eq name wild))
    126         (t (%path-str*= name wild))))
     126        (t (%path-str*= (namestring-unquote name) wild))))
    127127
    128128(defun translate-directory (source from to reversible &optional thost)
     
    462462                                     (setq result (%pathname-match-dir1 path (cdr wild)))
    463463                                     (return-from nil))
    464                                     ((%path-str*= pathstr wildstr))))
     464                                    ((%path-str*= (namestring-unquote pathstr) wildstr))))
    465465                         (setq result nil)
    466466                         (return-from nil)))
     
    493493                 (:wild-inferiors (setq pathstr "**")))
    494494               (until (or (not (consp path))
    495                           (%path-str*= pathstr wildstr))
     495                          (%path-str*= (namestring-unquote pathstr) wildstr))
    496496                 (when cons-result (push pathstr match))
    497497                 (setq path (cdr path))
     
    511511
    512512; three times bigger and 3 times slower - does it matter?
    513 (defun %path-str*= (string pattern)
    514   (multiple-value-bind (string s-start s-end) (get-sstring string)
     513;; This assumes pattern is escaped, but pstr is a native string (not escaped)
     514(defun %path-str*= (native-pstr pattern)
     515  (multiple-value-bind (string s-start s-end) (get-sstring native-pstr)
    515516    (multiple-value-bind (pattern p-start p-end) (get-sstring pattern)
    516517      (path-str-sub pattern string p-start s-start p-end s-end))))
  • trunk/source/level-1/l1-sysio.lisp

    r15750 r15837  
    810810                        (let ((truename (native-to-pathname native-truename)))
    811811                          (setq temp-name (gen-file-name truename))
    812                           (unix-rename native-truename (native-untranslated-namestring temp-name))
    813                           (%create-file native-truename))))))
     812                          (unix-rename native-truename (native-translated-namestring temp-name))
     813                          (%create-file truename))))))
    814814                 (return-from open nil)))
    815815             (if (setq filename (if-does-not-exist if-does-not-exist filename))
  • trunk/source/level-1/linux-files.lisp

    r15776 r15837  
    660660)
    661661
    662 ;;; Assume that any quoting's been removed already.
    663662(defun tilde-expand (namestring)
    664663  (let* ((len (length namestring)))
     
    668667      (if (or (= len 1)
    669668              (eql (schar namestring 1) #\/))
    670         (concatenate 'string (get-user-home-dir (getuid)) (if (= len 1) "/" (subseq namestring 1)))
     669        (concatenate 'string (native-to-namestring (get-user-home-dir (getuid))) (if (= len 1) "/" (subseq namestring 1)))
    671670        #+windows-target namestring
    672671        #-windows-target
    673         (let* ((slash-pos (position #\/ namestring))
    674                (user-name (subseq namestring 1 slash-pos))
     672        (let* ((slash-pos (%path-mem "/" namestring))
     673               (user-name (namestring-unquote (subseq namestring 1 slash-pos)))
    675674               (uid (or (get-uid-from-name user-name)
    676675                        (error "Unknown user ~s in namestring ~s" user-name namestring))))
    677           (concatenate 'string (get-user-home-dir uid) (if slash-pos (subseq namestring slash-pos) "/")))))))
     676          (concatenate 'string (native-to-namestring (get-user-home-dir uid)) (if slash-pos (subseq namestring slash-pos) "/")))))))
    678677
    679678
     
    933932(defun get-user-home-dir (userid)
    934933  "Look up and return the defined home directory of the user identified
    935 by uid. This value comes from the OS user database, not from the $HOME
    936 environment variable. Returns NIL if there is no user with the ID uid."
     934by uid, as a native namestring. This value comes from the OS user database, not from the $HOME
     935environment variable, unless *TRUST-PATHS-FROM-ENVIRONMENT* is true.
     936Returns NIL if there is no user with the ID uid."
    937937  #+(or windows-target android-target)
    938938  (declare (ignore userid))
  • trunk/source/lib/pathnames.lisp

    r15778 r15837  
    2727
    2828
     29#-BOOTSTRAPPED ;; get rid of this once bootstrapped
     30(progn
     31(unless (fboundp 'native-to-filename) (fset 'native-to-filename #'identity))
     32(unless (fboundp 'native-to-namestring) (fset 'native-to-namestring #'identity)))
    2933
    3034;-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_
     
    340344    `(let* ((,namestring (native-translated-namestring (make-pathname :device ,device :directory ,dir :defaults nil))))
    341345      (when (%new-directory-p ,namestring ,follow-links ,state)
    342         (let* ((,dirent (%open-dir (native-translated-namestring (make-pathname :device ,device :directory ,dir :defaults nil)))))
     346        (let* ((,dirent (%open-dir ,namestring)))
    343347          (when ,dirent
    344348            (unwind-protect
     
    375379    (mapcar #'cdr (sort (pairs) #'string< :key #'car))))
    376380
    377 (defun %new-directory-p (namestring follow-links result)
     381(defun %new-directory-p (native-namestring follow-links result)
    378382  (multiple-value-bind (win mode size mtime inode uid blocksize rmtime  gid dev)
    379       (%stat namestring (not follow-links))
     383      (%stat native-namestring (not follow-links))
    380384    (declare (ignore size mtime uid blocksize rmtime gid #+windows-target inode #+windows-target dev))
    381385    (when (and win (= (logand mode #$S_IFMT) #$S_IFDIR))
    382386      #+windows-target
    383       (let* ((dirname (namestring (truename (pathname namestring)))))
     387      (let* ((dirname (namestring (truename (native-to-pathname native-namestring)))))
    384388        (unless (member dirname (directory-result-directories-seen result) :test #'string=)
    385389          (push dirname (directory-result-directories-seen result))
     
    424428    (%process-directory-result (%directory "/" dir path '(:absolute) keys (%make-directory-result)))))
    425429
    426 (defun %directory (dir rest path so-far keys result)
    427   (multiple-value-bind (sub-dir wild rest) (%split-dir rest)
    428     (%some-specific dir sub-dir wild rest path so-far keys result)))
    429 
    430 (defun %some-specific (dir sub-dir wild rest path so-far keys result)
     430(defun %directory (native-dir rest path so-far keys result)
     431  (multiple-value-bind (native-sub-dir wild rest) (%split-dir rest)
     432    (%some-specific native-dir native-sub-dir wild rest path so-far keys result)))
     433
     434(defun %some-specific (native-dir native-sub-dir wild rest path so-far keys result)
    431435  (let* ((start 1)
    432          (end (length sub-dir))
    433          (full-dir (if (eq start end) dir (%str-cat dir (%substr sub-dir start end)))))
     436         (end (length native-sub-dir))
     437         (native-full-dir (if (eq start end) native-dir (%str-cat native-dir (%substr native-sub-dir start end)))))
    434438    (while (neq start end)
    435       (let ((pos (position #\/ sub-dir :start start :end end)))
    436         (push (%path-std-quotes (%substr sub-dir start pos) nil "/:;*") so-far)
     439      (let ((pos (position #\/ native-sub-dir :start start :end end)))
     440        (push (native-to-filename (%substr native-sub-dir start pos)) so-far)
    437441        (setq start (%i+ 1 pos))))
    438442    (cond ((null wild)
    439            (%files-in-directory full-dir path so-far keys result))
     443           (%files-in-directory native-full-dir path so-far keys result))
    440444          ((string= wild "**")
    441            (%all-directories full-dir rest path so-far keys result))
    442           (t (%one-wild full-dir wild rest path so-far keys result)))))
     445           (%all-directories native-full-dir rest path so-far keys result))
     446          (t (%one-wild native-full-dir wild rest path so-far keys result)))))
    443447
    444448; for a * or *x*y
    445 (defun %one-wild (dir wild rest path so-far keys result)
     449(defun %one-wild (native-dir wild rest path so-far keys result)
    446450  (let ((device (pathname-device path))
    447451        (all (getf keys :all))
    448452        (follow-links (getf keys :follow-links))
     453        (dir (native-to-namestring native-dir))
    449454        name)
    450455    (with-open-dir (dirent device dir result follow-links)
     
    453458                   (not (string= name "."))
    454459                   (not (string= name ".."))
    455                    (%path-pstr*= wild name)
    456                    (eq (%unix-file-kind (%path-cat device dir name) (not follow-links)) :directory))
    457           (let ((subdir (%path-cat nil dir name))
    458                 (so-far (cons (%path-std-quotes name nil "/;:*") so-far)))
     460                   (%path-str*= name wild)
     461                   (eq (%unix-file-kind (%path-cat device native-dir name) (not follow-links)) :directory))
     462          (let ((native-subdir (%path-cat nil native-dir name))
     463                (so-far (cons (native-to-filename name) so-far)))
    459464            (declare (dynamic-extent so-far))
    460             (%directory (%str-cat subdir "/") rest path so-far keys result)
    461 ))))
     465            (%directory (%str-cat native-subdir "/") rest path so-far keys result)))))
    462466    result))
    463467
    464 (defun %files-in-directory (dir path so-far keys result)
     468(defun %files-in-directory (native-dir path so-far keys result)
    465469  (let ((device (pathname-device path))
    466470        (name (pathname-name path))
     
    473477        (all (getf keys :all))
    474478        (include-emacs-lockfiles (getf keys :include-emacs-lockfiles))
    475         sub dir-list ans)
     479        (dir (native-to-namestring native-dir))
     480        native-sub dir-list ans)
    476481    (if (not (or name type))
    477482      (let (full-path)
    478483        (when (and directories
    479                    (eq (%unix-file-kind (namestring (setq full-path (%cons-pathname (reverse so-far) nil nil nil device)))
     484                   (eq (%unix-file-kind (native-translated-namestring (setq full-path (%cons-pathname (reverse so-far) nil nil nil device)))
    480485                                        (not follow-links))
    481486                       :directory))
     
    485490            (%add-directory-result ans result follow-links))))
    486491      (with-open-dir (dirent (pathname-device path) dir result follow-links)
    487         (while (setq sub (%read-dir dirent))
    488           (when (and (or all (neq (%schar sub 0) #\.))
     492        (while (setq native-sub (%read-dir dirent))
     493          (when (and (or all (neq (%schar native-sub 0) #\.))
    489494                     (or include-emacs-lockfiles
    490                          (< (length sub) 2)
    491                          (not (string= sub ".#" :end1 2)))
    492                      (not (string= sub "."))
    493                      (not (string= sub ".."))
    494                      (%file*= name type sub))
     495                         (< (length native-sub) 2)
     496                         (not (string= native-sub ".#" :end1 2)))
     497                     (not (string= native-sub "."))
     498                     (not (string= native-sub ".."))
     499                     (%file*= name type native-sub))
    495500            (setq ans
    496                   (if (eq (%unix-file-kind (%path-cat device dir sub) (not follow-links)) :directory)
     501                  (if (eq (%unix-file-kind (%path-cat device native-dir native-sub) (not follow-links)) :directory)
    497502                    (when directories
    498                       (let* ((std-sub (%path-std-quotes sub nil "/;:*")))
     503                      (let* ((std-sub (native-to-filename native-sub)))
    499504                        (if directory-pathnames
    500505                          (%cons-pathname (reverse (cons std-sub so-far)) nil nil nil device)
    501506                          (%cons-pathname (or dir-list (setq dir-list (reverse so-far))) std-sub nil nil device))))
    502507                    (when files
    503                       (multiple-value-bind (name type) (%std-name-and-type sub)
     508                      (multiple-value-bind (name type) (%std-name-and-type native-sub)
    504509                        (%cons-pathname (or dir-list (setq dir-list (reverse so-far))) name type nil device)))))
    505510            (when (and ans (or (null test) (funcall test ans)))
     
    507512    result))
    508513
    509 (defun %all-directories (dir rest path so-far keys result)
     514(defun %all-directories (native-dir rest path so-far keys result)
    510515  (let ((do-files nil)
    511516        (do-dirs nil)
     
    517522        (directory-pathnames (getf keys :directory-pathnames))
    518523        (follow-links (getf keys :follow-links))
    519         sub dir-list ans)
     524        sub native-sub dir-list ans)
    520525    ;; First process the case that the ** stands for 0 components
    521     (multiple-value-bind (next-dir next-wild next-rest) (%split-dir rest)
     526    (multiple-value-bind (native-next-dir next-wild next-rest) (%split-dir rest)
    522527      (while (and next-wild ; Check for **/**/ which is the same as **/
    523                   (string= next-dir "/")
     528                  (string= native-next-dir "/")
    524529                  (string= next-wild "**"))
    525530        (setq rest next-rest)
    526         (multiple-value-setq (next-dir next-wild next-rest) (%split-dir rest)))
    527       (cond ((not (string= next-dir "/"))
    528              (%some-specific dir next-dir next-wild next-rest path so-far keys result))
     531        (multiple-value-setq (native-next-dir next-wild next-rest) (%split-dir rest)))
     532      (cond ((not (string= native-next-dir "/"))
     533             (%some-specific native-dir native-next-dir next-wild next-rest path so-far keys result))
    529534            (next-wild
    530              (%one-wild dir next-wild next-rest path so-far keys result))
     535             (%one-wild native-dir next-wild next-rest path so-far keys result))
    531536            ((or name type)
    532537             (when (getf keys :files) (setq do-files t))
     
    538543                 (when (or (null test) (funcall test sub))
    539544                   (%add-directory-result sub result follow-links))))))
     545    (unless (or do-dirs do-files) (return-from %all-directories nil))
    540546    ;; now descend doing %all-dirs on dirs and collecting files & dirs
    541547    ;; if do-x is t
    542     (with-open-dir (dirent device (%path-std-quotes dir nil "*;:") result follow-links)
    543       (while (setq sub (%read-dir dirent))
    544         (when (and (or all (neq (%schar sub 0) #\.))
    545                    (not (string= sub "."))
    546                    (not (string= sub "..")))
    547           (if (eq (%unix-file-kind (%path-cat device dir sub) (not follow-links)) :directory)
    548             (let* ((subfile (%path-cat nil dir sub))
    549                    (std-sub (%path-std-quotes sub nil "/;:*"))
     548    (with-open-dir (dirent device (native-to-namestring native-dir) result follow-links)
     549      (while (setq native-sub (%read-dir dirent))
     550        (when (and (or all (neq (%schar native-sub 0) #\.))
     551                   (not (string= native-sub "."))
     552                   (not (string= native-sub "..")))
     553          (if (eq (%unix-file-kind (%path-cat device native-dir native-sub) (not follow-links)) :directory)
     554            (let* ((native-subfile (%path-cat nil native-dir native-sub))
     555                   (std-sub (native-to-filename native-sub))
    550556                   (so-far (cons std-sub so-far))
    551                    (subdir (%str-cat subfile  "/")))
     557                   (native-subdir (%str-cat native-subfile  "/")))
    552558              (declare (dynamic-extent so-far))
    553               (when (and do-dirs (%file*= name type sub))
     559              (when (and do-dirs (%file*= name type native-sub))
    554560                (setq ans (if directory-pathnames
    555561                            (%cons-pathname (reverse so-far) nil nil nil device)
     
    558564                (when (or (null test) (funcall test ans))
    559565                  (%add-directory-result ans result follow-links)))
    560               (%all-directories subdir rest path so-far keys result))
    561             (when (and do-files (%file*= name type sub))
     566             (%all-directories native-subdir rest path so-far keys result))
     567            (when (and do-files (%file*= name type native-sub))
    562568              (multiple-value-bind (name type) (%std-name-and-type sub)
    563569                (setq ans (%cons-pathname (or dir-list (setq dir-list (reverse so-far))) name type nil device))
     
    567573
    568574(defun %split-dir (dir &aux pos)                 ; dir ends in a "/".
    569   ;"/foo/bar/../x*y/baz/../z*t/"  ->  "/foo/bar/../" "x*y" "/baz/../z*t/"
     575  ;"/foo/bar/../x*y/baz/../z*t/"  ->  "/foo/bar/../" "x*y" "/baz/../z*t/",
     576  ;  where the first value is native, second and third are escaped.
    570577  (if (null (setq pos (%path-mem "*" dir)))
    571     (values dir nil nil)
     578    (if (%path-mem-last-quoted "/" dir)
     579      (signal-file-error $xbadfilenamechar dir #\/)
     580      (values (namestring-unquote dir) nil nil))
    572581    (let (epos (len (length dir)))
    573582      (setq pos (if (setq pos (%path-mem-last "/" dir 0 pos)) (%i+ pos 1) 0)
     
    578587              (%substr dir pos epos)
    579588              (%substr dir epos len)))))
    580 
    581 (defun %path-pstr*= (pattern pstr &optional (p-start 0))
    582   (assert (eq p-start 0))
    583   (%path-str*= pstr pattern))
    584589
    585590(defun %file*= (name-pat type-pat pstr)
     
    597602         (name (unless (eq (or pos end) 0) (if pos (%substr pstr 0 pos) pstr))))
    598603    (and (cond ((or (eq name-pat :unspecific) (null name-pat)) (null name))
    599                (t (%path-pstr*= name-pat (or name ""))))
     604               (t (%path-str*= (or name "") name-pat)))
    600605         (cond ((or (null type-pat) (eq type-pat :unspecific)) (null type))
    601                (t (%path-pstr*= type-pat (or type "")))))))
     606               (t (%path-str*= (or type "") type-pat))))))
    602607
    603608(provide "PATHNAMES")
Note: See TracChangeset for help on using the changeset viewer.