1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: vcs-tree -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: kmrcl-excerpt.lisp
6 ;;;; Purpose: Excerpted functions from KMRCL to support vcs-tree
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Sep 2003
11 ;;;; *************************************************************************
15 (defun read-file-to-strings (file)
16 "Opens a reads a file. Returns the contents as a list of strings"
18 (with-open-file (in file :direction :input)
20 (do ((line (read-line in nil eof)
21 (read-line in nil eof)))
27 (defvar *whitespace-chars* '(#\space #\tab #\return #\linefeed))
29 (defun string-trim-whitespace (str)
30 (string-trim *whitespace-chars* str))
32 (defmacro aif (test then &optional else)
37 (cond ((atom lis) lis)
39 (append (flatten (car lis)) (flatten (cdr lis))))
40 (t (append (list (car lis)) (flatten (cdr lis))))))
43 "Make into list if atom"
44 (if (listp obj) obj (list obj)))
46 (defun directory-tree (filename)
47 "Returns a tree of pathnames for sub-directories of a directory"
48 (let* ((root (canonicalize-directory-name filename))
49 (subdirs (loop for path in (directory
50 (make-pathname :name :wild
53 when (probe-directory path)
54 collect (canonicalize-directory-name path))))
55 (when (find nil subdirs)
60 (cons root (mapcar #'directory-tree subdirs))
61 (if (probe-directory root)
63 (error "root not directory ~A" root)))))
66 (defun canonicalize-directory-name (filename)
67 (flet ((un-unspecific (value)
68 (if (eq value :unspecific) nil value)))
69 (let* ((path (pathname filename))
70 (name (un-unspecific (pathname-name path)))
71 (type (un-unspecific (pathname-type path)))
73 (cond ((and name type) (list (concatenate 'string name "." type)))
79 :directory (append (un-unspecific (pathname-directory path))
81 :name nil :type nil :version nil :defaults path)
85 (defun probe-directory (filename)
86 (let ((path (canonicalize-directory-name filename)))
87 #+allegro (excl:probe-directory path)
90 (#+lisp=cl ext:probe-directory #-lisp=cl lisp:probe-directory
92 #+(or cmu scl) (eq :directory (unix:unix-file-kind (namestring path)))
95 (or (find-symbol "NATIVE-FILE-KIND" :sb-impl)
96 (find-symbol "UNIX-FILE-KIND" :sb-unix))))
97 (when (eq :directory (funcall file-kind-fun (namestring path)))
99 #+lispworks (lw:file-directory-p path)
100 #-(or allegro clisp cmu lispworks sbcl scl)
104 (defun cwd (&optional dir)
105 "Change directory and set default pathname"
108 (when (and (typep dir 'logical-pathname)
109 (translate-logical-pathname dir))
110 (setq dir (translate-logical-pathname dir)))
112 (setq dir (parse-namestring dir)))
113 #+allegro (excl:chdir dir)
114 #+clisp (#+lisp=cl ext:cd #-lisp=cl lisp:cd dir)
115 #+(or cmu scl) (setf (ext:default-directory) dir)
116 #+cormanlisp (ccl:set-current-directory dir)
117 #+(and mcl (not openmcl)) (ccl:set-mac-default-directory dir)
118 #+openmcl (ccl:cwd dir)
120 #+lispworks (hcl:change-directory dir)
121 (setq cl:*default-pathname-defaults* dir))
124 #+allegro (excl:current-directory)
125 #+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory)
126 #+(or cmu scl) (ext:default-directory)
127 #+sbcl (sb-unix:posix-getcwd/)
128 #+cormanlisp (ccl:get-current-directory)
129 #+lispworks (hcl:get-working-directory)
130 #+mcl (ccl:mac-default-directory)
131 #-(or allegro clisp cmu scl cormanlisp mcl sbcl lispworks) (truename ".")))
133 (setq dir (parse-namestring dir)))
138 (defun quit (&optional (code 0))
139 "Function to exit the Lisp implementation. Copied from CLOCC's QUIT function."
140 #+allegro (excl:exit code :quiet t)
141 #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code)
142 #+(or cmu scl) (ext:quit code)
143 #+cormanlisp (win32:exitprocess code)
144 #+gcl (lisp:bye code)
145 #+lispworks (lw:quit :status code)
146 #+lucid (lcl:quit code)
147 #+sbcl (sb-ext:quit :unix-status (typecase code (number code) (null 0) (t 1)))
148 #+mcl (ccl:quit code)
149 #-(or allegro clisp cmu scl cormanlisp gcl lispworks lucid sbcl mcl)
150 (error 'not-implemented :proc (list 'quit code)))
153 (defun command-line-arguments ()
154 #+allegro (system:command-line-arguments)
155 #+sbcl sb-ext:*posix-argv*
158 (defun shell-command-output (cmd &key directory whole)
159 #+allegro (excl.osi:command-output cmd :directory directory :whole whole)
161 (let* ((out (make-array '(0) :element-type 'character :fill-pointer 0
163 (err (make-array '(0) :element-type 'character :fill-pointer 0
166 (sb-impl::process-exit-code
167 (with-output-to-string (out-stream out)
168 (with-output-to-string (err-stream err)
172 :input nil :output out-stream :error err-stream))))))
173 (values out err status))