2 ;;; filesystem.cl -- various lisp utilities that make my life easier
4 ;;; Author: Cyrus Harmon <ch-lisp@bobobeach.com>
10 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
15 (ccl::current-directory-name
))
17 (defun component-present-p (value)
18 (and value
(not (eql value
:unspecific
))))
20 ;;; I don't remember where I got this from. Probably from KMR somewhere
22 (defun pathname-as-directory (pathname)
23 "Return a pathname reperesenting the given pathname in `directory
24 form', i.e. with all the name elements in the directory component and
25 NIL in the name and type components. Can not be used on wild
26 pathnames. Returns its argument if name and type are both nil or
28 (setf pathname
(pathname pathname
))
29 (when (wild-pathname-p pathname
)
30 (error "Can't reliably convert wild pathnames to directory names."))
32 ((or (component-present-p (pathname-name pathname
))
33 (component-present-p (pathname-type pathname
)))
35 :directory
(append (pathname-directory pathname
) (list
36 (file-namestring pathname
)))
42 ;;; I don't remember where I got this from. Probably from KMR somewhere
44 (defun list-directory (dirname)
45 "Return a list of the contents of the directory named by dirname.
46 Names of subdirectories will be returned in `directory normal form'.
47 Unlike CL:DIRECTORY, LIST-DIRECTORY does not accept wildcard
48 pathnames; `dirname' should simply be a pathname that names a
49 directory. It can be in either file or directory form."
50 (let ((wildcard (make-pathname :name
:wild
52 :defaults
(pathname-as-directory
55 (declare (ignorable wildcard
))
57 ;; OpenMCl by default doesn't return subdirectories at all. But
58 ;; when prodded to do so with the special argument :directories,
59 ;; it returns them in directory form.
60 (directory wildcard
:directories t
)
61 #-openmcl
(directory wildcard
)))
63 (defun ls (&optional
(dirname ""))
64 (list-directory dirname
))
66 (defmacro with-open-file-preserving-case
(&rest args
)
67 `(let ((*readtable
* (copy-readtable)))
68 (setf (readtable-case *readtable
*) :preserve
)
69 (with-open-file ,@args
)))
71 (defparameter *tmp-file-directory
* (make-pathname :directory
'(:absolute
"tmp")))
73 (defun tmp-file-name (&key
(prefix "tmp."))
74 (concatenate 'string prefix
(format nil
"~8,'0',X" (random #xffffffff
))))
76 (defun tmp-file (&key
(name (tmp-file-name)))
77 (merge-pathnames name
*tmp-file-directory
*))
79 (defun remove-keyword-args (list &rest remove
)
80 (loop for x on list by
#'cddr when
(not (member (car x
) remove
)) append
(list (car x
) (cadr x
))))
82 (defmacro with-temporary-file
((path stream
&rest options
&key
(delete t
) &allow-other-keys
) &body body
)
83 `(let ((,path
(tmp-file)))
85 (with-open-file (,stream
,path
,@(remove-keyword-args options
:delete
))
87 ,(when delete
`(delete-file ,path
)))))
89 ;;; from antifuchs on #lisp via paste.lisp.org
90 ;;; http://paste.lisp.org/display/9527
91 (defmacro with-current-directory
(dir &body body
)
92 `(unwind-protect (progn
95 (let ((*default-pathname-defaults
* ,dir
))
97 #+sbcl
(sb-posix:chdir
*default-pathname-defaults
*)))
99 (defmacro run-program
(&rest args
)
100 #+sbcl
`(sb-ext::run-program
,@args
))
102 (defmacro run-program-asynchronously
(&rest args
)
103 #+sbcl
`(sb-ext::run-program
,@args
:wait nil
))
106 (defun app-open (&rest args
)
107 #+darwin
(run-program "/usr/bin/open" (mapcar #'(lambda (x) (if (pathnamep x
) (unix-name x
) x
)) args
)))
109 (defun safari-open (&rest args
)
111 (apply #'app-open
(list* "-a" "/Applications/Safari.app"
112 (mapcar #'(lambda (x) (if (pathnamep x
) (unix-name x
) x
)) args
))))
114 (defun firefox-open (&rest args
)
116 (apply #'app-open
(list* "-a" "/Users/sly/Applications/Camino.app"
117 (mapcar #'(lambda (x) (if (pathnamep x
) (unix-name x
) x
)) args
))))
120 (defparameter *pdf-viewer
*
122 #+darwin
"Preview.app")
124 (defparameter *pdf-viewer-path
*
125 (let ((found (sb-ext:find-executable-in-search-path
129 #+darwin
"/Applications/Preview.app"
130 #-darwin
"/usr/bin/kpdf"))
133 (defun pdf-open (&rest args
)
135 (apply #'app-open
"-a" *pdf-viewer-path
* (mapcar #'unix-name args
))
137 (run-program-asynchronously *pdf-viewer-path
*
138 (mapcar #'(lambda (x)
139 (if (pathnamep x
) (unix-name x
) x
)) args
))
142 (defparameter *html-viewer
*
144 #+darwin
"Safari.app")
146 (defparameter *html-viewer-path
*
147 (let ((found (sb-ext:find-executable-in-search-path
151 #+darwin
"/Applications/Safari.app"
152 #-darwin
"/usr/bin/konqueror"))
155 (defun html-open (&rest args
)
156 (run-program-asynchronously *html-viewer-path
*
157 (mapcar #'(lambda (x)
158 (if (pathnamep x
) (unix-name x
) x
)) args
)))
160 (defmacro process-output-stream
(&rest args
)
161 #+sbcl
`(sb-ext::process-output
,@args
))
163 (defun prefix (seq suffix
)
164 "Removes the prefix of seq that occurs before suffix. Return
165 values are the prefix and the position at which the suffix
166 begins in the original sequence, or the original sequence and
167 NIL if the suffix is not in seq"
168 (let ((pos (search suffix seq
)))
170 (values (subseq seq
0 pos
) pos
)
173 (defun subdirectories (path)
176 (make-pathname :name
:wild
:type nil
:defaults path
))
177 when
(string-equal (file-namestring d
) "") collect d
))
179 (defun unix-name (pathname)
182 (logical-pathname (translate-logical-pathname pathname
))
185 (defun map-files-in-directory (function
186 destination-directory
193 :type
(if file-type file-type
:wild
))
194 destination-directory
))))
196 (defun pathname-lessp (p1 p2
)
197 (string-lessp (pathname-name p1
)