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$
  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     #+sbcl
  94     (let ((file-kind-fun
  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)))
  98         path))
  99     #+lispworks (lw:file-directory-p path)
 100     #-(or allegro clisp cmu lispworks sbcl scl)
 101     (probe-file path)))
 102
 103
 104 (defun cwd (&optional dir)
 105   "Change directory and set default pathname"
 106   (cond
 107    ((not (null dir))
 108     (when (and (typep dir 'logical-pathname)
 109                (translate-logical-pathname dir))
 110       (setq dir (translate-logical-pathname dir)))
 111     (when (stringp 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)
 119     #+gcl (si:chdir dir)
 120     #+lispworks (hcl:change-directory dir)
 121     (setq cl:*default-pathname-defaults* dir))
 122    (t
 123     (let ((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 ".")))
 132       (when (stringp dir)
 133         (setq dir (parse-namestring dir)))
 134       dir))))
 135
 136
 137
 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)))
 151
 152
 153 (defun command-line-arguments ()
 154   #+allegro (system:command-line-arguments)
 155   #+sbcl sb-ext:*posix-argv*
 156   )
 157
 158 (defun shell-command-output (cmd &key directory whole)
 159   #+allegro (excl.osi:command-output cmd :directory directory :whole whole)
 160   #+sbcl
 161   (let* ((out (make-array '(0) :element-type 'character :fill-pointer 0
 162                           :adjustable t))
 163          (err (make-array '(0) :element-type 'character :fill-pointer 0
 164                           :adjustable t))
 165         (status
 166          (sb-impl::process-exit-code
 167           (with-output-to-string (out-stream out)
 168             (with-output-to-string (err-stream err)
 169               (sb-ext:run-program
 170                "/bin/sh"
 171                (list  "-c" cmd)
 172                :input nil :output out-stream :error err-stream))))))
 173     (values out err status))
 174   )