From: Kevin M. Rosenberg <kevin@rosenberg.net>
Date: Mon, 6 Sep 2004 16:49:59 +0000 (+0000)
Subject: r9971: fix package name
X-Git-Tag: v1.96~59
X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=commitdiff_plain;h=1b7f506ec98bd5b885203a3250c52603b943cee9

r9971: fix package name
---

diff --git a/impl.lisp b/impl.lisp
index c2d7cab..0b37c8b 100644
--- a/impl.lisp
+++ b/impl.lisp
@@ -105,20 +105,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)))))
diff --git a/io.lisp b/io.lisp
index 75ee650..ba68048 100644
--- a/io.lisp
+++ b/io.lisp
@@ -311,4 +311,9 @@
     (write-char #\: stream)
     (write-string (aref +datetime-number-strings+ minute) stream)))
 
+(defun copy-binary-stream (in out)
+  (do* ((buf (make-array 4096 :element-type '(unsigned-byte 8)))
+	(pos (read-sequence buf in) (read-sequence buf in)))
+      ((zerop pos))
+    (write-sequence buf out :end pos)))
 
diff --git a/kmrcl.asd b/kmrcl.asd
index 7a2ff95..d16bfe9 100644
--- a/kmrcl.asd
+++ b/kmrcl.asd
@@ -58,7 +58,7 @@
      (:file "processes" :depends-on ("macros"))
      (:file "listener" :depends-on ("sockets" "processes" "console"))
      (:file "repl" :depends-on ("listener" "strings"))
-     (:file "os" :depends-on ("macros"))
+     (:file "os" :depends-on ("macros" "impl"))
      ))
 
 (defmethod perform ((o test-op) (c (eql (find-system 'kmrcl))))
diff --git a/os.lisp b/os.lisp
index 5b6fff3..5bbfbfa 100644
--- a/os.lisp
+++ b/os.lisp
@@ -60,7 +60,8 @@ returns (VALUES string-output error-output exit-status)"
 	  (let ((status 
 		 (system:call-system-showing-output
 		  command
-		  :shell-type "/bin/sh"
+		  :prefix ""
+		  :show-cmd nil
 		  :output-stream output)))
 	    (values (get-output-stream-string output) nil status))
 	(close output)))
@@ -119,7 +120,9 @@ returns (VALUES output-string pid)"
     (system:call-system-showing-output
      command
      :shell-type "/bin/sh"
-     :output-stream output)
+     :show-cmd nil
+     :prefix ""
+     :output-stream nil)
     
     #+clisp		;XXX not exactly *verbose-out*, I know
     (ext:run-shell-command  command :output :terminal :wait t)
@@ -148,3 +151,10 @@ returns (VALUES output-string pid)"
 		      (command-output cmd)))
 		   ((eq if-does-not-exist :error)
 		    (error "Directory ~A does not exist [delete-directory-and-files]." dir))))
+
+(defun file-size (file)
+  #+allegro (let ((stat (excl.osi:stat (namestring file))))
+	      (excl.osi:stat-size stat))
+  #-allegro
+  (with-open-file (in file :direction :input)
+    (file-length in)))
diff --git a/package.lisp b/package.lisp
index 27df0e6..9b9316f 100644
--- a/package.lisp
+++ b/package.lisp
@@ -108,13 +108,15 @@
    #:day-of-week
    #:+datetime-number-strings+   
    #:utc-offset
-   
+   #:copy-binary-stream
+
    ;; impl.lisp
    #:probe-directory
    #:cwd
    #:quit
    #:command-line-arguments
-   #:shell-command-output
+   #:copy-file
+   #:run-shell-command
 
    ;; lists.lisp
    #:remove-from-tree-if
@@ -287,7 +289,8 @@
    #:command-output
    #:run-shell-command-output-stream
    #:delete-directory-and-files
-   
+   #:file-size
+
    ;; color.lisp
    #:rgb->hsv
    #:rgb255->hsv255
diff --git a/strings.lisp b/strings.lisp
index 9dbe1ba..0c5ae7c 100644
--- a/strings.lisp
+++ b/strings.lisp
@@ -648,7 +648,6 @@ for characters in a string"
       word)))
 
 	  
-
 (defun collapse-whitespace (s)
   "Convert multiple whitespace characters to a single space character."
   (declare (simple-string s)