Move COPY-FILE into the operating-system-specific files. Both OS/2

and NT provide API calls to implement this operation, and these calls
do a better job than is possible with the previous code.  (For
example, the OS/2 call also copies extended attributes.)

diff --git a/v7/src/runtime/os2prm.scm b/v7/src/runtime/os2prm.scm
index a3fb56cfdea91c010f736c0a4f5b667ce9e4192c..9f075fb104064e43c1689245a832ea33aad83ef8 100644 (file)
--- a/v7/src/runtime/os2prm.scm
+++ b/v7/src/runtime/os2prm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: os2prm.scm,v 1.22 1995/10/25 02:16:48 cph Exp $
+$Id: os2prm.scm,v 1.23 1995/10/28 01:15:54 cph Exp $
 
 Copyright (c) 1994-95 Massachusetts Institute of Technology
 
@@ -82,6 +82,12 @@ MIT in each case. |#
    (->namestring (merge-pathnames filename))
    modes))
 
+(define-integrable os2-file-mode/read-only #x01)
+(define-integrable os2-file-mode/hidden    #x02)
+(define-integrable os2-file-mode/system    #x04)
+(define-integrable os2-file-mode/directory #x10)
+(define-integrable os2-file-mode/archived  #x20)
+
 (define (file-length filename)
   ((ucode-primitive file-length 1)
    (->namestring (merge-pathnames filename))))
@@ -281,6 +287,10 @@ MIT in each case. |#
 
 (define (os/default-end-of-line-translation)
   "\r\n")
+
+(define (copy-file from to)
+  ((ucode-primitive os2-copy-file 2) (->namestring (merge-pathnames from))
+                                    (->namestring (merge-pathnames to))))
 \f
 (define (initialize-system-primitives!)
   (discard-select-registry-result-vectors!)

diff --git a/v7/src/runtime/sfile.scm b/v7/src/runtime/sfile.scm
index 9ebf800542bb4730f0cd638540b1c894ffb3b639..32125460f9ddbf1fcbd7ddc92cc6848d083470a9 100644 (file)
--- a/v7/src/runtime/sfile.scm
+++ b/v7/src/runtime/sfile.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: sfile.scm,v 14.17 1995/04/09 22:57:42 cph Exp $
+$Id: sfile.scm,v 14.18 1995/10/28 01:16:09 cph Exp $
 
 Copyright (c) 1988-95 Massachusetts Institute of Technology
 
@@ -59,58 +59,10 @@ MIT in each case. |#
         (delete-file filename)
         #t)))))
 
-(define (copy-file from to)
-  (let ((input-filename (->namestring (merge-pathnames from)))
-       (output-filename (->namestring (merge-pathnames to))))
-    (let ((input-channel false)
-         (output-channel false))
-      (dynamic-wind
-       (lambda ()
-        (set! input-channel (file-open-input-channel input-filename))
-        (set! output-channel
-              (begin
-                ((ucode-primitive file-remove-link 1) output-filename)
-                (file-open-output-channel output-filename)))
-        unspecific)
-       (lambda ()
-        (let ((source-length (channel-file-length input-channel))
-              (buffer-length 8192))
-          (if (zero? source-length)
-              0
-              (let* ((buffer (make-string buffer-length))
-                     (transfer
-                      (lambda (length)
-                        (let ((n-read
-                               (channel-read-block input-channel
-                                                   buffer
-                                                   0
-                                                   length)))
-                          (if (positive? n-read)
-                              (channel-write-block output-channel
-                                                   buffer
-                                                   0
-                                                   n-read))
-                          n-read))))
-                (let loop ((source-length source-length))
-                  (if (< source-length buffer-length)
-                      (transfer source-length)
-                      (let ((n-read (transfer buffer-length)))
-                        (if (= n-read buffer-length)
-                            (+ (loop (- source-length buffer-length))
-                               buffer-length)
-                            n-read))))))))
-       (lambda ()
-        (if output-channel (channel-close output-channel))
-        (if input-channel (channel-close input-channel)))))
-    (set-file-times! output-filename
-                    #f
-                    (file-modification-time input-filename))
-    (set-file-modes! output-filename (file-modes input-filename))))
-
 (define (file-eq? x y)
   ((ucode-primitive file-eq?) (->namestring (merge-pathnames x))
                              (->namestring (merge-pathnames y))))
-\f
+
 (define (call-with-temporary-filename receiver)
   (call-with-temporary-file-pathname
    (lambda (pathname)

diff --git a/v7/src/runtime/unxprm.scm b/v7/src/runtime/unxprm.scm
index 6cd60dbc75fbcdffb22ffcc9dc378a1c13ff98a8..21748c9cbd67037e2bf2b1dbf2a7baae47c03f44 100644 (file)
--- a/v7/src/runtime/unxprm.scm
+++ b/v7/src/runtime/unxprm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: unxprm.scm,v 1.40 1995/10/23 06:39:22 cph Exp $
+$Id: unxprm.scm,v 1.41 1995/10/28 01:16:00 cph Exp $
 
 Copyright (c) 1988-95 Massachusetts Institute of Technology
 
@@ -297,6 +297,54 @@ MIT in each case. |#
 (define (os/default-end-of-line-translation)
   #f)
 \f
+(define (copy-file from to)
+  (let ((input-filename (->namestring (merge-pathnames from)))
+       (output-filename (->namestring (merge-pathnames to))))
+    (let ((input-channel false)
+         (output-channel false))
+      (dynamic-wind
+       (lambda ()
+        (set! input-channel (file-open-input-channel input-filename))
+        (set! output-channel
+              (begin
+                ((ucode-primitive file-remove-link 1) output-filename)
+                (file-open-output-channel output-filename)))
+        unspecific)
+       (lambda ()
+        (let ((source-length (channel-file-length input-channel))
+              (buffer-length 8192))
+          (if (zero? source-length)
+              0
+              (let* ((buffer (make-string buffer-length))
+                     (transfer
+                      (lambda (length)
+                        (let ((n-read
+                               (channel-read-block input-channel
+                                                   buffer
+                                                   0
+                                                   length)))
+                          (if (positive? n-read)
+                              (channel-write-block output-channel
+                                                   buffer
+                                                   0
+                                                   n-read))
+                          n-read))))
+                (let loop ((source-length source-length))
+                  (if (< source-length buffer-length)
+                      (transfer source-length)
+                      (let ((n-read (transfer buffer-length)))
+                        (if (= n-read buffer-length)
+                            (+ (loop (- source-length buffer-length))
+                               buffer-length)
+                            n-read))))))))
+       (lambda ()
+        (if output-channel (channel-close output-channel))
+        (if input-channel (channel-close input-channel)))))
+    (set-file-times! output-filename
+                    #f
+                    (file-modification-time input-filename))
+    (set-file-modes! output-filename (file-modes input-filename))))
+\f
 ;;; Queues after-restart daemon to clean up environment space
 
 (define (initialize-system-primitives!)