Re: [Gcl-devel] Fwd: Wild pathnames

[Camm Maguire]

Greetings, and thanks so much as always for your attention to these
things!

Below are two excerpts from the spec, (the latter from
parse-namestring), which it seems to me indicates that there is no
'right' behavior here.

I've also included below the latest work-in-progress pathname rewrite
attempt I've last worked on in December.  Don't have time to push it
further yet, but if you seen anything and have suggestions, that would
be great.


=============================================================================
19.2.2.2.2 :WILD as a Component Value

If :wild is the value of a pathname component, that component is considered to 
be a wildcard, which matches anything.

A conforming program must be prepared to encounter a value of :wild as the 
value of any pathname component, or as an element of a list that is the
value of the directory component.

When constructing a pathname, a conforming program may use :wild as the value 
of any or all of the directory, name, type, or version component, but
must not use :wild as the value of the host, or device component.

If :wild is used as the value of the directory component in the construction of 
a pathname, the effect is equivalent to specifying the list
(:absolute :wild-inferiors), or the same as (:absolute :wild) in a file system 
that does not support :wild-inferiors.


=============================================================================

Otherwise (if thing is a string), parse-namestring parses the name of a file 
within the substring of thing bounded by start and end.

If thing is a string then the substring of thing bounded by start and end is 
parsed into a pathname as follows:

* If host is a logical host then thing is parsed as a logical pathname 
namestring on the host.
   
* If host is nil and thing is a syntactically valid logical pathname namestring 
containing an explicit host, then it is parsed as a logical
    pathname namestring.
   
* If host is nil, default-pathname is a logical pathname, and thing is a 
syntactically valid logical pathname namestring without an explicit host,
    then it is parsed as a logical pathname namestring on the host that is the 
host component of default-pathname.
   
* Otherwise, the parsing of thing is implementation-defined.
   
=============================================================================
(in-package :si)

(defun asub (s l)
  (labels ((m (s l &optional (b 0))
              (let* ((z (reduce (lambda (y x &aux (f (string-match (car x) s 
b)))
                                  (if (when (>= f 0) (if y (> (car y) f) t)) 
(cons f x) y))
                                l :initial-value nil))
                     (d (pop z)))
                (cond (z (concatenate 'string (subseq s b d) (cdr z) (m s l (1+ 
d))))
                      ((eql b 0) s)
                      ((subseq s b))))))
    (m s l)))

