From: Russell M. <rus...@ya...> - 2008-08-15 13:53:06
|
The code I wrote works ok at least for the case that I posted in my original report. You could just give it a try! I promise it will not erase your hard disk. ;-) I did not intend to fully replace the code in pathnames.lisp, but rather to illustrate one approach to a fuller fix. I am not sure that I understand the overall structure of abcl to replace system level code. -russ ----- Original Message ---- > From: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX > To: Russell McManus <rus...@ya...> > Cc: arm...@li... > Sent: Friday, August 15, 2008 12:46:25 AM > Subject: Re: [j-devel] some pathname wildcard code > > On Thu, Aug 14, 2008 at 7:55 PM, Russell McManus > wrote: > > > > Something like the following might be useful in implementing support > > for wild pathnames in DIRECTORY in abcl. > > > > One issue that I aware of but did not address is that I used > > STRING-EQUAL in a couple of places that might be incorrect on Windows > > and/or OSX. > > Hi! > > I'm about to step onto a flight, but let me take a minute to say > thanks for the contribution! When having a cursory look at > pathnames.lisp, I think to see some of the code that you wrote down > here too. I didn't look at your code long enough though to find out > whether it solves the "wild parents" problem: the fact that the path > we're looking at can't itself contain wildcard patterns (or at least, > that's the bug). > > Bye, > > Erik. > > > -russ > > > > > > (defpackage :abcl-hacks > > (:use :common-lisp :java)) > > > > (in-package :abcl-hacks) > > > > (defun make-name-and-type-matcher (pathname) > > (let ((name1 (pathname-name pathname)) > > (type1 (pathname-type pathname))) > > (flet ((to-string (jstring) > > (jcall (jmethod (jclass "java.lang.String") "toString") jstring)) > > (split-path-and-type (s) > > (let ((dot-pos (position #\. s))) > > (if dot-pos > > (values (subseq s 0 dot-pos) (subseq s (1+ dot-pos))) > > (values s ""))))) > > (cond ((and (eql :wild name1) > > (eql :wild type1)) > > (lambda (jstring) > > (declare (ignore jstring)) > > t)) > > ((eql :wild name1) > > (lambda (jstring) > > (multiple-value-bind (name2 type2) > > (split-path-and-type (to-string jstring)) > > (string-equal type1 type2)))) > > ((eql :wild type1) > > (lambda (jstring) > > (multiple-value-bind (name2 type2) > > (split-path-and-type (to-string jstring)) > > (string-equal name1 name2)))) > > (t > > (lambda (jstring) > > (multiple-value-bind (name2 type2) > > (split-path-and-type (to-string jstring)) > > (and > > (string-equal type1 type2) > > (string-equal name1 name2))))))))) > > > > (defun find-matching-files (pathname) > > (let ((jfile-class (jclass "java.io.File")) > > (name-and-type-matcher (make-name-and-type-matcher pathname)) > > (matches nil)) > > (flet ((make-child (jfile child) > > (jnew (jconstructor jfile-class "java.io.File" "java.lang.String") > > jfile child)) > > (is-dir (jfile) > > (jcall (jmethod jfile-class "isDirectory") jfile)) > > (is-file (jfile) > > (jcall (jmethod jfile-class "isFile") jfile)) > > (children (jfile) > > (jcall (jmethod jfile-class "list") jfile))) > > (labels ((traverse (left-jfile subdirs) > > (cond ((null subdirs) > > (loop for jstring across (children left-jfile) > > when (and (is-file (make-child left-jfile > jstring)) > > (funcall name-and-type-matcher jstring)) > > do (push (make-child left-jfile jstring) > matches))) > > ((eql :wild (car subdirs)) > > (let ((children (loop for jstring across (children > left-jfile) > > collect (make-child left-jfile > jstring)))) > > (mapc (lambda (child) (traverse child (cdr subdirs))) > > (remove-if-not #'is-dir children)))) > > (t (traverse (make-child left-jfile (car subdirs)) > > (cdr subdirs)))))) > > (traverse (jnew (jconstructor jfile-class "java.lang.String") > > (namestring (make-pathname :defaults pathname > > :directory (list :absolute) > > :name nil > > :type nil))) > > (cdr (pathname-directory pathname))) > > (mapcar (lambda (jfile) > > (parse-namestring > > (jcall (jmethod jfile-class "toString") jfile))) > > matches))))) > > > > ------------------------------------------------------------------------- > > This SF.Net email is sponsored by the Moblin Your Move Developer's challenge > > Build the coolest Linux based applications with Moblin SDK & win great prizes > > Grand prize is a trip for two to an Open Source event anywhere in the world > > http://moblin-contest.org/redirect.php?banner_id=100&url=/ > > _______________________________________________ > > armedbear-j-devel mailing list > > arm...@li... > > https://lists.sourceforge.net/lists/listinfo/armedbear-j-devel > > |