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

[Nikodemus Siivola]

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

Modified Files:
	osicat.lisp packages.lisp 
Log Message:

* New function ABSOLUTE-PATHNAME-P.
* Export pathname utilities.

Date: Sun Apr 25 09:50:58 2004
Author: nsiivola

Index: src/osicat.lisp
diff -u src/osicat.lisp:1.25 src/osicat.lisp:1.26
--- src/osicat.lisp:1.25	Sun Apr 25 09:14:18 2004
+++ src/osicat.lisp	Sun Apr 25 09:50:58 2004
@@ -26,7 +26,7 @@
 					*compile-file-truename*))
       (symbol-name (read f))))
 
-;;;; COMMON SUBROUTINES
+;;;; Common subroutines
 
 (declaim (inline c-file-kind))
 (macrolet ((def ()
@@ -68,10 +68,25 @@
 		   , at forms))
 	       forms)))))
 
+;;;; Hopefully portable pathname manipulations
+
+(defun absolute-pathname-p (pathspec)
+  "function ABSOLUTE-PATHNAME-P pathspec => boolean
+
+Returns T if the pathspec designates an absolute pathname, NIL otherwise."
+  (eq :absolute (car (pathname-directory pathspec))))
+
 (defun relative-pathname-p (pathspec)
-  (not (eq :absolute (car (pathname-directory pathspec)))))
+  "function RELATIVE-PATHNAME-p pathspec => boolean
+
+Returns T if the pathspec designates a relative pathname, NIL otherwise."
+  (not (absolute-pathname-p pathspec)))
 
 (defun absolute-pathname (pathspec &optional (default *default-pathname-defaults*))
+  "function ABSOLUTE-PATHNAME pathspec &optional default => pathname
+
+Returns an absolute pathname corresponding to pathspec by merging it with default,
+and (current-directory) if necessary."
   (if (relative-pathname-p pathspec)
       (let ((tmp (merge-pathnames 
 		  pathspec
@@ -82,10 +97,13 @@
 	    tmp))
       pathspec))
 
-(defun unmerge-pathnames
-    (pathspec &optional (known *default-pathname-defaults*))
+(defun unmerge-pathnames (pathspec &optional (default *default-pathname-defaults*))
+  "function UNMERGE-PATHNAMES pathspec &optional default => pathname
+
+Removes those leading directory components from pathspec that are
+shared with default."
   (let* ((dir (pathname-directory pathspec))
-	 (mismatch (mismatch dir (pathname-directory known) :test #'equal)))
+	 (mismatch (mismatch dir (pathname-directory default) :test #'equal)))
     (make-pathname 
      :directory (when mismatch
 		  `(:relative ,@(subseq dir mismatch)))
@@ -110,7 +128,7 @@
     (with-cstring (cfile (namestring path))
       (c-file-kind cfile nil))))
 
-;;;; DIRECTORY ACCESS
+;;;; Directory access
 
 (defmacro with-directory-iterator ((iterator pathspec) &body body)
   "macro WITH-DIRECTORY-ITERATOR (iterator pathspec) &body forms => value
@@ -208,6 +226,8 @@
 	pathspec
 	(error "Could not delete directory ~S." pathspec))))
 
+;;;; Environment access
+
 (defun environment-variable (name)
   "function ENVIRONMENT-VARIABLE name => string
 function (SETF (ENVIRONMENT-VARIABLE name) value) => value
@@ -272,6 +292,8 @@
 	  do (makunbound-environment-variable var)))
   alist)
 
+;;;; Symbolic and hard links
+
 (defun read-link (pathspec)
   "function READ-LINK pathspec => pathname
 
@@ -323,14 +345,17 @@
 			(if hard "hard" "symbolic") new old))))
       (setf (current-directory) old))))
 
-(define-symbol-macro +permissions+
-    (load-time-value (mapcar (lambda (x)
-			       (cons (intern (symbol-name x) :keyword)
-				     (eval x)))
-			     '(user-read user-write user-exec
-			       group-read group-write group-exec
-			       other-read other-write other-exec
-			       set-user-id set-group-id sticky))))
+;;; File permissions
+
+(defconstant +permissions+ (if (boundp '+permissions+)
+			       +permissions+
+			       (mapcar (lambda (x)
+					 (cons (intern (symbol-name x) :keyword)
+					       (eval x)))
+				       '(user-read user-write user-exec
+					 group-read group-write group-exec
+					 other-read other-write other-exec
+					 set-user-id set-group-id sticky))))
 
 (defun file-permissions (pathspec)
   "function FILE-PERMISSIONS pathspec => list
@@ -366,6 +391,8 @@
 				   :initial-value 0)))
 	perms
 	(error "Could not set file permissions of ~S to ~S." pathspec perms))))
+
+;;;; Current directory
 
 (defun current-directory ()
   "function CURRENT-DIRECTORY => pathname


Index: src/packages.lisp
diff -u src/packages.lisp:1.10 src/packages.lisp:1.11
--- src/packages.lisp:1.10	Sun Apr 25 08:24:12 2004
+++ src/packages.lisp	Sun Apr 25 09:50:58 2004
@@ -59,5 +59,9 @@
    #:user-info
    ;; Version info
    #:*osicat-version*
+   ;; Pathname utilities
+   #:absolute-pathname
+   #:absolute-pathname-p
+   #:relative-pathname-p
+   #:unmerge-pathnames
    ))
-