r10070: fix keyword name

[kmrcl.git] / impl.lisp

diff --git a/impl.lisp b/impl.lisp
index c6aa65df7de8fd5b9ab7d5004e9dacae418450fb..7efec3d79b1cfd33eef5163ba24bdf38e4f12ca3 100644 (file)
--- a/impl.lisp
+++ b/impl.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Sep 2003
 ;;;;
-;;;; $Id: io.lisp 7795 2003-09-10 05:44:47Z kevin $
+;;;; $Id$
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -37,19 +37,29 @@
          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 probe-directory (filename &key (error-if-does-not-exist nil))
+  (let* ((path (canonicalize-directory-name filename))
+        (probe
+         #+allegro (excl:probe-directory path)
+         #+clisp (values
+                  (ignore-errors
+                    (#+lisp=cl ext:probe-directory
+                               #-lisp=cl lisp:probe-directory
+                               path)))
+         #+(or cmu scl) (when (eq :directory
+                                  (unix:unix-file-kind (namestring path)))
+                          path)
+         #+lispworks (when (lw:file-directory-p path)
+                       path)
+         #+sbcl (when (eq :directory
+                          (sb-unix:unix-file-kind (namestring path)))
+                  path)
+         #-(or allegro clisp cmu lispworks sbcl scl)
+         (probe-file path)))
+    (if probe
+       probe
+       (when error-if-not-exists
+         (error "Directory ~A does not exist." filename)))))
 
 (defun cwd (&optional dir)
   "Change directory and set default pathname"
@@ -105,20 +115,33 @@
   #+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))
-  )
+(defun copy-file (from to &key link overwrite preserve-symbolic-links
+                 (preserve-time t) remove-destination force verbose)
+  #+allegro (sys:copy-file from to :link link :overwrite overwrite
+                          :preserve-symbolic-links preserve-symbolic-links 
+                          :preserve-time preserve-time
+                          :remove-destination remove-destination
+                          :force force :verbose verbose)
+  #-allegro
+  (cond
+    ((and (typep from 'stream) (typep to 'stream))
+     (copy-binary-stream from to))
+    ((not (probe-file from))
+     (error "File ~A does not exist." from))
+    ((eq link :hard)
+     (run-shell-command "ln -f ~A ~A" (namestring from) (namestring to)))
+    (link
+     (multiple-value-bind (stdout stderr status)
+        (command-output "ln -f ~A ~A" (namestring from) (namestring to))
+       (declare (ignore stdout stderr))
+       ;; try symbolic if command failed
+       (unless (zerop status)
+        (run-shell-command "ln -sf ~A ~A" (namestring from) (namestring to)))))
+    (t
+     (when (and (or force remove-destination) (probe-file to))
+       (delete-file to))
+     (let* ((options (if preserve-time 
+                        "-p"
+                        ""))
+           (cmd (format nil "cp ~A ~A ~A" options (namestring from) (namestring to))))
+       (run-shell-command cmd)))))