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)))))