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

[Nikodemus Siivola]

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

Modified Files:
	osicat.lisp 
Log Message:
* Better interface for MAKE-LINK
* Smaller code for WITH-DIRECTORY-ITERATOR
Date: Sun Feb 29 13:36:42 2004
Author: nsiivola

Index: src/osicat.lisp
diff -u src/osicat.lisp:1.11 src/osicat.lisp:1.12
--- src/osicat.lisp:1.11	Sun Feb 29 13:10:41 2004
+++ src/osicat.lisp	Sun Feb 29 13:36:42 2004
@@ -150,30 +150,29 @@
 
 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)
+  (with-unique-names (dp dir cdir one-iter)
     `(let ((,dir (normpath ,pathspec t)))
        (with-c-file (,cdir ,dir :directory t)
 	 (let (,dp)
 	   (unwind-protect
-		(macrolet ((,iterator () 
-			     `(block nil
-				(tagbody :retry
-				   (let ((entry (readdir ,',dp)))
-				     (if (null-pointer-p entry)
-					 nil
-					 (let ((name 
-						(convert-from-cstring
-						 (osicat-dirent-name 
-						  entry))))
-					   (if (member name '("." "..") 
-						       :test #'string=)
-					       (go :retry)
-					       (return (normpath name))))))))))
-		  (setf ,dp (opendir ,cdir))
-		  (when (null-pointer-p ,dp)
-		    (error "Error opening directory ~S." ,dir))
-		  (let ((*default-pathname-defaults* ,dir))
-		    , at body))
+		(labels ((,one-iter ()
+			   (let ((entry (readdir ,dp)))
+			     (if (null-pointer-p entry)
+				 nil
+				 (let ((name 
+					(convert-from-cstring
+					 (osicat-dirent-name entry))))
+				   (if (member name '("." "..") 
+					       :test #'string=)
+				       (,one-iter)
+				       (normpath 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))
+		      , at body)))
 	     (when ,dp
 	       (if (zerop (closedir ,dp))
 		   nil
@@ -291,25 +290,33 @@
 	      (pathname str)))
 	(free-foreign-object buffer)))))
 
-(defun make-link (target link &key hard)
-  "function MAKE-LINK target link &key hard => pathname
+(defun make-link (link &key target hard)
+  "function MAKE-LINK link &key target hard => pathname
 
 Creates link that points to target. Defaults to a symbolic link, but
 giving a non-NIL value to the keyword argument :HARD creates a hard
 link. Returns the pathname of the link. 
 
+Relative targets are resolved against the link. Relative links are 
+resolved against *default-pathname-defaults*.
+
 Signals an error if either target or link is wild, target does not
 exist, or link exists already."
+  (unless target
+    (error "No target given to MAKE-LINK."))
   (let ((old (current-directory)))
     (unwind-protect
-	 (with-c-file (old target)
+	 ;; KLUDGE: We merge against link for hard links only,
+	 ;; since symlink does the right thing once we are in
+	 ;; the correct directory.
+	 (with-c-file (old (if hard (merge-pathnames target link) target))
 	   (with-c-file (new link)
 	     (setf (current-directory) 
 		   (normpath *default-pathname-defaults* t))
 	     (if (zerop (funcall (if hard #'link #'symlink) old new))
 		 (pathname link)
-		 (error "Could not create ~A link ~S -> ~S." 
-			(if hard "hard" "symbolic") link target))))
+		 (error "MAKE-LINK: Could not create ~A link ~S -> ~S." 
+			(if hard "hard" "symbolic") new old))))
       (setf (current-directory) old))))
 
 (define-symbol-macro +permissions+