[osicat-cvs] CVS update: src/osicat.lisp

[Nikodemus Siivola]

Update of /project/osicat/cvsroot/src
In directory common-lisp.net:/tmp/cvs-serv17487

Modified Files:
	osicat.lisp 
Log Message:
* Rewrote WITH-DIRECTORY-ITERATOR in CALL-WITH... style.
Date: Sun Apr 25 08:11:32 2004
Author: nsiivola

Index: src/osicat.lisp
diff -u src/osicat.lisp:1.22 src/osicat.lisp:1.23
--- src/osicat.lisp:1.22	Sun Apr 25 07:16:25 2004
+++ src/osicat.lisp	Sun Apr 25 08:11:31 2004
@@ -142,52 +142,58 @@
 entries, one by one. Both files and directories are returned, except
 '.' and '..'. The order of entries is not guaranteed. The entries are
 returned as relative pathnames against the designated
-directory. Entries that are symbolic links are not resolved. Once all
-entries have been returned, further invocations of (iterator) will all
-return NIL.
+directory. Entries that are symbolic links are not resolved, but links
+that point to directories are interpreted as directory
+designators. Once all entries have been returned, further invocations
+of (iterator) will all return NIL.
 
 The value returned is the value of the last form evaluated in
 body. Signals an error if pathspec is wild or does not designate a directory."
-  (with-unique-names (dp dir cdir old-dir one-iter)
-    `(let ((,dir (normpath ,pathspec t))
-	   (,old-dir (current-directory)))
-       (with-c-file (,cdir ,dir :directory t)
-	 (let (,dp)
-	   (unwind-protect
-		(labels ((,one-iter ()
-			   (let ((entry (readdir ,dp)))
-			     (if (null-pointer-p entry)
-				 nil
-				 (let* ((cname (osicat-dirent-name entry))
-					(name (convert-from-cstring cname)))
-				   (declare (type simple-string name))
-				   (cond 
-				     ((member name '("." "..") :test #'string=)
-				      (,one-iter))
-				     ((eq :directory (c-file-kind cname t))
-				      (make-pathname
-				       :directory `(:relative ,name)))
-				     (t
-				      (let ((dotpos (position #\. name :from-end t)))
-					(if (and dotpos (plusp dotpos))
-					    (make-pathname
-					     :name (subseq name 0 dotpos)
-					     :type (subseq name (1+ dotpos)))
-					    (make-pathname
-					     :name name))))))))))
-		  (macrolet ((,iterator () 
-			       `(,',one-iter)))
-		    (setf ,dp (opendir ,cdir))
-		    (when (null-pointer-p ,dp)
-		      (error "Error opening directory ~S." ,dir))
-		    (let ((*default-pathname-defaults* ,dir))
-		      (setf (current-directory) ,dir)
-		      , at body)))
-	     (when ,dp
-	       (if (zerop (closedir ,dp))
-		   nil
-		   (error "Error closing directory ~S." ,dir)))
-	     (setf (current-directory) ,old-dir)))))))
+  (with-unique-names (one-iter)
+    `(call-with-directory-iterator ,pathspec
+      (lambda (,one-iter)
+	(macrolet ((,iterator () 
+		     `(funcall ,',one-iter)))
+	  , at body)))))
+
+(defun call-with-directory-iterator (pathspec fun)
+  (let ((dir (normpath pathspec t))
+	(old-dir (current-directory)))
+    (with-c-file (cdir dir :directory t)
+      (let (dp)
+	(unwind-protect
+	     (labels ((one-iter ()
+			(let ((entry (readdir dp)))
+			  (if (null-pointer-p entry)
+			      nil
+			      (let* ((cname (osicat-dirent-name entry))
+				     (name (convert-from-cstring cname)))
+				(declare (type simple-string name))
+				(cond 
+				  ((member name '("." "..") :test #'string=)
+				      (one-iter))
+				  ((eq :directory (c-file-kind cname t))
+				   (make-pathname
+				    :directory `(:relative ,name)))
+				  (t
+				   (let ((dotpos (position #\. name :from-end t)))
+				     (if (and dotpos (plusp dotpos))
+					 (make-pathname
+					  :name (subseq name 0 dotpos)
+					  :type (subseq name (1+ dotpos)))
+					 (make-pathname
+					  :name name))))))))))
+	       (setf dp (opendir cdir))
+	       (when (null-pointer-p dp)
+		 (error "Error opening directory ~S." dir))
+	       (let ((*default-pathname-defaults* dir))
+		 (setf (current-directory) dir)
+		 (funcall fun #'one-iter)))
+	  (when dp
+	    (if (zerop (closedir dp))
+		nil
+		(error "Error closing directory ~S." dir)))
+	  (setf (current-directory) old-dir))))))
 
 (defun mapdir (function pathspec)
   "function MAPDIR function pathspec => list