r9971: fix package name

diff --git a/impl.lisp b/impl.lisp
index c2d7cabb84a3a36750374cf33aefa5d24ae36ae8..0b37c8badc9b655f1f7c45777dc6f7b433cb1000 100644 (file)
--- 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 75ee65087b1c3ccd78ed37749818e5de5c6c3556..ba68048739c57e4ff55b4138d8e48e6308af95cc 100644 (file)
--- 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 7a2ff95a0f62ae341a01396e318cd5701fa48944..d16bfe9976e2d124f330430cdf8b9f95a1032266 100644 (file)
--- 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 5b6fff3aa3d90aad02dd8ce57fa88f25c0560f87..5bbfbfa4f2fbca3ff430e88dd14c9a10df46133b 100644 (file)
--- 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 27df0e64e6b3e5a88fedabd51623deb9e74b1dc5..9b9316f9f05f9e23e1bde6adb93a968c1d6aee28 100644 (file)
--- 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 9dbe1babdccd7950172033dc0d5c6d9614ff4921..0c5ae7c4ec47407e0e77b358a1bf4c713dee89b2 100644 (file)
--- 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)