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

[Nikodemus Siivola]

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

Modified Files:
	osicat.lisp test-osicat.lisp test-tools.lisp 
Log Message:
 * More tests.
 * Miscellaneous fixes.
 * Dithering around the MAPDIR and W-D-I interfaces: should they bind
   *d-p-d* or not? Should only one of them do that?

Date: Sun Feb 29 18:28:22 2004
Author: nsiivola

Index: src/osicat.lisp
diff -u src/osicat.lisp:1.14 src/osicat.lisp:1.15
--- src/osicat.lisp:1.14	Sun Feb 29 15:52:37 2004
+++ src/osicat.lisp	Sun Feb 29 18:28:22 2004
@@ -71,16 +71,28 @@
 (defun relative-pathname-p (pathspec)
   (not (eq :absolute (car (pathname-directory pathspec)))))
 
-(defun merge-directories 
-    (pathspec &optional (other *default-pathname-defaults*))
-  (let ((tmp (merge-pathnames pathspec
-			      (make-pathname :name nil :type nil :version nil
-					     :defaults other))))
-    (if (relative-pathname-p tmp)
-	(merge-pathnames tmp (current-directory))
-	tmp)))
+(defun absolute-pathname 
+    (pathspec &optional (default *default-pathname-defaults*))
+    (if (relative-pathname-p pathspec)
+	(let ((tmp (merge-pathnames 
+		    pathspec
+		    (make-pathname :name nil :type nil :version nil
+				   :defaults default))))
+	  (if (relative-pathname-p tmp)
+	      (merge-pathnames tmp (current-directory))
+	      tmp))
+	pathspec))
+
+(defun unmerge-pathnames
+    (pathspec &optional (known *default-pathname-defaults*))
+  (let* ((dir (pathname-directory pathspec))
+	 (mismatch (mismatch dir (pathname-directory known) :test #'equal)))
+    (make-pathname 
+     :directory (when mismatch
+		  `(:relative ,@(subseq dir mismatch)))
+     :defaults pathspec)))
 
-(defun normpath (pathspec &optional merge)
+(defun normpath (pathspec &optional absolute)
   (flet ((fixedname (path)
 	   (let ((name (pathname-name path)))
 	     (cond ((equal ".." name) :up)
@@ -94,22 +106,23 @@
 	     (if (member (car dir) '(:absolute :relative))
 		 dir
 		 (cons :relative dir)))))
-    (let ((path (if (and merge (relative-pathname-p pathspec))
-		    (merge-directories pathspec)
-		    pathspec)))
+    (let ((path (absolute-pathname pathspec)))
       (when (wild-pathname-p path)
 	(error "Pathname is wild: ~S." path))
       (with-cstring (cfile (namestring path))
-	(if (eq :directory (c-file-kind cfile t))
-	    (make-pathname :name nil :type nil
-			   :directory 
-			   (append (fixeddir path)
-				   (remove-if 
-				    #'null
-				    (list (fixedname path)
-					  (fixedtype path))))
-			   :defaults path)
-	    path)))))
+	(let ((abspath (if (eq :directory (c-file-kind cfile t))
+			   (make-pathname :name nil :type nil
+					  :directory 
+					  (append (fixeddir path)
+						  (remove-if 
+						   #'null
+						   (list (fixedname path)
+							 (fixedtype path))))
+					  :defaults path)
+			   path)))
+	  (if absolute
+	      abspath
+	      (unmerge-pathnames abspath)))))))
 
 ;;;; FILE-KIND
 
@@ -191,7 +204,7 @@
     (loop for entry = (next)
 	  while entry
 	  collect (funcall function entry))))
-  
+
 (defun delete-directory (pathspec)
   "function DELETE-DIRECTORY pathspec => T
 


Index: src/test-osicat.lisp
diff -u src/test-osicat.lisp:1.3 src/test-osicat.lisp:1.4
--- src/test-osicat.lisp:1.3	Sun Feb 29 15:52:37 2004
+++ src/test-osicat.lisp	Sun Feb 29 18:28:22 2004
@@ -165,3 +165,46 @@
 		t)
 	(setf (environment-variable :path) old)))
   t)
+
+(deftest mapdir.1
+    (let* ((dir (ensure-directories-exist 
+		 (merge-pathnames "mapdir-test/" *test-dir*)))
+	   (file1 (ensure-file "file1" dir))
+	   (file2 (ensure-file "file2.txt" dir))
+	   (subdir (ensure-directories-exist
+		    (merge-pathnames "subdir/" dir))))
+      (unwind-protect
+	   (remove-if #'null (mapdir #'pathname-name dir))
+	(delete-file file1)
+	(delete-file file2)
+	(delete-directory subdir)
+	(delete-directory dir)))
+  ("file1" "file2"))
+
+(deftest mapdir.2
+    (let* ((dir (ensure-directories-exist 
+		 (merge-pathnames "mapdir-test/" *test-dir*)))
+	   (file1 (ensure-file "file1" dir))
+	   (file2 (ensure-file "file2.txt" dir))
+	   (subdir (ensure-directories-exist
+		    (merge-pathnames "subdir/" dir))))
+      (unwind-protect
+	   (mapdir #'namestring dir)
+	(delete-file file1)
+	(delete-file file2)
+	(delete-directory subdir)
+	(delete-directory dir)))
+  ("file1" "file2.txt" "subdir/"))
+
+(deftest mapdir.3
+    (let* ((dir (ensure-directories-exist 
+		 (merge-pathnames "mapdir-test/" *test-dir*)))
+	   (file (ensure-file "foo" dir)))
+      (unwind-protect
+	   (let ((*default-directory-defaults* (truename "/tmp/")))
+	     (mapdir (lambda (x) 
+		       (pathname-directory (merge-pathnames x))) 
+		     dir))
+	(delete-file file)
+	(delete-directory dir)))
+  (#.(pathname-directory (merge-pathnames "mapdir-test/" *test-dir*))))


Index: src/test-tools.lisp
diff -u src/test-tools.lisp:1.1 src/test-tools.lisp:1.2
--- src/test-tools.lisp:1.1	Sun Feb 29 15:29:35 2004
+++ src/test-tools.lisp	Sun Feb 29 18:28:22 2004
@@ -35,8 +35,8 @@
    (make-pathname :directory 
 		  (pathname-directory #.*compile-file-truename*))))
 
-(defun ensure-file (file)
-  (let ((file (merge-pathnames file *test-dir*)))
+(defun ensure-file (file &optional (dir *test-dir*))
+  (let ((file (merge-pathnames file dir)))
     (or (probe-file file)
 	(with-open-file (f file :direction :output)
 	  (probe-file f)))))