From: Chris Hanson Date: Sat, 28 Oct 1995 01:16:09 +0000 (+0000) Subject: Move COPY-FILE into the operating-system-specific files. Both OS/2 X-Git-Tag: 20090517-FFI~5830 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=72648503ff22a8a926488425807ab8ab95058092;p=mit-scheme.git 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 a3fb56cfd..9f075fb10 100644 --- 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)))) (define (initialize-system-primitives!) (discard-select-registry-result-vectors!) diff --git a/v7/src/runtime/sfile.scm b/v7/src/runtime/sfile.scm index 9ebf80054..32125460f 100644 --- 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)))) - + (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 6cd60dbc7..21748c9cb 100644 --- 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) +(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)))) + ;;; Queues after-restart daemon to clean up environment space (define (initialize-system-primitives!)