kmrcl-excerpt.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: vcs-tree -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   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
   9 ;;;;
  10 ;;;; $Id: xlunit.asd 7061 2003-09-07 06:34:45Z kevin $
  11 ;;;; *************************************************************************
  12
  13 (in-package vcs-tree)
  14
  15 (defun read-file-to-strings (file)
  16   "Opens a reads a file. Returns the contents as a list of strings"
  17   (let ((lines '()))
  18     (with-open-file (in file :direction :input)
  19       (let ((eof (gensym)))
  20         (do ((line (read-line in nil eof)
  21                    (read-line in nil eof)))
  22             ((eq line eof))
  23           (push line lines)))
  24       (nreverse lines))))
  25
  26
  27 (defvar *whitespace-chars* '(#\space #\tab #\return #\linefeed))
  28
  29 (defun string-trim-whitespace (str)
  30   (string-trim *whitespace-chars* str))
  31
  32 (defmacro aif (test then &optional else)
  33   `(let ((it ,test))
  34      (if it ,then ,else)))
  35
  36 (defun flatten (lis)
  37   (cond ((atom lis) lis)
  38         ((listp (car lis))
  39          (append (flatten (car lis)) (flatten (cdr lis))))
  40         (t (append (list (car lis)) (flatten (cdr lis))))))
  41
  42 (defun mklist (obj)
  43   "Make into list if atom"
  44   (if (listp obj) obj (list obj)))
  45
  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
  51                                                     :type :wild
  52                                                     :defaults root))
  53                         when (probe-directory path)
  54                         collect (canonicalize-directory-name path))))
  55     (when (find nil subdirs)
  56       (error "~A" subdirs))
  57     (when (null root)
  58       (error "~A" root))
  59     (if subdirs
  60         (cons root (mapcar #'directory-tree subdirs))
  61         (if (probe-directory root)
  62             (list root)
  63             (error "root not directory ~A" root)))))
  64
  65
  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)))
  72            (new-dir
  73             (cond ((and name type) (list (concatenate 'string name "." type)))
  74                   (name (list name))
  75                   (type (list type))
  76                   (t nil))))
  77       (if new-dir
  78           (make-pathname
  79            :directory (append (un-unspecific (pathname-directory path))
  80                               new-dir)
  81                     :name nil :type nil :version nil :defaults path)
  82           path))))
  83
  84
  85 (defun probe-directory (filename)
  86   (let ((path (canonicalize-directory-name filename)))
  87     #+allegro (excl:probe-directory path)
  88     #+clisp (values
  89              (ignore-errors
  90                (#+lisp=cl ext:probe-directory #-lisp=cl lisp:probe-directory
  91                           path)))
  92     #+(or cmu scl) (eq :directory (unix:unix-file-kind (namestring path)))
  93     #+lispworks (lw:file-directory-p path)
  94     #+sbcl (eq :directory (sb-unix:unix-file-kind (namestring path)))
  95     #-(or allegro clisp cmu lispworks sbcl scl)
  96     (probe-file path)))
  97
  98
  99 (defun cwd (&optional dir)
 100   "Change directory and set default pathname"
 101   (cond
 102    ((not (null dir))
 103     (when (and (typep dir 'logical-pathname)
 104                (translate-logical-pathname dir))
 105       (setq dir (translate-logical-pathname dir)))
 106     (when (stringp dir)
 107       (setq dir (parse-namestring dir)))
 108     #+allegro (excl:chdir dir)
 109     #+clisp (#+lisp=cl ext:cd #-lisp=cl lisp:cd dir)
 110     #+(or cmu scl) (setf (ext:default-directory) dir)
 111     #+cormanlisp (ccl:set-current-directory dir)
 112     #+(and mcl (not openmcl)) (ccl:set-mac-default-directory dir)
 113     #+openmcl (ccl:cwd dir)
 114     #+gcl (si:chdir dir)
 115     #+lispworks (hcl:change-directory dir)
 116     (setq cl:*default-pathname-defaults* dir))
 117    (t
 118     (let ((dir
 119            #+allegro (excl:current-directory)
 120            #+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory)
 121            #+(or cmu scl) (ext:default-directory)
 122            #+sbcl (sb-unix:posix-getcwd/)
 123            #+cormanlisp (ccl:get-current-directory)
 124            #+lispworks (hcl:get-working-directory)
 125            #+mcl (ccl:mac-default-directory)
 126            #-(or allegro clisp cmu scl cormanlisp mcl sbcl lispworks) (truename ".")))
 127       (when (stringp dir)
 128         (setq dir (parse-namestring dir)))
 129       dir))))
 130
 131
 132
 133 (defun quit (&optional (code 0))
 134   "Function to exit the Lisp implementation. Copied from CLOCC's QUIT function."
 135     #+allegro (excl:exit code :quiet t)
 136     #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code)
 137     #+(or cmu scl) (ext:quit code)
 138     #+cormanlisp (win32:exitprocess code)
 139     #+gcl (lisp:bye code)
 140     #+lispworks (lw:quit :status code)
 141     #+lucid (lcl:quit code)
 142     #+sbcl (sb-ext:quit :unix-status (typecase code (number code) (null 0) (t 1)))
 143     #+mcl (ccl:quit code)
 144     #-(or allegro clisp cmu scl cormanlisp gcl lispworks lucid sbcl mcl)
 145     (error 'not-implemented :proc (list 'quit code)))
 146
 147
 148 (defun command-line-arguments ()
 149   #+allegro (system:command-line-arguments)
 150   #+sbcl sb-ext:*posix-argv*
 151   )
 152
 153 (defun shell-command-output (cmd &key directory whole)
 154   #+allegro (excl.osi:command-output cmd :directory directory :whole whole)
 155   #+sbcl
 156   (let* ((out (make-array '(0) :element-type 'base-char :fill-pointer 0
 157                           :adjustable t))
 158          (err (make-array '(0) :element-type 'base-char :fill-pointer 0
 159                           :adjustable t))
 160         (status
 161          (sb-impl::process-exit-code
 162           (with-output-to-string (out-stream out)
 163             (with-output-to-string (err-stream err)
 164               (sb-ext:run-program
 165                "/bin/sh"
 166                (list  "-c" cmd)
 167                :input nil :output out-stream :error err-stream))))))
 168     (values out err status))
 169   )