;;;; -*- 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$
;;;; *************************************************************************

(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)))
    #+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)
    #-(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 '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))
  )