opt-lambda -> define/kw
svn: r4032
This commit is contained in:
parent
21939a881d
commit
b20f81b781
|
@ -1,5 +1,5 @@
|
||||||
(module tar mzscheme
|
(module tar mzscheme
|
||||||
(require (lib "deflate.ss") (lib "file.ss") (lib "etc.ss"))
|
(require (lib "deflate.ss") (lib "file.ss") (lib "kw.ss"))
|
||||||
|
|
||||||
(define tar-block-size 512)
|
(define tar-block-size 512)
|
||||||
(define tar-name-length 100)
|
(define tar-name-length 100)
|
||||||
|
@ -119,13 +119,12 @@
|
||||||
;; tar-write : (listof relative-path) ->
|
;; tar-write : (listof relative-path) ->
|
||||||
;; writes a tar file to current-output-port
|
;; writes a tar file to current-output-port
|
||||||
(provide tar->output)
|
(provide tar->output)
|
||||||
(define tar->output
|
(define/kw (tar->output files #:optional [out (current-output-port)])
|
||||||
(opt-lambda (files [out (current-output-port)])
|
|
||||||
(parameterize ([current-output-port out])
|
(parameterize ([current-output-port out])
|
||||||
(let* ([buf (new-block)] [entry (tar-one-entry buf)])
|
(let* ([buf (new-block)] [entry (tar-one-entry buf)])
|
||||||
(for-each entry files)
|
(for-each entry files)
|
||||||
;; two null blocks end-marker
|
;; two null blocks end-marker
|
||||||
(write-bytes buf) (write-bytes buf)))))
|
(write-bytes buf) (write-bytes buf))))
|
||||||
|
|
||||||
;; tar : output-file paths ->
|
;; tar : output-file paths ->
|
||||||
(provide tar)
|
(provide tar)
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
;; A modification of Dave Herman's zip module
|
;; A modification of Dave Herman's zip module
|
||||||
|
|
||||||
(module zip mzscheme
|
(module zip mzscheme
|
||||||
(require (lib "deflate.ss") (lib "file.ss") (lib "etc.ss"))
|
(require (lib "deflate.ss") (lib "file.ss") (lib "kw.ss"))
|
||||||
|
|
||||||
;; ===========================================================================
|
;; ===========================================================================
|
||||||
;; DATA DEFINITIONS
|
;; DATA DEFINITIONS
|
||||||
|
@ -246,8 +246,7 @@
|
||||||
;; zip-write : (listof relative-path) ->
|
;; zip-write : (listof relative-path) ->
|
||||||
;; writes a zip file to current-output-port
|
;; writes a zip file to current-output-port
|
||||||
(provide zip->output)
|
(provide zip->output)
|
||||||
(define zip->output
|
(define/kw (zip->output files #:optional [out (current-output-port)])
|
||||||
(opt-lambda (files [out (current-output-port)])
|
|
||||||
(parameterize ([current-output-port out])
|
(parameterize ([current-output-port out])
|
||||||
(let* ([seekable? (seekable-port? (current-output-port))]
|
(let* ([seekable? (seekable-port? (current-output-port))]
|
||||||
[headers ; note: MzScheme's `map' is always left-to-right
|
[headers ; note: MzScheme's `map' is always left-to-right
|
||||||
|
@ -258,7 +257,7 @@
|
||||||
(fprintf (current-error-port) "zip: writing headers...\n"))
|
(fprintf (current-error-port) "zip: writing headers...\n"))
|
||||||
(write-central-directory headers))
|
(write-central-directory headers))
|
||||||
(when (zip-verbose)
|
(when (zip-verbose)
|
||||||
(fprintf (current-error-port) "zip: done.\n")))))
|
(fprintf (current-error-port) "zip: done.\n"))))
|
||||||
|
|
||||||
;; zip : output-file paths ->
|
;; zip : output-file paths ->
|
||||||
(provide zip)
|
(provide zip)
|
||||||
|
|
Loading…
Reference in New Issue
Block a user