r9971: fix package name
authorKevin M. Rosenberg <kevin@rosenberg.net>
Mon, 6 Sep 2004 16:49:59 +0000 (16:49 +0000)
committerKevin M. Rosenberg <kevin@rosenberg.net>
Mon, 6 Sep 2004 16:49:59 +0000 (16:49 +0000)
impl.lisp
io.lisp
kmrcl.asd
os.lisp
package.lisp
strings.lisp

index c2d7cab..0b37c8b 100644 (file)
--- a/impl.lisp
+++ b/impl.lisp
   #+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 (file)
--- a/io.lisp
+++ b/io.lisp
     (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)))
 
index 7a2ff95..d16bfe9 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 5b6fff3..5bbfbfa 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)))
index 27df0e6..9b9316f 100644 (file)
    #: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
    #:command-output
    #:run-shell-command-output-stream
    #:delete-directory-and-files
-   
+   #:file-size
+
    ;; color.lisp
    #:rgb->hsv
    #:rgb255->hsv255
index 9dbe1ba..0c5ae7c 100644 (file)
@@ -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)