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) - ,@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))) + ,@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