100 lines
2.8 KiB
Common Lisp
100 lines
2.8 KiB
Common Lisp
|
(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))))
|
||
|
|
|