"Opens a reads a file. Returns the contents as a list of strings"
(let ((lines '()))
(with-open-file (in file :direction :input)
- (let ((eof (gensym)))
- (do ((line (read-line in nil eof)
- (read-line in nil eof)))
- ((eq line eof))
- (push line lines)))
+ (let ((eof (gensym)))
+ (do ((line (read-line in nil eof)
+ (read-line in nil eof)))
+ ((eq line eof))
+ (push line lines)))
(nreverse lines))))
(defun flatten (lis)
(cond ((atom lis) lis)
- ((listp (car lis))
- (append (flatten (car lis)) (flatten (cdr lis))))
- (t (append (list (car lis)) (flatten (cdr lis))))))
+ ((listp (car lis))
+ (append (flatten (car lis)) (flatten (cdr lis))))
+ (t (append (list (car lis)) (flatten (cdr lis))))))
(defun mklist (obj)
"Make into list if atom"
(defun directory-tree (filename)
"Returns a tree of pathnames for sub-directories of a directory"
(let* ((root (canonicalize-directory-name filename))
- (subdirs (loop for path in (directory
- (make-pathname :name :wild
- :type :wild
- :defaults root))
- when (probe-directory path)
- collect (canonicalize-directory-name path))))
+ (subdirs (loop for path in (directory
+ (make-pathname :name :wild
+ :type :wild
+ :defaults root))
+ when (probe-directory path)
+ collect (canonicalize-directory-name path))))
(when (find nil subdirs)
(error "~A" subdirs))
(when (null root)
(error "~A" root))
(if subdirs
- (cons root (mapcar #'directory-tree subdirs))
- (if (probe-directory root)
- (list root)
- (error "root not directory ~A" root)))))
+ (cons root (mapcar #'directory-tree subdirs))
+ (if (probe-directory root)
+ (list root)
+ (error "root not directory ~A" root)))))
(defun canonicalize-directory-name (filename)
(flet ((un-unspecific (value)
- (if (eq value :unspecific) nil value)))
+ (if (eq value :unspecific) nil value)))
(let* ((path (pathname filename))
- (name (un-unspecific (pathname-name path)))
- (type (un-unspecific (pathname-type path)))
- (new-dir
- (cond ((and name type) (list (concatenate 'string name "." type)))
- (name (list name))
- (type (list type))
- (t nil))))
+ (name (un-unspecific (pathname-name path)))
+ (type (un-unspecific (pathname-type path)))
+ (new-dir
+ (cond ((and name type) (list (concatenate 'string name "." type)))
+ (name (list name))
+ (type (list type))
+ (t nil))))
(if new-dir
- (make-pathname
- :directory (append (un-unspecific (pathname-directory path))
- new-dir)
- :name nil :type nil :version nil :defaults path)
- path))))
-
+ (make-pathname
+ :directory (append (un-unspecific (pathname-directory path))
+ new-dir)
+ :name nil :type nil :version nil :defaults path)
+ path))))
+
(defun probe-directory (filename)
(let ((path (canonicalize-directory-name filename)))
#+allegro (excl:probe-directory path)
#+clisp (values
- (ignore-errors
- (#+lisp=cl ext:probe-directory #-lisp=cl lisp:probe-directory
- path)))
+ (ignore-errors
+ (#+lisp=cl ext:probe-directory #-lisp=cl lisp:probe-directory
+ path)))
#+(or cmu scl) (eq :directory (unix:unix-file-kind (namestring path)))
+ #+sbcl
+ (let ((file-kind-fun
+ (or (find-symbol "NATIVE-FILE-KIND" :sb-impl)
+ (find-symbol "UNIX-FILE-KIND" :sb-unix))))
+ (when (eq :directory (funcall file-kind-fun (namestring path)))
+ path))
#+lispworks (lw:file-directory-p path)
- #+sbcl (eq :directory (sb-unix:unix-file-kind (namestring path)))
#-(or allegro clisp cmu lispworks sbcl scl)
(probe-file path)))
(cond
((not (null dir))
(when (and (typep dir 'logical-pathname)
- (translate-logical-pathname dir))
+ (translate-logical-pathname dir))
(setq dir (translate-logical-pathname dir)))
(when (stringp dir)
(setq dir (parse-namestring dir)))
(setq cl:*default-pathname-defaults* dir))
(t
(let ((dir
- #+allegro (excl:current-directory)
- #+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory)
- #+(or cmu scl) (ext:default-directory)
- #+sbcl (sb-unix:posix-getcwd/)
- #+cormanlisp (ccl:get-current-directory)
- #+lispworks (hcl:get-working-directory)
- #+mcl (ccl:mac-default-directory)
- #-(or allegro clisp cmu scl cormanlisp mcl sbcl lispworks) (truename ".")))
+ #+allegro (excl:current-directory)
+ #+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory)
+ #+(or cmu scl) (ext:default-directory)
+ #+sbcl (sb-unix:posix-getcwd/)
+ #+cormanlisp (ccl:get-current-directory)
+ #+lispworks (hcl:get-working-directory)
+ #+mcl (ccl:mac-default-directory)
+ #-(or allegro clisp cmu scl cormanlisp mcl sbcl lispworks) (truename ".")))
(when (stringp dir)
- (setq dir (parse-namestring dir)))
+ (setq dir (parse-namestring dir)))
dir))))
(defun shell-command-output (cmd &key directory whole)
#+allegro (excl.osi:command-output cmd :directory directory :whole whole)
#+sbcl
- (let* ((out (make-array '(0) :element-type 'base-char :fill-pointer 0
- :adjustable t))
- (err (make-array '(0) :element-type 'base-char :fill-pointer 0
- :adjustable t))
- (status
- (sb-impl::process-exit-code
- (with-output-to-string (out-stream out)
- (with-output-to-string (err-stream err)
- (sb-ext:run-program
- "/bin/sh"
- (list "-c" cmd)
- :input nil :output out-stream :error err-stream))))))
+ (let* ((out (make-array '(0) :element-type 'character :fill-pointer 0
+ :adjustable t))
+ (err (make-array '(0) :element-type 'character :fill-pointer 0
+ :adjustable t))
+ (status
+ (sb-impl::process-exit-code
+ (with-output-to-string (out-stream out)
+ (with-output-to-string (err-stream err)
+ (sb-ext:run-program
+ "/bin/sh"
+ (list "-c" cmd)
+ :input nil :output out-stream :error err-stream))))))
(values out err status))
)
projects / vcs-tree.git / blobdiff