[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: [Gcl-devel] Fwd: Wild pathnames
From: |
Camm Maguire |
Subject: |
Re: [Gcl-devel] Fwd: Wild pathnames |
Date: |
Mon, 24 Mar 2014 11:35:38 -0400 |
User-agent: |
Gnus/5.13 (Gnus v5.13) Emacs/23.4 (gnu/linux) |
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