X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=impl.lisp;h=c17449c088fb6a7b11d8755650d95a45d4519ac9;hp=c2d7cabb84a3a36750374cf33aefa5d24ae36ae8;hb=d4bfdf559cbd44dee337d2d2fbb457bfe1cec56e;hpb=1738d41053dae41266d5740385be9aac03a864ad

diff --git a/impl.lisp b/impl.lisp
index c2d7cab..c17449c 100644
--- a/impl.lisp
+++ b/impl.lisp
@@ -44,9 +44,12 @@
 	     (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 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)))
 
@@ -105,20 +108,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)))))