external/ch-util/src/filesystem.cl

   1 ;;;
   2 ;;; filesystem.cl -- various lisp utilities that make my life easier
   3 ;;;
   4 ;;; Author: Cyrus Harmon <ch-lisp@bobobeach.com>
   5 ;;;
   6
   7 (in-package :ch-util)
   8
   9 #+sbcl
  10 (eval-when (:compile-toplevel :load-toplevel :execute)
  11   (require :sb-posix))
  12
  13 #+openmcl
  14 (defun pwd ()
  15   (ccl::current-directory-name))
  16
  17 (defun component-present-p (value)
  18   (and value (not (eql value :unspecific))))
  19
  20 ;;; I don't remember where I got this from. Probably from KMR somewhere
  21 ;;; along the line...
  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
  27   :unspecific."
  28   (setf pathname (pathname pathname))
  29   (when (wild-pathname-p pathname)
  30     (error "Can't reliably convert wild pathnames to directory names."))
  31   (cond
  32    ((or (component-present-p (pathname-name pathname))
  33         (component-present-p (pathname-type pathname)))
  34     (make-pathname
  35      :directory (append (pathname-directory pathname) (list
  36                                                        (file-namestring pathname)))
  37      :name      nil
  38      :type      nil
  39      :defaults pathname))
  40    (t pathname)))
  41
  42 ;;; I don't remember where I got this from. Probably from KMR somewhere
  43 ;;; along the line...
  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
  51                                  :type :wild
  52                                  :defaults (pathname-as-directory
  53                                             dirname))))
  54
  55     (declare (ignorable wildcard))
  56     #+openmcl
  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)))
  62
  63 (defun ls (&optional (dirname ""))
  64   (list-directory dirname))
  65
  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)))
  70
  71 (defparameter *tmp-file-directory* (make-pathname :directory '(:absolute "tmp")))
  72
  73 (defun tmp-file-name (&key (prefix "tmp."))
  74   (concatenate 'string prefix (format nil "~8,'0',X" (random #xffffffff))))
  75
  76 (defun tmp-file (&key (name (tmp-file-name)))
  77   (merge-pathnames name *tmp-file-directory*))
  78
  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))))
  81
  82 (defmacro with-temporary-file ((path stream &rest options &key (delete t) &allow-other-keys) &body body)
  83   `(let ((,path (tmp-file)))
  84      (prog1
  85          (with-open-file (,stream ,path ,@(remove-keyword-args options :delete))
  86            ,@body)
  87        ,(when delete `(delete-file ,path)))))
  88
  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
  93                      #+sbcl
  94                      (sb-posix:chdir ,dir)
  95                      (let ((*default-pathname-defaults* ,dir))
  96                        ,@body))
  97      #+sbcl (sb-posix:chdir *default-pathname-defaults*)))
  98
  99 (defmacro run-program (&rest args)
 100   #+sbcl `(sb-ext::run-program ,@args))
 101
 102 (defmacro run-program-asynchronously (&rest args)
 103   #+sbcl `(sb-ext::run-program ,@args :wait nil))
 104
 105
 106 (defun app-open (&rest args)
 107   #+darwin (run-program "/usr/bin/open" (mapcar #'(lambda (x) (if (pathnamep x) (unix-name x) x)) args)))
 108
 109 (defun safari-open (&rest args)
 110   #+darwin
 111   (apply #'app-open (list* "-a" "/Applications/Safari.app"
 112                            (mapcar #'(lambda (x) (if (pathnamep x) (unix-name x) x)) args))))
 113
 114 (defun firefox-open (&rest args)
 115   #+darwin
 116   (apply #'app-open (list* "-a" "/Users/sly/Applications/Camino.app"
 117                            (mapcar #'(lambda (x) (if (pathnamep x) (unix-name x) x)) args))))
 118
 119
 120 (defparameter *pdf-viewer*
 121   #+linux "kpdf"
 122   #+darwin "Preview.app")
 123
 124 (defparameter *pdf-viewer-path*
 125   (let ((found (sb-ext:find-executable-in-search-path
 126                 *pdf-viewer*)))
 127     (unless found
 128       (setf found
 129             #+darwin "/Applications/Preview.app"
 130             #-darwin "/usr/bin/kpdf"))
 131     found))
 132
 133 (defun pdf-open (&rest args)
 134   #+darwin
 135   (apply #'app-open "-a" *pdf-viewer-path* (mapcar #'unix-name args))
 136   #-darwin
 137   (run-program-asynchronously *pdf-viewer-path*
 138                (mapcar #'(lambda (x)
 139                            (if (pathnamep x) (unix-name x) x)) args))
 140   )
 141
 142 (defparameter *html-viewer*
 143   #+linux "konqueror"
 144   #+darwin "Safari.app")
 145
 146 (defparameter *html-viewer-path*
 147   (let ((found (sb-ext:find-executable-in-search-path
 148                 *html-viewer*)))
 149     (unless found
 150       (setf found
 151             #+darwin "/Applications/Safari.app"
 152             #-darwin "/usr/bin/konqueror"))
 153     found))
 154
 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)))
 159
 160 (defmacro process-output-stream (&rest args)
 161   #+sbcl `(sb-ext::process-output ,@args))
 162
 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)))
 169     (if pos
 170         (values (subseq seq 0 pos) pos)
 171         (values seq nil))))
 172
 173 (defun subdirectories (path)
 174   (loop for d in
 175        (directory
 176         (make-pathname :name :wild :type nil :defaults path))
 177      when (string-equal (file-namestring d) "") collect d))
 178
 179 (defun unix-name (pathname)
 180   (namestring
 181    (typecase pathname
 182      (logical-pathname (translate-logical-pathname pathname))
 183      (t pathname))))
 184
 185 (defun map-files-in-directory (function
 186                                destination-directory
 187                                &key file-type)
 188   (mapcar function
 189           (directory
 190            (merge-pathnames
 191             (make-pathname
 192              :name :wild
 193              :type (if file-type file-type :wild))
 194             destination-directory))))
 195
 196 (defun pathname-lessp (p1 p2)
 197   (string-lessp (pathname-name p1)
 198                 (pathname-name p2)))
 199