(defconstant +glob-to-regexp+ (list (cons #v"\\?" "(.)")(cons #v"\\*" 
"(.*)")(cons #v"\\." "\\.")))

(defvar *cre* nil)
(defun mregexp (x) (funcall (if *cre* 'compile-regexp 'identity) (concatenate 
'string "^" (asub x +glob-to-regexp+) "$")))

(defun match-list (x)
  (labels ((m (&optional (s 0) (i 1) &aux (b (match-beginning i)))
              (unless (eql b -1)
                (let* ((e (match-end i))(r (m e (1+ i))))
                  (if (>= b s) (cons (subseq x b e) r) r)))))
    (let* ((m (m))
           (m (when m (cons x m))))
      (or m x))))
         
(defconstant +pathname-keys+ 
  (mapcar (lambda (x) (cons x (intern (concatenate 'string "PATHNAME-" 
(string-upcase x)))))
          '(:directory :host :device :name :type :version)))

#.`(defun mlp (p &optional r &aux (p (pathname p)))
     (labels ((mrxp (x) (if (when r (stringp x)) (mregexp x) x)))
       (cons
        (mapcar #'mrxp (pathname-directory p))
        (list 
         ,@(mapcar (lambda (x) `(mrxp (,(cdr x) p))) (cdr +pathname-keys+))))))

(defun pathname-match-p (p w &aux (lp (mlp p)) (lw (mlp w t)) 
(*case-fold-search* t));FIXME
  (labels ((pedd (x y) (if y (pedd1 x y) x))
           (pedd1 (x y) (cond ((eq x y) x)
                              ((eq (car y) :wild-inferiors)
                               (let* ((y (cdr y))(z (last x (length y))))
                                 (cons (list (ldiff x z)) (pedd1 z y))))
                              ((and x y) (cons (peqq (pop x) (pop y)) (pedd1 x 
y)))
                              ((return-from pathname-match-p nil))))
           (peqq (x y) (cond ((or (eq x y) (eq y :wild) (not y)) x)
                             ((when (and (vectorp y) (stringp x)) (eql 
(string-match y x) 0)) (match-list x))
                             ((return-from pathname-match-p nil)))))
    (cons (pedd (pop lp) (pop lw)) (mapcar #'peqq lp lw))))
  
(defun pedd (x y) (if (when y (not (equal y '(:absolute :wild-inferiors)))) 
(pedd1 x y) x))
(defun pedd1 (x y) (cond ((eq x y) x)
                         ((eq (car y) :wild-inferiors)
                          (let* ((y (cdr y))(z (last x (length y))))
                            (cons (list (ldiff x z)) (pedd1 z y))))
                         ((and x y) (cons (peqq (pop x) (pop y)) (pedd1 x y)))
                         ((throw :no-match nil))))
(defun peqq (x y) (cond ((or (eq x y) (eq y :wild) (not y)) x)
                             ((when (and (vectorp y) (stringp x)) (eql 
(string-match y x) 0)) (match-list x))
                             ((throw :no-match nil))))

(defun pathname-match-p (p w &aux (lp (mlp p)) (lw (mlp w t)) 
(*case-fold-search* t));FIXME
  (values (catch :no-match (cons (pedd (pop lp) (pop lw)) (mapcar 'peqq lp 
lw)))))

(defun host-key (k) (if (stringp k) (string-right-trim ":" (string-downcase k)) 
k))

(defun (setf logical-pathname-translations) (v k &aux (k (host-key k)))
  (let ((c (or (assoc k *pathname-logical* :test 'equal) (car (push (cons k 
(list nil)) *pathname-logical*)))))
    (setf (cdr c) 
          (if (listp v) (mapcar (lambda (x) (list (let ((x (parse-namestring 
(car x) (string-upcase k)))) (host-key (c-set-pathname-host x k)) x)
                                                  (parse-namestring (cadr x)))) 
v) v))))

(defun logical-pathname-translations (k)
  (cdr (assoc (host-key k) *pathname-logical* :test 'equal)))

(remprop 'logical-pathname-translations 'si::setf-update-fn)

(defun do-repl (x y)
  (labels ((r (x l &optional (b 0) &aux (f (string-match #v"\\*" x b)))
              (if (eql f -1) (if (eql b 0) x (subseq x b))
                (concatenate 'string (subseq x b f) (or (car l) "") (r x (cdr 
l) (1+ f))))))
    (r y x)))
  
(defun directory-splice (x y)
  (mapcan (lambda (z) 
            (cond ((eq z :wild) (setq x (member-if 'listp x)) 
                   (assert (when x (atom (caar x))))
                   (list (caar x)))
                  ((eq z :wild-inferiors) (setq x (member-if 'listp x))
                   (assert (if x (listp (caar x)) t))
                   (caar x))
                  ((when (stringp z) (>= 0 (string-match #v"\\*" z)))
                   (setq x (member-if 'listp x))
                   (list (do-repl (cdar x) z)))
                  ((list z)))) y))


(defun splice-pathname (lr lt)
  (cons (directory-splice (pop lr) (pop lt))
        (mapcar (lambda (x y) (cond ((if y (eq y :wild) t) (if (listp x) (car 
x) x))
                                    ((stringp y) (do-repl (when (listp x) (cdr 
x)) y))
                                    (y))) lr lt)))

(defun translate-pathname (s fr to &key)
     (apply 'make-pathname
            (mapcan (lambda (x y &aux (x (car x)))
                      (unless (member x '(:host :device))
                        (list x y)))
                    +pathname-keys+ (splice-pathname (pathname-match-p s fr) 
(mlp to)))))

(defun translate-logical-pathname (p &key &aux (p (pathname p)))
  (if (typep p 'logical-pathname)
      (let ((tr (assoc p (logical-pathname-translations (pathname-host p)) 
:test 'pathname-match-p)))
        (unless tr  (error "No translation matches"));(break)
        (apply 'translate-pathname p tr))
    p))

(defconstant +d-type-alist+ (d-type-list))

(defun wreaddir (x y &aux (r (readdir x y))(c (consp r))(s (if c (car r) r)))
  (cond ((or (member s '("." "..") :test 'string-equal)) (wreaddir x y))
        (c (cons s (cdr (assoc (cdr r) +d-type-alist+))))
        (r)))

(defun getdir-loop (x y &aux (z (wreaddir x y)))
  (if z (cons z (getdir-loop x y)) (progn (closedir x) nil)))

(defun getsdir (x &optional (y :unknown) &aux (x (namestring x)))
  (getdir-loop (opendir x) (car (or (rassoc y +d-type-alist+) (rassoc :unknown 
+d-type-alist+)))))

(defun getdir (x &optional (y :unknown) &aux (x (namestring x)))
  (labels ((mp (s tp) (pathname (concatenate 'string x s (if (eq tp :directory) 
"/" "")))))
    (mapcar (lambda (q) (if (consp q) (cons (mp (pop q) q) q) (mp q y)))
            (getsdir x y))))
                 
(defun getrdir (x &aux (r (getdir x :directory)))
  (if r (mapcan 'getrdir r) (list x)))

(defun wjoind (l &aux (w (member :wild l)))
  (if w
      (let ((d (ldiff l w)))
        (mapcan (lambda (x) (wjoind (append d (cons x (cdr w))))) (getsdir 
(make-pathname :directory d) :directory)))
    (when (stat (make-pathname :directory l))
      (list l))))
         
(defun wjoinp (p)
  (mapcar (lambda (x) (make-pathname :directory x)) (wjoind (pathname-directory 
p))))

(defun wjoini (p &aux (l (pathname-directory p))(w (member :wild-inferiors l)))
  (when w
      (remove-if-not (lambda (x) (pathname-match-p x p))
                     (getrdir (make-pathname :directory (ldiff l w))))))

(defun exppathd (p)
  (or (wjoini p) (wjoinp p)))

(defun directory (p &key &aux (p (merge-pathnames (pathname p) (truename 
".")))(l (exppathd p)))
  (if (or (pathname-name p) (pathname-type p) (pathname-version p))
      (let ((pp (make-pathname :name (pathname-name p) :type (pathname-type p) 
:version nil)));FIXME (pathname-version p)
        (mapcan (lambda (x)
                  (mapcan (lambda (y &aux (y (pathname y))) 
                            (when (pathname-match-p y pp) (list 
(merge-pathnames x y)))) (getsdir x :file))) l))
    l))


(defun dir-parse (s &optional (r #v"/") (b 0) (e (length s)) y &aux (f 
(string-match r s b e)))
  (when (>= f 0)
    (let* ((q (subseq s b f))
           (c (or (cdr (assoc q '(("" . :empty)("." . :current)(".." . :up)("*" 
. :wild)("**" . :wild-inferiors)) :test 'string-equal)) q))
           (x (dir-parse s r (if y (1+ f) b) e t)))
      (cond 
       ((not y) (let ((z (char= #\/ (char s f)))) (cons (if (eq c :empty) (if z 
:absolute :relative) (if z :relative :absolute)) x)))
       ((or (eq c :current) (eq c :empty)) x)
       ((eq (car x) :up) (cdr x))
       ((cons c x))))))
  
(defun parse-namestring-string (x host default start end)
  (labels ((match (reg st def &aux (i (string-match reg x st end))) (if (>= i 
0) i def))
           (subs (&rest r &aux (s (apply 'subseq x r))) (when (> (length s) 0) 
(if (string-equal "*" s) :wild s))))
    (let* ((hsi (match #v":" start -1))
           (start (max (1+ hsi) start))
           (lhost (when (>= hsi 0) (subs 0 hsi)))
           (lh (car (member-if 'logical-pathname-translations (list host lhost 
(pathname-host default)))))
           (nsi (match (if lh #v"[^;]*$" #v"[^/]*$") start end))
           (tsi (match #v"\\." nsi end))
           (vsi (if lh (match #v"\\." tsi end) end))
           (path (make-pathname :host (or lhost lh) :device (when lh 
:unspecific) 
                                :directory (dir-parse x (if lh #v";" #v"/") 
start nsi)
                                :name (subs nsi tsi) :type (subs (1+ tsi) vsi)
                                :version (subs (1+ vsi)) :case (if lh :common 
:local))))
      (if lh (logical-pathname path) path))))

(deftype pathname-stream nil #t(and stream (not (or broadcast-stream 
concatenated-stream echo-stream
                                                    two-way-stream 
string-input-stream string-output-stream))))
(deftype pathname-designator nil #t(or string pathname-stream pathname))

(defun parse-namestring (x &optional host (default *default-pathname-defaults*) 
                           &key (start 0) end junk-allowed)
  (declare (optimize (safety 1))(ignore junk-allowed))
  (check-type x pathname-designator)
  (let* ((path (typecase x
                 (stream (parse-namestring-string (setq x (c-stream-object1 x)) 
host default start (setq end (or end (length x)))))
                 (pathname (progn (setq end start) x))
                 (string (parse-namestring-string x host default start (setq 
end (or end (length x)))))))
         (lhost (pathname-host path :case (if (typep path 'logical-pathname) 
:common :local))))
    (unless (if (and host lhost) (equal host lhost) t)
      (error "Host mismatch"))
    (values path end)))

(defun pathname (x)
  (declare (optimize (safety 1)))
  (check-type x pathname-designator)
  (typecase
      x
    (stream (pathname (c-stream-object1 x)))
    (pathname x)
    (string (values (parse-namestring x)))))

(defun sharp-P-reader (stream subchar arg)
  (declare (ignore subchar arg))
  (let ((x (read stream t nil t)))
    (unless *read-suppress* (pathname x))))

(set-dispatch-macro-character #\# #\P 'sharp-P-reader)
(set-dispatch-macro-character #\# #\p 'sharp-P-reader)

(defun logical-pathname (x)
  (declare (optimize (safety 1)))
  (check-type x pathname-designator)
  (let ((x (pathname x)))
    (unless (logical-pathname-translations (pathname-host x)) (error 
'type-error :datum x :expected-type 'logical-pathname))
    (if (typep x 'logical-pathname) x 
      (let ((x (merge-pathnames x)))
        (c-set-pathname-version x nil);FIXME
        (c-set-t-tt x 1)
        x))))

(defun namestring (ps &aux (x (pathname ps)) (c (if (typep x 'logical-pathname) 
:common :local)))
  (declare (optimize (safety 1)))
  (check-type ps pathname-designator)
  (apply 'concatenate 'string 
         (append (let ((x (pathname-host x :case c))) (when x (list x ":")))
                 (mapcan (lambda (x &aux (y (case x
                                              (:absolute "")
                                              (:relative nil)
                                              (:up "..")
                                              (:wild "*")
                                              (:wild-inferiors "**")
                                              (otherwise x))))
                           (when y (list y "/"))) (pathname-directory x :case 
c))
                 (let ((x (pathname-name x :case c))) (when x (list (if (eq 
:wild x) "*" x))))
                 (let ((x (pathname-type x :case c))) (when x (list  "." (if 
(eq :wild x) "*" x)))))))

(defun user-homedir-pathname (&optional host)
  (unless host (truename #p"~/")))


(defun foo (&rest r &key k d)
  (labels ((d (&key ((:k k1) (bar d))) (baz k1)))
          (apply #'d r)))

(defvar *omp* #'make-pathname)

(defun make-pathname (&rest r &key (host nil hp) (device nil dp) (directory nil 
yp) (name nil np) (type nil tp) (version :newest vp);
                           (defaults (make-pathname :host (pathname-host 
*default-pathname-defaults*) :defaults (make-blank-pathname)))
                           (case :local) &aux (p (make-blank-pathname)))
  (declare (optimize (safety 1)))
  (check-type host (or null string))
  (check-type device (or null string (member :unspecific)))
  (check-type directory (or null list (member :unspecific :wild)));fixme string
  (check-type name (or null string (member :unspecific :wild)))
  (check-type type (or null string (member :unspecific :wild)))
  (check-type version (or (integer 0) null (member :unspecific :wild :newest 
:oldest :previous :installed)))
  (check-type case (member :common :local))
  (labels ((case-string (x) (cond ((eq case :local) x)
                                  ((not (find-if 'upper-case-p x)) 
(string-upcase x))
                                  ((not (find-if 'lower-case-p x)) 
(string-downcase x))
                                  (x)))
           (conv (x) (if (stringp x) (case-string x) x)))
    (c-set-pathname-host p (conv (if hp host (pathname-host defaults))))
    (c-set-pathname-device p (conv (if dp device (pathname-device defaults))))
    (c-set-pathname-directory p (identity ;rem-back
                                 (if yp (let ((x (if (listp directory) (mapcar 
#'conv directory) '(:absolute :wild-inferiors))))
;                                         (if (eq (car x) :relative) (append 
(pathname-directory defaults) (cdr x))
                                            x
                                            )
                                   ;)
                                   (pathname-directory defaults))))
    (c-set-pathname-name p (conv (if np name (pathname-name defaults))))
    (c-set-pathname-type p (conv (if tp type (pathname-type defaults))))
    (c-set-pathname-version p (conv version))
    (when (logical-pathname-translations host)
      (c-set-t-tt p 1))
    ;; (let ((z (apply *omp* r)))
    ;;   (unless (equal p z) (print (setq vvv (list r z p))) (break)))
    p))

(defvar *default-pathname-defaults* (make-pathname :defaults 
(make-blank-pathname)))

(defun rem-back (p &aux (op p)(cp (pop p)))
  (cond ((member cp '(:up :back)) (error 'file-error :pathname ""))
        ((member (car p) '(:up :back)) 
         (unless (or (stringp cp) (member cp '(:relative :wild))) (error 
'file-error :pathname ""))
         (rem-back (cdr p)))
        ((not p) op)
        ((let ((r (rem-back p))) (if (eq r p) op (cons cp r))))))

(defun merge-pathnames (p &optional (dp *default-pathname-defaults*) (dv 
:newest) &aux (path (pathname p))(np (make-blank-pathname)))
  (check-type p pathname-designator)
  (c-set-pathname-host np (or (pathname-host path) (pathname-host dp)))
  (c-set-pathname-device np (or (pathname-device path) (pathname-device dp)))
  (c-set-pathname-directory 
   np 
   (let* ((d (pathname-directory path))(dd (pathname-directory dp)))
     (rem-back (if (eq (car d) :relative) (append dd (cdr d)) (or d dd)))))
  (c-set-pathname-name np (or (pathname-name path) (pathname-name dp)))
  (c-set-pathname-type np (or (pathname-type path) (pathname-type dp)))
  (c-set-pathname-version np (or (pathname-version path) (if (pathname-name p) 
dv (pathname-version dp))))
  np)

;(trace make-pathname merge-pathnames)
=============================================================================

Faré <address@hidden> writes:

> Bug report: gcl doesn't correctly process filenames with a "*" in them.
>
> Here is the command I ran, where cl is the latest cl-launch 4:
>
> mkdir -p /tmp/x ; touch "/tmp/x/*" ;
> for i in sbcl ccl clisp cmucl ecl abcl \
>           scl allegro lispworks gcl xcl ; do
>   echo $i ; cl -l $i -iw \
>     '(let ((x (directory "/tmp/x/*"))) (list "'$i'" x (pathname-name
> (first x))))' ;
> done
>
> And the summarized results are:
>
> Escape properly:
> ("sbcl" (#P"/tmp/x/\\*") "*")
> ("ccl" (#P"/tmp/x/\\*") "\\*")
> ("cmucl" (#P"/tmp/x/\\*") "*")
> ("lispworks" (#P"/tmp/x/\\*") "\\*")
> ("scl" (#P"file://localhost/tmp/x/*") "*")
>
> Read badly:
> ("clisp" (#P"/tmp/x/*") :WILD)
> ("ecl" (#P"/tmp/x/*") :WILD)
> ("allegro" (#P"/tmp/x/*") :WILD)
> ("xcl" (#P"/tmp/x/*") :WILD)
>
> Error out:
> abcl
> Fatal condition:
> Bad place for a wild pathname.
>
> gcl:
> Fatal condition:
> Condition in LET [or a callee]: INTERNAL-SIMPLE-FILE-ERROR: File error
> on "/tmp/x/*": File "/tmp/x/*" is wild
>
> —♯ƒ • François-René ÐVB Rideau •Reflection&Cybernethics• http://fare.tunes.org
> No man would listen to you talk if he didn't know it was his turn next.
>                 — Edgar Watson Howe
>
> _______________________________________________
> Gcl-devel mailing list
> address@hidden
> https://lists.gnu.org/mailman/listinfo/gcl-devel

-- 
Camm Maguire                                        address@hidden
==========================================================================
"The earth is but one country, and mankind its citizens."  --  Baha'u'llah