Added Common Lisp Bits & Pieces.

Common-Lisp-Bits-And-Pieces/Chapter-15/barra-filename-library.lisp

@@ -0,0 +1,99 @@
+(defpackage BARRA-FILENAME-PACKAGE
+  (:use common-lisp)
+  (:export 
+   :component-present-p
+   :directory-pathname-p
+   :pathname-as-directory
+   :pathname-as-file
+   :directory-wildcard
+   :file-exists-p
+   :list-directory
+   :walk-directory))
+
+(in-package BARRA-FILENAME-PACKAGE)
+
+(defun component-present-p (value)
+  (and value (not (eql value :unspecified))))
+
+(defun directory-pathname-p (pathname)
+  (and
+   (not (component-present-p (pathname-name pathname)))
+   (not (component-present-p (pathname-type pathname)))))
+
+(defun pathname-as-directory (path)
+  (let ((pathname (pathname path)))
+    (if
+     (directory-pathname-p pathname)
+     pathname
+     (make-pathname
+      :host (pathname-host pathname)
+      :device (pathname-device pathname)
+      :directory (append (or (pathname-directory pathname) (file-namestring pathname)) 
+			 (list (file-namestring pathname)))
+      :name nil
+      :type nil
+      :defaults pathname))))
+
+(defun directory-wildcard (dirname)
+  (make-pathname
+   :name :wild
+   :type #-clisp :wild #+clisp nil
+   :defaults (pathname-as-directory dirname)))
+
+(defun list-directory (dirname)
+  (when (wild-pathname-p dirname)
+    (error "Can only list concrete directory names."))
+  (directory (directory-wildcard dirname)))
+
+(defun file-exists-p (pathname)
+  #+(or sbcl lispworks openmcl)
+  (probe-file pathname)
+
+  #+(or allegro cmu)
+  (or (probe-file (pathname-as-directory pathname))
+      (probe-file pathname))
+
+  #+clisp
+  (or (ignore-errors
+       (probe-file (pathname-as-file pathname)))
+      (ignore-errors
+       (let ((directory-form (pathname-as-directory pathname)))
+         (when (ext:probe-directory directory-form)
+           directory-form))))
+
+  #-(or sbcl cmu lispworks openmcl allegro clisp)
+  (error "list-directory not implemented"))
+
+#+clisp
+(defun clisp-subdirectories-wildcard (wildcard)
+  (make-pathname
+   :directory (append (pathname-directory wildcard) (list :wild))
+   :name nil
+   :type nil
+   :defaults wildcard))
+
+(defun pathname-as-file (name)
+  (let ((pathname (pathname name)))
+    (when (wild-pathname-p pathname)
+      (error "Can't reliably convert wild pathnames."))
+    (if (directory-pathname-p name)
+	(let* ((directory (pathname-directory pathname))
+               (name-and-type (pathname (first (last directory)))))
+          (make-pathname
+           :directory (butlast directory)
+           :name (pathname-name name-and-type)
+           :type (pathname-type name-and-type)
+           :defaults pathname))
+	pathname)))
+
+(defun walk-directory (dirname fn &key directories (test (constantly t)))
+  (labels
+      ((walk (name)
+         (cond
+           ((directory-pathname-p name)
+            (when (and directories (funcall test name))
+              (funcall fn name))
+            (dolist (x (list-directory name)) (walk x)))
+           ((funcall test name) (funcall fn name)))))
+    (walk (pathname-as-directory dirname))))
+