From 201a12d75bcf55989e2c710148d15395a7c4bece Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 30 Jun 2009 21:06:53 +0000 Subject: [PATCH] Moved `tar' from mzlib to file, and use `scheme/base' now. svn: r15346 --- collects/file/tar.ss | 152 +++++++++++++++++++++++++++++++++++++++- collects/mzlib/tar.ss | 157 +----------------------------------------- 2 files changed, 153 insertions(+), 156 deletions(-) diff --git a/collects/file/tar.ss b/collects/file/tar.ss index 9be4d5b9f2..9de2b265ee 100644 --- a/collects/file/tar.ss +++ b/collects/file/tar.ss @@ -1,4 +1,152 @@ #lang scheme/base +(require file/gzip scheme/file) -(require mzlib/tar) -(provide (all-from-out mzlib/tar)) +(define tar-block-size 512) +(define tar-name-length 100) +(define tar-prefix-length 155) + +(define 0-block (make-bytes tar-block-size 0)) ; used for fast block zeroing + +(define (new-block) (bytes-copy 0-block)) +(define (zero-block! buf) (bytes-copy! buf 0 0-block)) + +(define path->name-bytes + (case (system-type) + [(windows) (lambda (p) (regexp-replace* #rx"\\\\" (path->bytes p) "/"))] + [else path->bytes])) + +(define sep-char (char->integer #\/)) + +(define (split-tar-name path) + (let* ([bts (path->name-bytes path)] + [len (bytes-length bts)]) + (if (< len tar-name-length) + (values bts #f) + (let loop ([n 1]) ; seach for a split point + (cond [(<= (sub1 len) n) + (error 'tar "path too long for USTAR: ~a" path)] + [(and (eq? sep-char (bytes-ref bts n)) + (< n tar-prefix-length) + (< (- len (+ n 1)) tar-name-length)) + (values (subbytes bts (add1 n)) (subbytes bts 0 n))] + [else (loop (add1 n))]))))) + +;; see also the same function name in zip.ss +(define (path-attributes path dir?) + (apply bitwise-ior + (map (lambda (p) + (case p + [(read) #o444] + [(write) #o200] ; mask out write bits + [(execute) #o111])) + (file-or-directory-permissions path)))) + +(define 0-byte (char->integer #\0)) + +(define ((tar-one-entry buf) path) + (let* ([path (resolve-path path)] + [dir? (directory-exists? path)] + [size (if dir? 0 (file-size path))] + [p 0] ; write pointer + [cksum 0] + [cksum-p #f]) + (define-values (file-name file-prefix) (split-tar-name path)) + (define-syntax advance (syntax-rules () [(_ l) (set! p (+ p l))])) + (define (write-block* len bts) ; no padding required + (when bts + (bytes-copy! buf p bts) + (for ([i (in-range (bytes-length bts))]) + (set! cksum (+ cksum (bytes-ref bts i))))) + (advance len)) + (define (write-block len bts) ; len includes one nul padding + (when (and bts (<= len (bytes-length bts))) + (error 'tar "entry too long, should fit in ~a bytes: ~e" + (sub1 len) bts)) + (write-block* len bts)) + (define (write-octal len int) ; int should take all space -1 nul-padding + (let loop ([q (+ p len -2)] [n int]) + (if (< q p) + (when (< 0 n) + (error 'tar "integer too big, should fit in ~a bytes: ~e" + int (sub1 len))) + (let ([d (+ 0-byte (modulo n 8))]) + (bytes-set! buf q d) + (set! cksum (+ cksum d)) + (loop (sub1 q) (quotient n 8))))) + (advance len)) + ;; see http://www.mkssoftware.com/docs/man4/tar.4.asp for format spec + (write-block tar-name-length file-name) + (write-octal 8 (path-attributes path dir?)) + (write-octal 8 0) ; always root (uid) + (write-octal 8 0) ; always root (gid) + (write-octal 12 size) + (write-octal 12 (file-or-directory-modify-seconds path)) + ;; set checksum later, consider it "all blanks" for cksum + (set! cksum-p p) (set! cksum (+ cksum (* 8 32))) (advance 8) + (write-block* 1 (if dir? #"5" #"0")) ; type-flag: dir/file (no symlinks) + (advance 100) ; no link-name + (write-block 6 #"ustar") ; magic + (write-block* 2 #"00") ; version + (write-block 32 #"root") ; always root (user-name) + (write-block 32 #"root") ; always root (group-name) + (write-octal 8 0) ; device-major + (write-octal 8 0) ; device-minor + (write-block tar-prefix-length file-prefix) + (set! p cksum-p) + (write-octal 8 cksum) ; patch checksum + (write-bytes buf) + (if dir? + (zero-block! buf) ; must clean buffer for re-use + ;; write the file + (with-input-from-file path + (lambda () + (let loop ([n size]) + (let ([l (read-bytes! buf)]) + (cond + [(eq? l tar-block-size) (write-bytes buf) (loop (- n l))] + [(number? l) ; shouldn't happen + (write-bytes buf (current-output-port) 0 l) (loop (- n l))] + [(not (eq? eof l)) (error 'tar "internal error")] + [(not (zero? n)) + (error 'tar "file changed while packing: ~e" path)] + [else (zero-block! buf) ; must clean buffer for re-use + (let ([l (modulo size tar-block-size)]) + (unless (zero? l) + ;; complete block (buf is now zeroed) + (write-bytes buf (current-output-port) + 0 (- tar-block-size l))))])))))))) + +;; tar-write : (listof relative-path) -> +;; writes a tar file to current-output-port +(provide tar->output) +(define (tar->output files [out (current-output-port)]) + (parameterize ([current-output-port out]) + (let* ([buf (new-block)] [entry (tar-one-entry buf)]) + (for-each entry files) + ;; two null blocks end-marker + (write-bytes buf) (write-bytes buf)))) + +;; tar : output-file paths -> +(provide tar) +(define (tar tar-file . paths) + (when (null? paths) (error 'tar "no paths specified")) + (with-output-to-file tar-file + (lambda () (tar->output (pathlist-closure paths))))) + +;; tar-gzip : output-file paths -> +(provide tar-gzip) +(define (tar-gzip tgz-file . paths) + (when (null? paths) (error 'tar-gzip "no paths specified")) + (with-output-to-file tgz-file + (lambda () + (let-values ([(i o) (make-pipe)]) + (thread (lambda () + (tar->output (pathlist-closure paths) o) + (close-output-port o))) + (gzip-through-ports + i (current-output-port) + (cond [(regexp-match #rx"^(.*[.])(?:tar[.]gz|tgz)$" + (if (path? tgz-file) + (path->string tgz-file) tgz-file)) + => (lambda (m) (string-append (car m) "tar"))]) + (current-seconds)))))) diff --git a/collects/mzlib/tar.ss b/collects/mzlib/tar.ss index b91cfefbc8..c251ede0a4 100644 --- a/collects/mzlib/tar.ss +++ b/collects/mzlib/tar.ss @@ -1,154 +1,3 @@ -(module tar mzscheme - (require mzlib/deflate mzlib/file mzlib/kw) - - (define tar-block-size 512) - (define tar-name-length 100) - (define tar-prefix-length 155) - - (define 0-block (make-bytes tar-block-size 0)) ; used for fast block zeroing - - (define (new-block) (bytes-copy 0-block)) - (define (zero-block! buf) (bytes-copy! buf 0 0-block)) - - (define path->name-bytes - (case (system-type) - [(windows) (lambda (p) (regexp-replace* #rx"\\\\" (path->bytes p) "/"))] - [else path->bytes])) - - (define sep-char (char->integer #\/)) - - (define (split-tar-name path) - (let* ([bts (path->name-bytes path)] - [len (bytes-length bts)]) - (if (< len tar-name-length) - (values bts #f) - (let loop ([n 1]) ; seach for a split point - (cond [(<= (sub1 len) n) - (error 'tar "path too long for USTAR: ~a" path)] - [(and (eq? sep-char (bytes-ref bts n)) - (< n tar-prefix-length) - (< (- len (+ n 1)) tar-name-length)) - (values (subbytes bts (add1 n)) (subbytes bts 0 n))] - [else (loop (add1 n))]))))) - - ;; see also the same function name in zip.ss - (define (path-attributes path dir?) - (apply bitwise-ior (map (lambda (p) - (case p - [(read) #o444] - [(write) #o200] ; mask out write bits - [(execute) #o111])) - (file-or-directory-permissions path)))) - - (define 0-byte (char->integer #\0)) - - (define ((tar-one-entry buf) path) - (let* ([path (resolve-path path)] - [dir? (directory-exists? path)] - [size (if dir? 0 (file-size path))] - [p 0] ; write pointer - [cksum 0] - [cksum-p #f]) - (define-values (file-name file-prefix) (split-tar-name path)) - (define-syntax advance (syntax-rules () [(_ l) (set! p (+ p l))])) - (define (write-block* len bts) ; no padding required - (when bts - (bytes-copy! buf p bts) - (do ([i (sub1 (bytes-length bts)) (sub1 i)]) - [(< i 0)] - (set! cksum (+ cksum (bytes-ref bts i))))) - (advance len)) - (define (write-block len bts) ; len includes one nul padding - (when (and bts (<= len (bytes-length bts))) - (error 'tar "entry too long, should fit in ~a bytes: ~e" - (sub1 len) bts)) - (write-block* len bts)) - (define (write-octal len int) ; int should take all space -1 nul-padding - (let loop ([q (+ p len -2)] [n int]) - (if (< q p) - (when (< 0 n) - (error 'tar "integer too big, should fit in ~a bytes: ~e" - int (sub1 len))) - (let ([d (+ 0-byte (modulo n 8))]) - (bytes-set! buf q d) - (set! cksum (+ cksum d)) - (loop (sub1 q) (quotient n 8))))) - (advance len)) - ;; see http://www.mkssoftware.com/docs/man4/tar.4.asp for format spec - (write-block tar-name-length file-name) - (write-octal 8 (path-attributes path dir?)) - (write-octal 8 0) ; always root (uid) - (write-octal 8 0) ; always root (gid) - (write-octal 12 size) - (write-octal 12 (file-or-directory-modify-seconds path)) - ;; set checksum later, consider it "all blanks" for cksum - (set! cksum-p p) (set! cksum (+ cksum (* 8 32))) (advance 8) - (write-block* 1 (if dir? #"5" #"0")) ; type-flag: dir/file (no symlinks) - (advance 100) ; no link-name - (write-block 6 #"ustar") ; magic - (write-block* 2 #"00") ; version - (write-block 32 #"root") ; always root (user-name) - (write-block 32 #"root") ; always root (group-name) - (write-octal 8 0) ; device-major - (write-octal 8 0) ; device-minor - (write-block tar-prefix-length file-prefix) - (set! p cksum-p) - (write-octal 8 cksum) ; patch checksum - (write-bytes buf) - (if dir? - (zero-block! buf) ; must clean buffer for re-use - ;; write the file - (with-input-from-file path - (lambda () - (let loop ([n size]) - (let ([l (read-bytes! buf)]) - (cond - [(eq? l tar-block-size) (write-bytes buf) (loop (- n l))] - [(number? l) ; shouldn't happen - (write-bytes buf (current-output-port) 0 l) (loop (- n l))] - [(not (eq? eof l)) (error 'tar "internal error")] - [(not (zero? n)) - (error 'tar "file changed while packing: ~e" path)] - [else (zero-block! buf) ; must clean buffer for re-use - (let ([l (modulo size tar-block-size)]) - (unless (zero? l) - ;; complete block (buf is now zeroed) - (write-bytes buf (current-output-port) - 0 (- tar-block-size l))))])))))))) - - ;; tar-write : (listof relative-path) -> - ;; writes a tar file to current-output-port - (provide tar->output) - (define/kw (tar->output files #:optional [out (current-output-port)]) - (parameterize ([current-output-port out]) - (let* ([buf (new-block)] [entry (tar-one-entry buf)]) - (for-each entry files) - ;; two null blocks end-marker - (write-bytes buf) (write-bytes buf)))) - - ;; tar : output-file paths -> - (provide tar) - (define (tar tar-file . paths) - (when (null? paths) (error 'tar "no paths specified")) - (with-output-to-file tar-file - (lambda () (tar->output (pathlist-closure paths))))) - - ;; tar-gzip : output-file paths -> - (provide tar-gzip) - (define (tar-gzip tgz-file . paths) - (when (null? paths) (error 'tar-gzip "no paths specified")) - (with-output-to-file tgz-file - (lambda () - (let-values ([(i o) (make-pipe)]) - (thread (lambda () - (tar->output (pathlist-closure paths) o) - (close-output-port o))) - (gzip-through-ports - i (current-output-port) - (cond [(regexp-match #rx"^(.*[.])(?:tar[.]gz|tgz)$" - (if (path? tgz-file) - (path->string tgz-file) tgz-file)) - => (lambda (m) (string-append (car m) "tar"))]) - (current-seconds)))))) - - ) +#lang scheme/base +(require file/tar) +(provide (all-from-out file/tar))