+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: vcs-tree -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: kmrcl-excerpt.lisp
+;;;; Purpose: Excerpted functions from KMRCL to support vcs-tree
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Sep 2003
+;;;;
+;;;; $Id: xlunit.asd 7061 2003-09-07 06:34:45Z kevin $
+;;;; *************************************************************************
+
+(in-package vcs-tree)
+
+(defun read-file-to-strings (file)
+ "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)))
+ (nreverse lines))))
+
+
+(defvar *whitespace-chars* '(#\space #\tab #\return #\linefeed))
+
+(defun string-trim-whitespace (str)
+ (string-trim *whitespace-chars* str))
+
+(defmacro aif (test then &optional else)
+ `(let ((it ,test))
+ (if it ,then ,else)))
+
+(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))))))
+
+(defun mklist (obj)
+ "Make into list if atom"
+ (if (listp obj) obj (list obj)))
+
+(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))))
+ (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)))))
+
+
+(defun canonicalize-directory-name (filename)
+ (flet ((un-unspecific (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))))
+ (if new-dir
+ (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)))
+ #+(or cmu scl) (eq :directory (unix:unix-file-kind (namestring 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)))
+
+
+(defun cwd (&optional dir)
+ "Change directory and set default pathname"
+ (cond
+ ((not (null dir))
+ (when (and (typep dir 'logical-pathname)
+ (translate-logical-pathname dir))
+ (setq dir (translate-logical-pathname dir)))
+ (when (stringp dir)
+ (setq dir (parse-namestring dir)))
+ #+allegro (excl:chdir dir)
+ #+clisp (#+lisp=cl ext:cd #-lisp=cl lisp:cd dir)
+ #+(or cmu scl) (setf (ext:default-directory) dir)
+ #+cormanlisp (ccl:set-current-directory dir)
+ #+(and mcl (not openmcl)) (ccl:set-mac-default-directory dir)
+ #+openmcl (ccl:cwd dir)
+ #+gcl (si:chdir dir)
+ #+lispworks (hcl:change-directory 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 ".")))
+ (when (stringp dir)
+ (setq dir (parse-namestring dir)))
+ dir))))
+
+
+
+(defun quit (&optional (code 0))
+ "Function to exit the Lisp implementation. Copied from CLOCC's QUIT function."
+ #+allegro (excl:exit code :quiet t)
+ #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code)
+ #+(or cmu scl) (ext:quit code)
+ #+cormanlisp (win32:exitprocess code)
+ #+gcl (lisp:bye code)
+ #+lispworks (lw:quit :status code)
+ #+lucid (lcl:quit code)
+ #+sbcl (sb-ext:quit :unix-status (typecase code (number code) (null 0) (t 1)))
+ #+mcl (ccl:quit code)
+ #-(or allegro clisp cmu scl cormanlisp gcl lispworks lucid sbcl mcl)
+ (error 'not-implemented :proc (list 'quit code)))
+
+
+(defun command-line-arguments ()
+ #+allegro (system:command-line-arguments)
+ #+sbcl sb-ext:*posix-argv*
+ )
+
+(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))))))
+ (values out err status))
+ )