60 lines
1.7 KiB
Scheme
60 lines
1.7 KiB
Scheme
;;; -*-Scheme-*-
|
|
;;;
|
|
;;; Demonstrate open, stat, read, write.
|
|
|
|
(require 'unix)
|
|
|
|
(define copy-buffer-size 8192)
|
|
|
|
(define (copy-file from to)
|
|
(let ((from-stat (unix-stat from))
|
|
(to-stat (unix-errval (unix-stat to))))
|
|
|
|
(if (eq? (stat-type from-stat) 'directory) ; complain if "from"
|
|
(error 'copy-file "~s is a directory" from)) ; is a directory
|
|
|
|
(if (and (not (unix-error? to-stat)) ; destination exists
|
|
(eq? (stat-type to-stat) 'directory)) ; and is a directory?
|
|
(set! to (format #f "~a/~a" to (pathname-tail from))))
|
|
|
|
(let* ((to-fd (unix-open to '(write create exclusive)
|
|
(stat-mode from-stat)))
|
|
(from-fd (unix-open from '(read)))
|
|
(buf (make-string copy-buffer-size)))
|
|
|
|
(let loop ((num-chars (unix-read-string-fill! from-fd buf)))
|
|
(if (positive? num-chars)
|
|
(begin
|
|
(unix-write to-fd buf num-chars)
|
|
(loop (unix-read-string-fill! from-fd buf)))))
|
|
|
|
(unix-close from-fd)
|
|
(unix-close to-fd))))
|
|
|
|
(define (string-rindex s c)
|
|
(let loop ((i (string-length s)))
|
|
(cond
|
|
((zero? i) #f)
|
|
((char=? (string-ref s (1- i)) c) (1- i))
|
|
(else (loop (1- i))))))
|
|
|
|
(define (pathname-tail s)
|
|
(let ((i (string-rindex s #\/)))
|
|
(if i
|
|
(substring s (1+ i) (string-length s))
|
|
s)))
|
|
|
|
;;; Test -- copy /bin/date into a temporary file
|
|
|
|
(let ((tmp (unix-tempname)))
|
|
(unwind-protect
|
|
(begin
|
|
(format #t "Copying /bin/date to ~a.~%" tmp)
|
|
(copy-file "/bin/date" tmp)
|
|
(format #t "Comparing files... ")
|
|
(if (zero? (unix-system (format #f "cmp -s /bin/date ~s" tmp)))
|
|
(format #t "OK.~%")
|
|
(format #t "Oops, files differ.~%")))
|
|
(format #t "Removing ~a.~%" tmp)
|
|
(unix-unlink tmp)))
|