Moved some mzlib library implementations to racket
The libraries moved were: - mzlib/control => racket/control - mzlib/date => racket/date - mzlib/deflate => file/gzip - mzlib/inflate => file/gunzip - mzlib/port => racket/port - mzlib/process => racket/system - mzlib/runtime-path => racket/runtime-path - mzlib/shared => racket/shared - mzlib/unit => racket/unit - mzlib/unit-exptime => racket/unit-exptime - mzlib/zip => file/zip The old modules in mzlib are now pointers to the new modules. These are all modules that were already redirected in the documentation. original commit: 403aaac7d4c32132223f06e059df439cceda7a2e
This commit is contained in:
Asumu Takikawa
parent
c53585429a
commit
1ef7101d53
|
|
@ -1,6 +1,6 @@
|
|||
(module a-signature mzscheme
|
||||
(require-for-syntax "private/unit-compiletime.rkt"
|
||||
"private/unit-syntax.rkt")
|
||||
(require-for-syntax racket/private/unit-compiletime
|
||||
racket/private/unit-syntax)
|
||||
(require "unit.rkt")
|
||||
|
||||
(provide (rename module-begin #%module-begin)
|
||||
|
|
|
|||
|
|
@ -1,268 +1,6 @@
|
|||
#lang racket/base
|
||||
|
||||
(require (for-syntax racket/base))
|
||||
|
||||
(provide call/prompt call/comp abort/cc
|
||||
|
||||
abort
|
||||
|
||||
fcontrol %
|
||||
|
||||
control prompt control-at prompt-at
|
||||
;; `-at' variations expect a prompt tag
|
||||
|
||||
shift reset shift-at reset-at
|
||||
|
||||
control0 prompt0 control0-at prompt0-at
|
||||
shift0 reset0 shift0-at reset0-at
|
||||
|
||||
spawn
|
||||
|
||||
splitter
|
||||
|
||||
new-prompt set cupto)
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define call/prompt call-with-continuation-prompt)
|
||||
(define call/comp call-with-composable-continuation)
|
||||
(define abort/cc abort-current-continuation)
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (abort . vals)
|
||||
(abort-current-continuation
|
||||
(default-continuation-prompt-tag)
|
||||
(lambda () (apply values vals))))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Sitaram, PLDI'93
|
||||
;; The `%' here is compable with Sitaram & Felleisen, LSC'90,
|
||||
;; since we make the handler optional.
|
||||
|
||||
(define (fcontrol f #:tag [prompt-tag (default-continuation-prompt-tag)])
|
||||
(call-with-composable-continuation
|
||||
(lambda (k)
|
||||
(abort-current-continuation
|
||||
prompt-tag
|
||||
f
|
||||
k))))
|
||||
|
||||
(define-syntax %
|
||||
(syntax-rules ()
|
||||
[(_ expr handler #:tag prompt-tag)
|
||||
(call-with-continuation-prompt
|
||||
(lambda () expr)
|
||||
prompt-tag
|
||||
handler)]
|
||||
[(_ expr handler)
|
||||
(call-with-continuation-prompt
|
||||
(lambda () expr)
|
||||
(default-continuation-prompt-tag)
|
||||
handler)]
|
||||
[(_ expr)
|
||||
(call-with-continuation-prompt
|
||||
(lambda () expr))]))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Predecessors of Sitaram, PLDI'93
|
||||
;; Felleisen, Wand, Friedman, & Duba, LFP'88
|
||||
;; Instead of `#', we use `prompt' as in Felleisen, POPL'88
|
||||
;; (where `control' is called `F')
|
||||
;; See also Sitaram and Felleisen, LSC'90
|
||||
|
||||
;; Helpder function: abort-current-continuation/keep-prompt is
|
||||
;; like abort-current-continuation, but it always leaves the
|
||||
;; prompt in place, independent of the prompt's handler.
|
||||
;; This is possible via call/cc (i.e., it must be possible
|
||||
;; to abort and keep a prompt, because call/cc needs it).
|
||||
(define (abort-current-continuation/keep-prompt tag thunk)
|
||||
((call-with-continuation-prompt
|
||||
(lambda ()
|
||||
((call-with-current-continuation
|
||||
(lambda (k) (lambda () k))
|
||||
tag)))
|
||||
tag)
|
||||
thunk))
|
||||
|
||||
;; call-with-control, parameterized over whether to keep the
|
||||
;; prompt (if the prompt's handler gives us the option of
|
||||
;; removing it). The generated function is the same
|
||||
;; as fcontrol when `abort-cc' is `abort-current-continuation'.
|
||||
(define (make-call-with-control abort-cc)
|
||||
;; Uses call/cc to always keep the enclosing prompt.
|
||||
(letrec ([call-with-control
|
||||
(case-lambda
|
||||
[(f) (call-with-control f (default-continuation-prompt-tag))]
|
||||
[(f tag) (call-with-composable-continuation
|
||||
(lambda (k)
|
||||
(abort-cc
|
||||
tag
|
||||
(lambda ()
|
||||
(f k))))
|
||||
tag)])])
|
||||
call-with-control))
|
||||
|
||||
(define call-with-control
|
||||
(make-call-with-control abort-current-continuation/keep-prompt))
|
||||
|
||||
(define-syntax define-control-macros
|
||||
(syntax-rules ()
|
||||
[(_ control control-at call-with-control)
|
||||
(begin
|
||||
(define-syntax (control stx)
|
||||
(syntax-case stx ()
|
||||
[(control id expr0 expr (... ...))
|
||||
(identifier? #'id)
|
||||
#'(call-with-control (lambda (id) expr0 expr (... ...)))]))
|
||||
(define-syntax (control-at stx)
|
||||
(syntax-case stx ()
|
||||
[(control-at tag id expr0 expr (... ...))
|
||||
(identifier? #'id)
|
||||
#'(call-with-control (lambda (id) expr0 expr (... ...)) tag)])))]))
|
||||
|
||||
(define-control-macros control control-at call-with-control)
|
||||
|
||||
(define-syntax define-prompt-macros
|
||||
(syntax-rules ()
|
||||
[(_ prompt prompt-at call-with-prompt)
|
||||
(begin
|
||||
(define-syntax prompt
|
||||
(syntax-rules ()
|
||||
[(prompt expr0 expr (... ...))
|
||||
(call-with-prompt (lambda () expr0 expr (... ...)))]))
|
||||
(define-syntax prompt-at
|
||||
(syntax-rules ()
|
||||
[(prompt-at tag expr0 expr (... ...))
|
||||
(call-with-prompt (lambda () expr0 expr (... ...)) tag)])))]))
|
||||
|
||||
(define-prompt-macros prompt prompt-at call-with-continuation-prompt)
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Danvy & Filinski, LFP'90
|
||||
|
||||
;; call-with-shift, parameterized over whether to keep the prompt
|
||||
;; (if the prompt's handler gives us the option of removing it),
|
||||
;; and whether the new one is removable:
|
||||
(define (make-call-with-shift abort-cc inserted-handler)
|
||||
(letrec ([call-with-shift
|
||||
(case-lambda
|
||||
[(f) (call-with-shift f (default-continuation-prompt-tag))]
|
||||
[(f tag)
|
||||
(call-with-composable-continuation
|
||||
(lambda (k)
|
||||
(abort-cc
|
||||
tag
|
||||
(lambda ()
|
||||
(f (lambda vals
|
||||
(call-with-continuation-prompt
|
||||
(lambda ()
|
||||
(apply k vals))
|
||||
tag
|
||||
inserted-handler))))))
|
||||
tag)])])
|
||||
call-with-shift))
|
||||
|
||||
(define call-with-shift
|
||||
(make-call-with-shift abort-current-continuation/keep-prompt #f))
|
||||
|
||||
(define-control-macros shift shift-at call-with-shift)
|
||||
|
||||
(define-prompt-macros reset reset-at call-with-continuation-prompt)
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Shan, SCHEME'04
|
||||
;; Kiselyov, Indiana CS TR-611, 2005
|
||||
;;
|
||||
;; The `control0' and `shift0' here are closer to Kiselyov, in that
|
||||
;; `control0' and `shift0' only behave as in Shan when paired with
|
||||
;; `prompt0' or `reset0' (which are two names for the same thing).
|
||||
;; When paired with `prompt' or `reset' (again, the same thing),
|
||||
;; they act like `control' and `shift'.
|
||||
;;
|
||||
;; This difference is intentional. The programmer that inserts a
|
||||
;; prompt should choose whether the current continuation is visible
|
||||
;; or not. Note, also, that `control' and `shift' work whether
|
||||
;; they're paired with `prompt'/`reset' or `prompt0'/`reset0'.
|
||||
|
||||
(define call-with-control0
|
||||
;; Uses abort-current-continuation, so that the prompt
|
||||
;; is removed --- if the prompt is willing to be removed.
|
||||
(make-call-with-control abort-current-continuation))
|
||||
|
||||
(define call-with-shift0
|
||||
;; Uses abort-current-continuation, so that the prompt
|
||||
;; is removed --- if the prompt is willing to be removed.
|
||||
;; The prompt installed with the captured continuation is
|
||||
;; itself willing to be removed.
|
||||
(make-call-with-shift abort-current-continuation (lambda (thunk) (thunk))))
|
||||
|
||||
(define-control-macros control0 control0-at call-with-control0)
|
||||
|
||||
(define-control-macros shift0 shift0-at call-with-shift0)
|
||||
|
||||
(define call-with-prompt0
|
||||
(case-lambda
|
||||
[(thunk) (call-with-prompt0 thunk (default-continuation-prompt-tag))]
|
||||
[(thunk tag)
|
||||
(call-with-continuation-prompt thunk tag (lambda (thunk) (thunk)))]))
|
||||
|
||||
(define-prompt-macros prompt0 prompt0-at call-with-prompt0)
|
||||
|
||||
(define-prompt-macros reset0 reset0-at call-with-prompt0)
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Hieb & Dybvig, PPOPP'90
|
||||
|
||||
(define (spawn f)
|
||||
(let ([p (make-continuation-prompt-tag)])
|
||||
(call-with-continuation-prompt
|
||||
(lambda ()
|
||||
(f (lambda (f)
|
||||
(call-with-composable-continuation
|
||||
(lambda (k)
|
||||
(abort-current-continuation
|
||||
p
|
||||
(lambda ()
|
||||
(f (lambda vals
|
||||
(call-with-continuation-prompt
|
||||
(lambda ()
|
||||
(apply k vals))
|
||||
p
|
||||
(lambda (thunk) (thunk))))))))
|
||||
p))))
|
||||
p
|
||||
(lambda (thunk) (thunk)))))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Queinnec & Serpette, POPL'91
|
||||
|
||||
(define (splitter receiver)
|
||||
(let ([p (make-continuation-prompt-tag)])
|
||||
(call-with-continuation-prompt
|
||||
(lambda ()
|
||||
(receiver (lambda (thunk)
|
||||
(abort-current-continuation
|
||||
p
|
||||
thunk))
|
||||
(lambda (proc)
|
||||
(call-with-composable-continuation
|
||||
proc
|
||||
p))))
|
||||
p
|
||||
(lambda (thunk) (thunk)))))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Gunter, Remy, & Rieke, FPLCA'95
|
||||
;; Unfortunately, the "prompt"s in Gunter et al. are what
|
||||
;; we call "prompt tags". In our terminology, a "prompt"
|
||||
;; is a tagged instance in a continuation.
|
||||
|
||||
(define (new-prompt) (make-continuation-prompt-tag))
|
||||
|
||||
(define-syntax set (make-rename-transformer #'prompt0-at))
|
||||
|
||||
(define-syntax cupto (make-rename-transformer #'control0-at))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; deprecated library, see `racket/control`
|
||||
|
||||
(require racket/control)
|
||||
(provide (all-from-out racket/control))
|
||||
|
|
|
|||
|
|
@ -1,367 +1,6 @@
|
|||
#lang racket/base
|
||||
(require racket/promise
|
||||
racket/match
|
||||
racket/list
|
||||
racket/function
|
||||
racket/contract/base)
|
||||
|
||||
(provide/contract
|
||||
[current-date (-> date?)]
|
||||
[date->seconds ((date?) (any/c) . ->* . exact-integer?)]
|
||||
[date->string ((date?) (any/c) . ->* . string?)]
|
||||
[date-display-format (parameter/c (symbols 'american 'chinese 'german 'indian 'irish 'julian 'iso-8601 'rfc2822))]
|
||||
[find-seconds (((integer-in 0 61)
|
||||
(integer-in 0 59)
|
||||
(integer-in 0 23)
|
||||
(integer-in 1 31)
|
||||
(integer-in 1 12)
|
||||
exact-nonnegative-integer?)
|
||||
(any/c)
|
||||
. ->* .
|
||||
exact-integer?)]
|
||||
[date->julian/scalinger (date? . -> . exact-integer?)]
|
||||
[julian/scalinger->string (exact-integer? . -> . string?)])
|
||||
;; deprecated library, see `racket/date`
|
||||
|
||||
(define (current-date)
|
||||
(seconds->date (current-seconds)))
|
||||
|
||||
;; Support for Julian calendar added by Shriram;
|
||||
;; current version only works until 2099 CE Gregorian
|
||||
|
||||
(define date-display-format
|
||||
(make-parameter 'american))
|
||||
|
||||
(define (month/number->string x)
|
||||
(case x
|
||||
[(12) "December"] [(1) "January"] [(2) "February"]
|
||||
[(3) "March"] [(4) "April"] [(5) "May"]
|
||||
[(6) "June"] [(7) "July"] [(8) "August"]
|
||||
[(9) "September"] [(10) "October"] [(11) "November"]
|
||||
[else ""]))
|
||||
|
||||
(define (day/number->string x)
|
||||
(case x
|
||||
[(0) "Sunday"]
|
||||
[(1) "Monday"]
|
||||
[(2) "Tuesday"]
|
||||
[(3) "Wednesday"]
|
||||
[(4) "Thursday"]
|
||||
[(5) "Friday"]
|
||||
[(6) "Saturday"]
|
||||
[else ""]))
|
||||
|
||||
(define (add-zero n)
|
||||
(if (< n 10)
|
||||
(string-append "0" (number->string n))
|
||||
(number->string n)))
|
||||
|
||||
(define (date->string date [time? #f])
|
||||
(define year (number->string (date-year date)))
|
||||
(define num-month (number->string (date-month date)))
|
||||
(define week-day (day/number->string (date-week-day date)))
|
||||
(define week-day-num (date-week-day date))
|
||||
(define month (month/number->string (date-month date)))
|
||||
(define day (number->string (date-day date)))
|
||||
(define day-th
|
||||
(if (<= 11 (date-day date) 13)
|
||||
"th"
|
||||
(case (modulo (date-day date) 10)
|
||||
[(1) "st"]
|
||||
[(2) "nd"]
|
||||
[(3) "rd"]
|
||||
[(0 4 5 6 7 8 9) "th"])))
|
||||
(define hour (date-hour date))
|
||||
(define am-pm (if (>= hour 12) "pm" "am"))
|
||||
(define hour24 (add-zero hour))
|
||||
(define hour12
|
||||
(number->string
|
||||
(cond
|
||||
[(zero? hour) 12]
|
||||
[(> hour 12) (- hour 12)]
|
||||
[else hour])))
|
||||
(define minute (add-zero (date-minute date)))
|
||||
(define second (add-zero (date-second date)))
|
||||
(define-values
|
||||
(day-strs time-strs)
|
||||
(case (date-display-format)
|
||||
[(american)
|
||||
(values (list week-day ", " month " " day day-th ", " year)
|
||||
(list " " hour12 ":" minute ":" second am-pm))]
|
||||
[(chinese)
|
||||
(values
|
||||
(list year "/" num-month "/" day
|
||||
" \u661F\u671F" (case (date-week-day date)
|
||||
[(0) "\u5929"]
|
||||
[(1) "\u4E00"]
|
||||
[(2) "\u4E8C"]
|
||||
[(3) "\u4e09"]
|
||||
[(4) "\u56DB"]
|
||||
[(5) "\u4E94"]
|
||||
[(6) "\u516D"]
|
||||
[else ""]))
|
||||
(list " " hour24 ":" minute ":" second))]
|
||||
[(indian)
|
||||
(values (list day "-" num-month "-" year)
|
||||
(list " " hour12 ":" minute ":" second am-pm))]
|
||||
[(german)
|
||||
(values (list day ". "
|
||||
(case (date-month date)
|
||||
[(1) "Januar"]
|
||||
[(2) "Februar"]
|
||||
[(3) "M\344rz"]
|
||||
[(4) "April"]
|
||||
[(5) "Mai"]
|
||||
[(6) "Juni"]
|
||||
[(7) "Juli"]
|
||||
[(8) "August"]
|
||||
[(9) "September"]
|
||||
[(10) "Oktober"]
|
||||
[(11) "November"]
|
||||
[(12) "Dezember"]
|
||||
[else ""])
|
||||
" " year)
|
||||
(list ", " hour24 "." minute))]
|
||||
[(irish)
|
||||
(values (list week-day ", " day day-th " " month " " year)
|
||||
(list ", " hour12 ":" minute am-pm))]
|
||||
[(julian)
|
||||
(values (list (julian/scalinger->string
|
||||
(date->julian/scalinger date)))
|
||||
(list ", " hour24 ":" minute ":" second))]
|
||||
[(iso-8601)
|
||||
(values
|
||||
(list year "-" (add-zero (date-month date)) "-" (add-zero (date-day date)))
|
||||
(list " " hour24 ":" minute ":" second))]
|
||||
[(rfc2822)
|
||||
(values
|
||||
(list (substring week-day 0 3) ", " day " " (substring month 0 3) " " year)
|
||||
(list* " " hour24 ":" minute ":" second " "
|
||||
(let* ([delta (date-time-zone-offset date)]
|
||||
[hours (quotient delta 3600)]
|
||||
[minutes (modulo (quotient delta 60) 60)])
|
||||
(list
|
||||
(if (negative? delta) "-" "+")
|
||||
(add-zero (abs hours))
|
||||
(add-zero minutes)))))]
|
||||
[else (error 'date->string "unknown date-display-format: ~s"
|
||||
(date-display-format))]))
|
||||
(apply string-append
|
||||
(if time?
|
||||
(append day-strs time-strs)
|
||||
day-strs)))
|
||||
|
||||
(define (leap-year? year)
|
||||
(or (= 0 (modulo year 400))
|
||||
(and (= 0 (modulo year 4))
|
||||
(not (= 0 (modulo year 100))))))
|
||||
|
||||
;; it's not clear what months mean in this context -- use days
|
||||
(define-struct date-offset (second minute hour day year))
|
||||
|
||||
(define (fixup s x) (if (< s 0) (+ s x) s))
|
||||
(define (date- date1 date2)
|
||||
(define second (- (date-second date1) (date-second date2)))
|
||||
(define minute
|
||||
(+ (- (date-minute date1) (date-minute date2))
|
||||
(if (< second 0) -1 0)))
|
||||
(define hour
|
||||
(+ (- (date-hour date1) (date-hour date2))
|
||||
(if (< minute 0) -1 0)
|
||||
(cond [(equal? (date-dst? date1) (date-dst? date2)) 0]
|
||||
[(date-dst? date1) -1]
|
||||
[(date-dst? date2) 1])))
|
||||
(define day
|
||||
(+ (- (date-year-day date1) (date-year-day date2))
|
||||
(if (< hour 0) -1 0)))
|
||||
(define year
|
||||
(+ (- (date-year date1) (date-year date2))
|
||||
(if (< day 0) -1 0)))
|
||||
(make-date-offset
|
||||
(fixup second 60)
|
||||
(fixup minute 60)
|
||||
(fixup hour 24)
|
||||
(fixup day (if (leap-year? (date-year date1)) 366 365))
|
||||
year))
|
||||
|
||||
(define (one-entry b)
|
||||
(string-append
|
||||
(number->string (first b))
|
||||
" "
|
||||
(second b)
|
||||
(if (= 1 (first b)) "" "s")))
|
||||
(define (date-offset->string date [seconds? #f])
|
||||
(define fields
|
||||
(list (list (date-offset-year date) "year")
|
||||
(list (date-offset-day date) "day")
|
||||
(list (date-offset-hour date) "hour")
|
||||
(list (date-offset-minute date) "minute")
|
||||
(list (if seconds? (date-offset-second date) 0) "second")))
|
||||
(define non-zero-fields
|
||||
(filter (negate (compose (curry = 0) first)) fields))
|
||||
(match non-zero-fields
|
||||
[(list) ""]
|
||||
[(list one) (one-entry one)]
|
||||
[_
|
||||
(for/fold ([string ""])
|
||||
([b (in-list non-zero-fields)])
|
||||
(cond
|
||||
[(= 0 (first b)) string]
|
||||
[(string=? string "")
|
||||
(string-append "and "
|
||||
(one-entry b)
|
||||
string)]
|
||||
[else (string-append (one-entry b) ", " string)]))]))
|
||||
|
||||
(define (days-per-month year month)
|
||||
(cond
|
||||
[(and (= month 2) (leap-year? year)) 29]
|
||||
[(= month 2) 28]
|
||||
[(<= month 7) (+ 30 (modulo month 2))]
|
||||
[else (+ 30 (- 1 (modulo month 2)))]))
|
||||
|
||||
(define (find-extreme-date-seconds start offset)
|
||||
(let/ec found
|
||||
(letrec ([find-between
|
||||
(lambda (lo hi)
|
||||
(let ([mid (floor (/ (+ lo hi) 2))])
|
||||
(if (or (and (positive? offset) (= lo mid))
|
||||
(and (negative? offset) (= hi mid)))
|
||||
(found lo)
|
||||
(let ([mid-ok?
|
||||
(with-handlers ([exn:fail? (lambda (exn) #f)])
|
||||
(seconds->date mid)
|
||||
#t)])
|
||||
(if mid-ok?
|
||||
(find-between mid hi)
|
||||
(find-between lo mid))))))])
|
||||
(let loop ([lo start][offset offset])
|
||||
(let ([hi (+ lo offset)])
|
||||
(with-handlers ([exn:fail?
|
||||
(lambda (exn)
|
||||
; failed - must be between lo & hi
|
||||
(find-between lo hi))])
|
||||
(seconds->date hi))
|
||||
; succeeded; double offset again
|
||||
(loop hi (* 2 offset)))))))
|
||||
|
||||
(define get-min-seconds
|
||||
(let ([d (delay (find-extreme-date-seconds (current-seconds) -1))])
|
||||
(lambda ()
|
||||
(force d))))
|
||||
(define get-max-seconds
|
||||
(let ([d (delay (find-extreme-date-seconds (current-seconds) 1))])
|
||||
(lambda ()
|
||||
(force d))))
|
||||
|
||||
(define (date->seconds date [local-time? #t])
|
||||
(find-seconds
|
||||
(date-second date)
|
||||
(date-minute date)
|
||||
(date-hour date)
|
||||
(date-day date)
|
||||
(date-month date)
|
||||
(date-year date)
|
||||
local-time?))
|
||||
|
||||
(define (find-seconds sec min hour day month year [local-time? #t])
|
||||
(define (signal-error msg)
|
||||
(error 'find-secs (string-append
|
||||
msg
|
||||
" (inputs: ~a ~a ~a ~a ~a ~a)")
|
||||
sec min hour day month year))
|
||||
(let loop ([below-secs (get-min-seconds)]
|
||||
[secs (floor (/ (+ (get-min-seconds) (get-max-seconds)) 2))]
|
||||
[above-secs (get-max-seconds)])
|
||||
(let* ([date (seconds->date secs local-time?)]
|
||||
[compare
|
||||
(let loop ([inputs (list year month day
|
||||
hour min sec)]
|
||||
[tests (list (date-year date)
|
||||
(date-month date)
|
||||
(date-day date)
|
||||
(date-hour date)
|
||||
(date-minute date)
|
||||
(date-second date))])
|
||||
(cond
|
||||
[(null? inputs) 'equal]
|
||||
[else (let ([input (car inputs)]
|
||||
[test (car tests)])
|
||||
(if (= input test)
|
||||
(loop (cdr inputs) (cdr tests))
|
||||
(if (<= input test)
|
||||
'input-smaller
|
||||
'test-smaller)))]))])
|
||||
; (printf "~a ~a ~a\n" compare secs (date->string date))
|
||||
(cond
|
||||
[(eq? compare 'equal) secs]
|
||||
[(or (= secs below-secs) (= secs above-secs))
|
||||
(signal-error "non-existent date")]
|
||||
[(eq? compare 'input-smaller)
|
||||
(loop below-secs (floor (/ (+ secs below-secs) 2)) secs)]
|
||||
[(eq? compare 'test-smaller)
|
||||
(loop secs (floor (/ (+ above-secs secs) 2)) above-secs)]))))
|
||||
|
||||
;; date->julian/scalinger :
|
||||
;; date -> number [julian-day]
|
||||
|
||||
;; Note: This code is correct until 2099 CE Gregorian
|
||||
|
||||
(define (date->julian/scalinger date)
|
||||
(define day (date-day date))
|
||||
(define month (date-month date))
|
||||
(define d-year (date-year date))
|
||||
(define year (+ 4712 d-year))
|
||||
(define adj-year (if (< month 3) (sub1 year) year))
|
||||
(define cycle-number (quotient adj-year 4))
|
||||
(define cycle-position (remainder adj-year 4))
|
||||
(define base-day (+ (* 1461 cycle-number) (* 365 cycle-position)))
|
||||
(define month-day-number
|
||||
(case month
|
||||
((3) 0)
|
||||
((4) 31)
|
||||
((5) 61)
|
||||
((6) 92)
|
||||
((7) 122)
|
||||
((8) 153)
|
||||
((9) 184)
|
||||
((10) 214)
|
||||
((11) 245)
|
||||
((12) 275)
|
||||
((1) 306)
|
||||
((2) 337)))
|
||||
(define total-days (+ base-day month-day-number day))
|
||||
(define total-days/march-adjustment (+ total-days 59))
|
||||
(define gregorian-adjustment
|
||||
(cond
|
||||
((< adj-year 1700) 11)
|
||||
((< adj-year 1800) 12)
|
||||
(else 13)))
|
||||
(define final-date
|
||||
(- total-days/march-adjustment
|
||||
gregorian-adjustment))
|
||||
final-date)
|
||||
|
||||
;; julian/scalinger->string :
|
||||
;; number [julian-day] -> string [julian-day-format]
|
||||
|
||||
(define (julian/scalinger->string julian-day)
|
||||
(apply string-append
|
||||
(cons "JD "
|
||||
(reverse
|
||||
(let loop ((reversed-digits (map number->string
|
||||
(let loop ((jd julian-day))
|
||||
(if (zero? jd) null
|
||||
(cons (remainder jd 10)
|
||||
(loop (quotient jd 10))))))))
|
||||
(cond
|
||||
((or (null? reversed-digits)
|
||||
(null? (cdr reversed-digits))
|
||||
(null? (cdr (cdr reversed-digits)))
|
||||
(null? (cdr (cdr (cdr reversed-digits)))))
|
||||
(list (apply string-append (reverse reversed-digits))))
|
||||
(else (cons (apply string-append
|
||||
(list " "
|
||||
(caddr reversed-digits)
|
||||
(cadr reversed-digits)
|
||||
(car reversed-digits)))
|
||||
(loop (cdr (cdr (cdr reversed-digits))))))))))))
|
||||
(require racket/date)
|
||||
(provide (all-from-out racket/date))
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -3,6 +3,7 @@
|
|||
racket/local
|
||||
racket/bool
|
||||
racket/block
|
||||
racket/private/this-expression-source-directory
|
||||
(only racket/function
|
||||
identity)
|
||||
(only racket/base
|
||||
|
|
@ -10,7 +11,6 @@
|
|||
build-list
|
||||
build-vector
|
||||
compose)
|
||||
"private/this-expression-source-directory.rkt"
|
||||
(rename racket/base base-else else))
|
||||
|
||||
(require-for-syntax syntax/name
|
||||
|
|
|
|||
|
|
@ -1,931 +1,6 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base))
|
||||
|
||||
(provide inflate
|
||||
gunzip-through-ports
|
||||
gunzip)
|
||||
|
||||
#|
|
||||
|
||||
/* inflate.c -- Not copyrighted 1992 by Mark Adler
|
||||
version c10p1, 10 January 1993 */
|
||||
; Taken from the gzip source distribution
|
||||
; Translated directly from C (obviously) by Matthew, April 1997
|
||||
|
||||
/* You can do whatever you like with this source file, though I would
|
||||
prefer that if you modify it and redistribute it that you include
|
||||
comments to that effect with your name and the date. Thank you.
|
||||
[The history has been moved to the file ChangeLog.]
|
||||
; ChangeLog is distributed with the gzip source.
|
||||
*/
|
||||
|
||||
/*
|
||||
Inflate deflated (PKZIP's method 8 compressed) data. The compression
|
||||
method searches for as much of the current string of bytes (up to a
|
||||
length of 258) in the previous 32K bytes. If it doesn't find any
|
||||
matches (of at least length 3), it codes the next byte. Otherwise, it
|
||||
codes the length of the matched string and its distance backwards from
|
||||
the current position. There is a single Huffman code that codes both
|
||||
single bytes (called "literals") and match lengths. A second Huffman
|
||||
code codes the distance information, which follows a length code. Each
|
||||
length or distance code actually represents a base value and a number
|
||||
of "extra" (sometimes zero) bits to get to add to the base value. At
|
||||
the end of each deflated block is a special end-of-block (EOB) literal/
|
||||
length code. The decoding process is basically: get a literal/length
|
||||
code; if EOB then done; if a literal, emit the decoded byte; if a
|
||||
length then get the distance and emit the referred-to bytes from the
|
||||
sliding window of previously emitted data.
|
||||
|
||||
There are (currently) three kinds of inflate blocks: stored, fixed, and
|
||||
dynamic. The compressor deals with some chunk of data at a time, and
|
||||
decides which method to use on a chunk-by-chunk basis. A chunk might
|
||||
typically be 32K or 64K. If the chunk is uncompressible, then the
|
||||
"stored" method is used. In this case, the bytes are simply stored as
|
||||
is, eight bits per byte, with none of the above coding. The bytes are
|
||||
preceded by a count, since there is no longer an EOB code.
|
||||
|
||||
If the data is compressible, then either the fixed or dynamic methods
|
||||
are used. In the dynamic method, the compressed data is preceded by
|
||||
an encoding of the literal/length and distance Huffman codes that are
|
||||
to be used to decode this block. The representation is itself Huffman
|
||||
coded, and so is preceded by a description of that code. These code
|
||||
descriptions take up a little space, and so for small blocks, there is
|
||||
a predefined set of codes, called the fixed codes. The fixed method is
|
||||
used if the block codes up smaller that way (usually for quite small
|
||||
chunks), otherwise the dynamic method is used. In the latter case, the
|
||||
codes are customized to the probabilities in the current block, and so
|
||||
can code it much better than the pre-determined fixed codes.
|
||||
|
||||
The Huffman codes themselves are decoded using a mutli-level table
|
||||
lookup, in order to maximize the speed of decoding plus the speed of
|
||||
building the decoding tables. See the comments below that precede the
|
||||
lbits and dbits tuning parameters.
|
||||
*/
|
||||
|
||||
|
||||
/*
|
||||
Notes beyond the 1.93a appnote.txt:
|
||||
|
||||
1. Distance pointers never point before the beginning of the output
|
||||
stream.
|
||||
2. Distance pointers can point back across blocks, up to 32k away.
|
||||
3. There is an implied maximum of 7 bits for the bit length table and
|
||||
15 bits for the actual data.
|
||||
4. If only one code exists, then it is encoded using one bit. (Zero
|
||||
would be more efficient, but perhaps a little confusing.) If two
|
||||
codes exist, they are coded using one bit each (0 and 1).
|
||||
5. There is no way of sending zero distance codes--a dummy must be
|
||||
sent if there are none. (History: a pre 2.0 version of PKZIP would
|
||||
store blocks with no distance codes, but this was discovered to be
|
||||
too harsh a criterion.) Valid only for 1.93a. 2.04c does allow
|
||||
zero distance codes, which is sent as one code of zero bits in
|
||||
length.
|
||||
6. There are up to 286 literal/length codes. Code 256 represents the
|
||||
end-of-block. Note however that the static length tree defines
|
||||
288 codes just to fill out the Huffman codes. Codes 286 and 287
|
||||
cannot be used though, since there is no length base or extra bits
|
||||
defined for them. Similarly, there are up to 30 distance codes.
|
||||
However, static trees define 32 codes (all 5 bits) to fill out the
|
||||
Huffman codes, but the last two had better not show up in the data.
|
||||
7. Unzip can check dynamic Huffman blocks for complete code sets.
|
||||
The exception is that a single code would not be complete (see #4).
|
||||
8. The five bits following the block type is really the number of
|
||||
literal codes sent minus 257.
|
||||
9. Length codes 8,16,16 are interpreted as 13 length codes of 8 bits
|
||||
(1+6+6). Therefore, to output three times the length, you output
|
||||
three codes (1+1+1), whereas to output four times the same length,
|
||||
you only need two codes (1+3). Hmm.
|
||||
10. In the tree reconstruction algorithm, Code = Code + Increment
|
||||
only if BitLength(i) is not zero. (Pretty obvious.)
|
||||
11. Correction: 4 Bits: # of Bit Length codes - 4 (4 - 19)
|
||||
12. Note: length code 284 can represent 227-258, but length code 285
|
||||
really is 258. The last length deserves its own, short code
|
||||
since it gets used a lot in very redundant files. The length
|
||||
258 is special since 258 - 3 (the min match length) is 255.
|
||||
13. The literal/length and distance code bit lengths are read as a
|
||||
single stream of lengths. It is possible (and advantageous) for
|
||||
a repeat code (16, 17, or 18) to go across the boundary between
|
||||
the two sets of lengths.
|
||||
*/
|
||||
|
||||
|#
|
||||
|
||||
#|
|
||||
/* Huffman code lookup table entry--this entry is four bytes for machines
|
||||
that have 16-bit pointers (e.g. PC's in the small or medium model).
|
||||
Valid extra bits are 0..13. e == 15 is EOB (end of block), e == 16
|
||||
means that v is a literal, 16 < e < 32 means that v is a pointer to
|
||||
the next table, which codes e - 16 bits, and lastly e == 99 indicates
|
||||
an unused code. If a code with e == 99 is looked up, this implies an
|
||||
error in the data. */
|
||||
|#
|
||||
|
||||
(define-struct huft (e b v) #:mutable)
|
||||
|
||||
(define (huft-copy dest src)
|
||||
(set-huft-e! dest (huft-e src))
|
||||
(set-huft-b! dest (huft-b src))
|
||||
(set-huft-v! dest (huft-v src)))
|
||||
|
||||
(define (step start < end add1 f)
|
||||
(let loop ([i start])
|
||||
(when (< i end)
|
||||
(f i)
|
||||
(loop (add1 i)))))
|
||||
|
||||
(define (subvector v offset)
|
||||
(let* ([len (- (vector-length v) offset)]
|
||||
[new (make-vector len)])
|
||||
(step 0 < len add1
|
||||
(lambda (i)
|
||||
(vector-set! new i (vector-ref v (+ i offset)))))
|
||||
new))
|
||||
|
||||
(define (build-vector n p)
|
||||
(let ([v (make-vector n)])
|
||||
(step 0 < n add1 (lambda (i) (vector-set! v i (p i))))
|
||||
v))
|
||||
|
||||
;; We know that inflating will be a bottleneck, so we might as
|
||||
;; well help out the compiler...
|
||||
(define-syntax define-const
|
||||
(syntax-rules ()
|
||||
[(_ id v) (define-syntax id (make-const #'v))]))
|
||||
(define-for-syntax (make-const val)
|
||||
(make-set!-transformer
|
||||
(lambda (stx)
|
||||
(syntax-case stx (set!)
|
||||
[(set! id . _) (raise-syntax-error (syntax-e #'id)
|
||||
"cannot assign constant"
|
||||
stx)]
|
||||
[(id . rest) (quasisyntax/loc stx (#,val . rest))]
|
||||
[id val]))))
|
||||
|
||||
#|
|
||||
/* The inflate algorithm uses a sliding 32K byte window on the uncompressed
|
||||
stream to find repeated byte strings. This is implemented here as a
|
||||
circular buffer. The index is updated simply by incrementing and then
|
||||
and'ing with 0x7fff (32K-1). */
|
||||
|#
|
||||
|
||||
(define-const WSIZE 32768)
|
||||
|
||||
(define border
|
||||
(vector
|
||||
16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15))
|
||||
|
||||
(define cplens
|
||||
(vector
|
||||
3 4 5 6 7 8 9 10 11 13 15 17 19 23 27 31
|
||||
35 43 51 59 67 83 99 115 131 163 195 227 258 0 0))
|
||||
; /* note: see note #13 above about the 258 in this list. */
|
||||
(define cplext
|
||||
(vector
|
||||
0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2
|
||||
3 3 3 3 4 4 4 4 5 5 5 5 0 99 99)) ; /* 99==invalid */
|
||||
(define cpdist
|
||||
(vector
|
||||
1 2 3 4 5 7 9 13 17 25 33 49 65 97 129 193
|
||||
257 385 513 769 1025 1537 2049 3073 4097 6145
|
||||
8193 12289 16385 24577))
|
||||
(define cpdext
|
||||
(vector
|
||||
0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6
|
||||
7 7 8 8 9 9 10 10 11 11
|
||||
12 12 13 13))
|
||||
|
||||
(define mask_bits
|
||||
(vector
|
||||
#x0000
|
||||
#x0001 #x0003 #x0007 #x000f #x001f #x003f #x007f #x00ff
|
||||
#x01ff #x03ff #x07ff #x0fff #x1fff #x3fff #x7fff #xffff))
|
||||
|
||||
(define-const lbits 9) ; /* bits in base literal/length lookup table */
|
||||
(define-const dbits 6) ; /* bits in base distance lookup table */
|
||||
|
||||
|
||||
; /* If BMAX needs to be larger than 16, then h and x[] should be ulg. */
|
||||
(define-const BMAX 16) ; /* maximum bit length of any code (16 for explode) */
|
||||
(define-const N_MAX 288) ; /* maximum number of codes in any set */
|
||||
|
||||
(define (inflate input-port output-port)
|
||||
|
||||
(define slide (make-bytes WSIZE))
|
||||
(define wp 0)
|
||||
|
||||
(define (flush-output len)
|
||||
; write out the data
|
||||
(write-bytes slide output-port 0 len))
|
||||
|
||||
(define (check-flush)
|
||||
(when (= wp WSIZE)
|
||||
(flush-output WSIZE)
|
||||
(set! wp 0)))
|
||||
|
||||
#|
|
||||
/* Macros for inflate() bit peeking and grabbing.
|
||||
The usage is:
|
||||
|
||||
NEEDBITS(j)
|
||||
x = b & mask_bits[j];
|
||||
DUMPBITS(j)
|
||||
|
||||
where NEEDBITS makes sure that b has at least j bits in it, and
|
||||
DUMPBITS removes the bits from b. The macros use the variable k
|
||||
for the number of bits in b. Normally, b and k are register
|
||||
variables for speed, and are initialized at the beginning of a
|
||||
routine that uses these macros from a global bit buffer and count.
|
||||
|
||||
If we assume that EOB will be the longest code, then we will never
|
||||
ask for bits with NEEDBITS that are beyond the end of the stream.
|
||||
So, NEEDBITS should not read any more bytes than are needed to
|
||||
meet the request. Then no bytes need to be "returned" to the buffer
|
||||
at the end of the last block.
|
||||
|
||||
However, this assumption is not true for fixed blocks--the EOB code
|
||||
is 7 bits, but the other literal/length codes can be 8 or 9 bits.
|
||||
(The EOB code is shorter than other codes because fixed blocks are
|
||||
generally short. So, while a block always has an EOB, many other
|
||||
literal/length codes have a significantly lower probability of
|
||||
showing up at all.) However, by making the first table have a
|
||||
lookup of seven bits, the EOB code will be found in that first
|
||||
lookup, and so will not require that too many bits be pulled from
|
||||
the stream.
|
||||
*/
|
||||
|#
|
||||
|
||||
;; We can't read the bytes outright, because we may
|
||||
;; look ahead. Assume that we need no more than 32 bytes
|
||||
;; look ahead, and peek in 4096-byte blocks.
|
||||
(define MAX-LOOKAHEAD 32)
|
||||
(define BUFFER-SIZE 4096)
|
||||
(define buffer (make-bytes BUFFER-SIZE))
|
||||
(define buf-max 0) ; number of bytes in buffer
|
||||
(define buf-pos 0) ; index into buffer = number of used peeked bytes
|
||||
|
||||
(define bb 0) ; /* bit buffer */
|
||||
(define bk 0) ; /* bits in bit buffer */
|
||||
|
||||
(define (NEEDBITS n)
|
||||
(when (< bk n)
|
||||
(READBITS n)))
|
||||
(define (READBITS n)
|
||||
(if (= buf-pos buf-max)
|
||||
(begin
|
||||
(when (positive? buf-max)
|
||||
(read-bytes! buffer input-port 0 (- buf-max MAX-LOOKAHEAD))
|
||||
; (bytes-copy! buffer 0 buffer (- buf-max MAX-LOOKAHEAD) buf-max)
|
||||
(set! buf-pos MAX-LOOKAHEAD))
|
||||
(let ([got (peek-bytes-avail! buffer buf-pos #f input-port buf-pos BUFFER-SIZE)])
|
||||
(if (eof-object? got)
|
||||
(error 'inflate "unexpected end of file")
|
||||
(set! buf-max (+ buf-pos got))))
|
||||
(READBITS n))
|
||||
(let ([v (bytes-ref buffer buf-pos)])
|
||||
(set! buf-pos (add1 buf-pos))
|
||||
(set! bb (+ bb (arithmetic-shift v bk)))
|
||||
(set! bk (+ bk 8))
|
||||
(NEEDBITS n))))
|
||||
(define (DUMPBITS n)
|
||||
(set! bb (arithmetic-shift bb (- n)))
|
||||
(set! bk (- bk n)))
|
||||
|
||||
(define (GETBITS n)
|
||||
(NEEDBITS n)
|
||||
(begin0
|
||||
bb
|
||||
(DUMPBITS n)))
|
||||
|
||||
#|
|
||||
/*
|
||||
Huffman code decoding is performed using a multi-level table lookup.
|
||||
The fastest way to decode is to simply build a lookup table whose
|
||||
size is determined by the longest code. However, the time it takes
|
||||
to build this table can also be a factor if the data being decoded
|
||||
is not very long. The most common codes are necessarily the
|
||||
shortest codes, so those codes dominate the decoding time, and hence
|
||||
the speed. The idea is you can have a shorter table that decodes the
|
||||
shorter, more probable codes, and then point to subsidiary tables for
|
||||
the longer codes. The time it costs to decode the longer codes is
|
||||
then traded against the time it takes to make longer tables.
|
||||
|
||||
This results of this trade are in the variables lbits and dbits
|
||||
below. lbits is the number of bits the first level table for literal/
|
||||
length codes can decode in one step, and dbits is the same thing for
|
||||
the distance codes. Subsequent tables are also less than or equal to
|
||||
those sizes. These values may be adjusted either when all of the
|
||||
codes are shorter than that, in which case the longest code length in
|
||||
bits is used, or when the shortest code is *longer* than the requested
|
||||
table size, in which case the length of the shortest code in bits is
|
||||
used.
|
||||
|
||||
There are two different values for the two tables, since they code a
|
||||
different number of possibilities each. The literal/length table
|
||||
codes 286 possible values, or in a flat code, a little over eight
|
||||
bits. The distance table codes 30 possible values, or a little less
|
||||
than five bits, flat. The optimum values for speed end up being
|
||||
about one bit more than those, so lbits is 8+1 and dbits is 5+1.
|
||||
The optimum values may differ though from machine to machine, and
|
||||
possibly even between compilers. Your mileage may vary.
|
||||
*/
|
||||
|#
|
||||
|
||||
(define (huft_build
|
||||
b ; int vector /* code lengths in bits (all assumed <= BMAX) */
|
||||
n ; /* number of codes (assumed <= N_MAX) */
|
||||
s ; /* number of simple-valued codes (0..s-1) */
|
||||
d ; int vector /* list of base values for non-simple codes */
|
||||
e ; int vector /* list of extra bits for non-simple codes */
|
||||
m ; int /* maximum lookup bits, returns actual */
|
||||
incomp-ok?)
|
||||
; return: new-t new-m ok?
|
||||
|
||||
#|
|
||||
/* Given a list of code lengths and a maximum table size, make a set of
|
||||
tables to decode that set of codes. Return zero on success, one if
|
||||
the given code set is incomplete (the tables are still built in this
|
||||
case), two if the input is invalid (all zero length codes or an
|
||||
oversubscribed set of lengths), and three if not enough memory. */
|
||||
|#
|
||||
(define c (make-vector (add1 BMAX) 0))
|
||||
(define x (make-vector (add1 BMAX)))
|
||||
(define v (make-vector N_MAX))
|
||||
|
||||
(define final-y 0)
|
||||
(define t-result #f)
|
||||
|
||||
; (printf "n: ~s\n" n)
|
||||
|
||||
(let/ec return
|
||||
|
||||
#|
|
||||
(if (= n 270)
|
||||
(step 0 < n add1
|
||||
(lambda (i) (printf "b[~a] = ~a\n" i (vector-ref b i)))))
|
||||
|#
|
||||
|
||||
(step 0 < n add1
|
||||
(lambda (i)
|
||||
(let ([pos (vector-ref b i)])
|
||||
(vector-set! c pos (add1 (vector-ref c pos))))))
|
||||
|
||||
(when (= n (vector-ref c 0))
|
||||
; (printf "zero\n")
|
||||
(return #f 0 #t))
|
||||
|
||||
#|
|
||||
(when (= n 270)
|
||||
(step 0 <= BMAX add1
|
||||
(lambda (i)
|
||||
(printf "c[~s]: ~s\n" i (vector-ref c i)))))
|
||||
|#
|
||||
|
||||
; /* Find minimum and maximum length, bound m-result by those */
|
||||
(let* ([j ; min-code-length
|
||||
(let loop ([j 1])
|
||||
(cond
|
||||
[(> j BMAX) j]
|
||||
[(positive? (vector-ref c j)) j]
|
||||
[else (loop (add1 j))]))]
|
||||
[k j]
|
||||
[i ; max-code-length
|
||||
(let loop ([i BMAX])
|
||||
(cond
|
||||
[(zero? i) 0]
|
||||
[(positive? (vector-ref c i)) i]
|
||||
[else (loop (sub1 i))]))]
|
||||
[g i]
|
||||
[l (min (max m j) i)]
|
||||
[m-result l])
|
||||
; (printf "min: ~s max: ~s\n" k g)
|
||||
; /* Adjust last length count to fill out codes, if needed */
|
||||
(let-values ([(y j)
|
||||
(let loop ([y (arithmetic-shift 1 j)][j j])
|
||||
(if (>= j i)
|
||||
(values y j)
|
||||
(let ([new-y (- y (vector-ref c j))])
|
||||
(if (negative? new-y)
|
||||
(begin
|
||||
(error 'inflate
|
||||
"bad input: more codes than bits")
|
||||
(return null m-result #f))
|
||||
(loop (* new-y 2) (add1 j))))))])
|
||||
; (printf "loop y: ~s\n" y)
|
||||
(let ([y (- y (vector-ref c i))])
|
||||
(when (negative? y)
|
||||
(error 'inflate "bad input: more codes than bits")
|
||||
(return #f m-result #f))
|
||||
; (printf "set c[~s] ~s + ~s\n" i (vector-ref c i) y)
|
||||
(vector-set! c i (+ (vector-ref c i) y))
|
||||
(set! final-y y)))
|
||||
; /* Generate starting offsets into the value table for each length */
|
||||
(vector-set! x 1 0)
|
||||
(let* ([j (let loop ([i (sub1 i)][x-pos 2][c-pos 1][j 0])
|
||||
(if (zero? i)
|
||||
j
|
||||
(let ([v (vector-ref c c-pos)])
|
||||
(vector-set! x x-pos (+ j v))
|
||||
(loop (sub1 i) (add1 x-pos) (add1 c-pos) (+ j v)))))])
|
||||
; /* Make a table of values in order of bit lengths */
|
||||
(let loop ([i 0][b-pos 0])
|
||||
(let ([j (vector-ref b b-pos)])
|
||||
(unless (zero? j)
|
||||
(let ([xj (vector-ref x j)])
|
||||
(vector-set! x j (add1 xj))
|
||||
(vector-set! v xj i)))
|
||||
(let ([new-i (add1 i)])
|
||||
(when (< new-i n)
|
||||
(loop new-i (add1 b-pos))))))
|
||||
|
||||
; /* Generate the Huffman codes and for each, make the table entries */
|
||||
(vector-set! x 0 0) ; /* first Huffman code is zero */
|
||||
(let ([v-pos 0] ; /* grab values in bit order */
|
||||
[i 0] ; /* the Huffman code of length k bits for value *p */
|
||||
[h -1] ; /* no tables yet--level -1 */
|
||||
[w (- l)] ; /* bits decoded == (l * h) */
|
||||
[u (make-vector BMAX)] ; /* table stack */
|
||||
[q null] ; /* points to current table */
|
||||
[z 0] ; /* number of entries in current table */
|
||||
[r (make-huft 0 0 0)]) ; /* table entry for structure assignment */
|
||||
; /* go through the bit lengths (k already is bits in shortest code) */
|
||||
(let k-loop ([k k])
|
||||
; (printf "k: ~s\n" k)
|
||||
(when (<= k g)
|
||||
(let ([a (vector-ref c k)])
|
||||
(let a-loop ([a (sub1 a)])
|
||||
(unless (negative? a)
|
||||
; (printf "a: ~s\n" a)
|
||||
; /* here i is the Huffman code of length k bits for value *p */
|
||||
; /* make tables up to required level */
|
||||
(let kwl-loop ()
|
||||
(when (> k (+ w l))
|
||||
(set! h (add1 h))
|
||||
(set! w (+ w l)) ; /* previous table always l bits */
|
||||
|
||||
; /* compute minimum size table less than or equal to l bits */
|
||||
(set! z (min (- g w) l)) ; /* upper limit on table size */
|
||||
|
||||
; (printf "z: ~s k: ~s w: ~s\n" z k w)
|
||||
|
||||
(let* ([j (- k w)]
|
||||
[f (arithmetic-shift 1 j)])
|
||||
(when (> f (add1 a)) ; /* try a k-w bit table */
|
||||
; /* too few codes for k-w bit table */
|
||||
(set! f (- f a 1)) ; /* deduct codes from patterns left */
|
||||
; /* try smaller tables up to z bits */
|
||||
(let loop ([c-pos k])
|
||||
(set! j (add1 j))
|
||||
(when (< j z)
|
||||
(set! f (* f 2))
|
||||
(let* ([c-pos (add1 c-pos)]
|
||||
[cv (vector-ref c c-pos)])
|
||||
(if (<= f cv)
|
||||
(void) ; /* enough codes to use up j bits */
|
||||
(begin
|
||||
(set! f (- f cv)) ; /* else deduct codes from patterns */
|
||||
(loop c-pos)))))))
|
||||
(set! z (arithmetic-shift 1 j)) ; /* table entries for j-bit table */
|
||||
|
||||
; /* allocate and link in new table */
|
||||
; (printf "alloc: ~a\n" z)
|
||||
(set! q (build-vector z (lambda (i) (make-huft 0 0 0))))
|
||||
|
||||
(when (not t-result)
|
||||
(set! t-result q))
|
||||
|
||||
(vector-set! u h q)
|
||||
|
||||
; /* connect to last table, if there is one */
|
||||
(unless (zero? h)
|
||||
(vector-set! x h i) ; /* save pattern for backing up */
|
||||
(set-huft-b! r l) ; /* bits to dump before this table */
|
||||
(set-huft-e! r (+ j 16)); /* bits in this table */
|
||||
(set-huft-v! r q) ; /* pointer to this table */
|
||||
(set! j (arithmetic-shift i (- l w)))
|
||||
; /* connect to last table: */
|
||||
(huft-copy (vector-ref (vector-ref u (sub1 h)) j) r)))
|
||||
|
||||
(kwl-loop)))
|
||||
|
||||
(set-huft-b! r (- k w)) ; cast uch (- k w) if needed
|
||||
(if (>= v-pos n)
|
||||
(set-huft-e! r 99) ; /* out of values--invalid code */
|
||||
(let ([vv (vector-ref v v-pos)])
|
||||
; (printf "*p: ~s s: ~s\n" vv s)
|
||||
(if (< vv s)
|
||||
(begin
|
||||
(set-huft-e! r (if (< vv 256) 16 15)) ; /* 256 is end-of-block code */
|
||||
(set-huft-v! r vv)) ; /* simple code is just the value */
|
||||
(begin
|
||||
(set-huft-e! r (vector-ref e (- vv s))) ; /* non-simple--look up in lists */
|
||||
(set-huft-v! r (vector-ref d (- vv s)))))
|
||||
(set! v-pos (add1 v-pos))))
|
||||
; /* fill code-like entries with r */
|
||||
; (printf "i: ~s w: ~s k: ~s\n" i w k)
|
||||
(let ([f (arithmetic-shift 1 (- k w))]) ; /* i repeats in table every f entries */
|
||||
(let loop ([j (arithmetic-shift i (- w))])
|
||||
(when (< j z)
|
||||
(huft-copy (vector-ref q j) r)
|
||||
(loop (+ j f)))))
|
||||
; /* backwards increment the k-bit code i */
|
||||
(let loop ([j (arithmetic-shift 1 (sub1 k))])
|
||||
(if (positive? (bitwise-and i j))
|
||||
(begin
|
||||
(set! i (bitwise-xor i j))
|
||||
(loop (arithmetic-shift j -1)))
|
||||
(set! i (bitwise-xor i j))))
|
||||
; /* backup over finished tables */
|
||||
(let loop ()
|
||||
(unless (= (vector-ref x h) (bitwise-and i (sub1 (arithmetic-shift 1 w))))
|
||||
(set! h (sub1 h)) ; /* don't need to update q */
|
||||
(set! w (- w l))
|
||||
(loop)))
|
||||
|
||||
(a-loop (sub1 a))))
|
||||
(k-loop (add1 k)))))
|
||||
|
||||
; /* Return #f as third if we were given an incomplete table */
|
||||
; (printf "done: ~s ~s\n" final-y g)
|
||||
(let ([ok? (or incomp-ok?
|
||||
(not (and (not (zero? final-y))
|
||||
(not (= g 1)))))])
|
||||
(unless ok?
|
||||
(error 'inflate "incomplete table"))
|
||||
(values t-result m-result ok?)))))))
|
||||
|
||||
(define (inflate_codes
|
||||
tl ; vector of hufts ; /* literal/length tables */
|
||||
td ; vector of hufts ; /* distance decoder tables */
|
||||
bl ; /* number of bits decoded by tl */
|
||||
bd) ; /* number of bits decoded by td[] */
|
||||
; /* inflate (decompress) the codes in a deflated (compressed) block.
|
||||
; Return an error code or zero if it all goes ok. */
|
||||
|
||||
; /* inflate the coded data */
|
||||
|
||||
; /* precompute masks for speed */
|
||||
(define ml (vector-ref mask_bits bl))
|
||||
(define md (vector-ref mask_bits bd))
|
||||
(define t (void))
|
||||
(define e 0)
|
||||
(define n 0)
|
||||
(define d 0)
|
||||
|
||||
(let/ec return
|
||||
|
||||
(define (jump-to-next)
|
||||
(let loop ()
|
||||
(when (= e 99)
|
||||
(error 'inflate "bad inflate code")
|
||||
(return #f))
|
||||
(DUMPBITS (huft-b t))
|
||||
(set! e (- e 16))
|
||||
(NEEDBITS e)
|
||||
(set! t (vector-ref (huft-v t) (bitwise-and bb (vector-ref mask_bits e))))
|
||||
(set! e (huft-e t))
|
||||
(when (> e 16)
|
||||
(loop))))
|
||||
|
||||
(let loop () ; /* do until end of block */
|
||||
(NEEDBITS bl)
|
||||
(set! t (vector-ref tl (bitwise-and bb ml)))
|
||||
; (printf "t->e: ~s t->b: ~s\n" (huft-e t) (huft-b t))
|
||||
(set! e (huft-e t))
|
||||
(when (> e 16)
|
||||
(jump-to-next))
|
||||
(DUMPBITS (huft-b t))
|
||||
; (printf "e: ~s\n" e)
|
||||
(if (= e 16) ; /* then it's a literal */
|
||||
(begin
|
||||
(bytes-set! slide wp (huft-v t))
|
||||
(set! wp (add1 wp))
|
||||
(check-flush))
|
||||
(begin ; /* it's an EOB or a length */
|
||||
; /* exit if end of block */
|
||||
(when (= e 15)
|
||||
(return #t))
|
||||
|
||||
; /* get length of block to copy */
|
||||
(NEEDBITS e)
|
||||
(set! n (+ (huft-v t) (bitwise-and bb (vector-ref mask_bits e))))
|
||||
(DUMPBITS e)
|
||||
; (printf "n: ~s bb: ~s md: ~s\n" n bb md)
|
||||
|
||||
; /* decode distance of block to copy */
|
||||
(NEEDBITS bd)
|
||||
(set! t (vector-ref td (bitwise-and bb md)))
|
||||
; (printf "t->e: ~s t->b: ~s\n" (huft-e t) (huft-b t))
|
||||
(set! e (huft-e t))
|
||||
; (printf "e: ~s\n" e)
|
||||
(when (> e 16)
|
||||
(jump-to-next))
|
||||
(DUMPBITS (huft-b t))
|
||||
; (printf "e: ~s\n" e)
|
||||
|
||||
(NEEDBITS e)
|
||||
(set! d (modulo (- wp (huft-v t) (bitwise-and bb (vector-ref mask_bits e))) WSIZE))
|
||||
(DUMPBITS e)
|
||||
|
||||
; (printf "wp: ~s t->v: ~s d: ~s\n" wp (huft-v t) d)
|
||||
|
||||
; /* do the copy */
|
||||
(let loop ()
|
||||
(set! d (bitwise-and d (sub1 WSIZE)))
|
||||
(set! e (min n (- WSIZE (max d wp))))
|
||||
(set! n (- n e))
|
||||
(let loop ()
|
||||
(bytes-set! slide wp (bytes-ref slide d))
|
||||
(set! wp (add1 wp))
|
||||
(set! d (add1 d))
|
||||
(set! e (sub1 e))
|
||||
(unless (zero? e)
|
||||
(loop)))
|
||||
(check-flush)
|
||||
(unless (zero? n)
|
||||
(loop)))))
|
||||
(loop))))
|
||||
|
||||
(define (inflate_stored)
|
||||
; /* "decompress" an inflated type 0 (stored) block. */
|
||||
|
||||
(let/ec return
|
||||
|
||||
; /* go to byte boundary */
|
||||
(DUMPBITS (bitwise-and bk 7))
|
||||
|
||||
; /* get the length and its complement */
|
||||
(NEEDBITS 16)
|
||||
(let ([n (bitwise-and bb #xffff)])
|
||||
(DUMPBITS 16)
|
||||
(NEEDBITS 16)
|
||||
(unless (= n (bitwise-and (bitwise-not bb) #xffff))
|
||||
(error 'inflate "error in compressed data")
|
||||
(return #f)) ; /* error in compressed data */
|
||||
(DUMPBITS 16)
|
||||
|
||||
; /* read and output the compressed data */
|
||||
(let loop ([n n])
|
||||
(when (positive? n)
|
||||
(NEEDBITS 8)
|
||||
(bytes-set! slide wp (bitwise-and bb #xff))
|
||||
(set! wp (add1 wp))
|
||||
(check-flush)
|
||||
(DUMPBITS 8)
|
||||
(loop (sub1 n))))
|
||||
|
||||
#t)))
|
||||
|
||||
(define (inflate_fixed)
|
||||
; /* decompress an inflated type 1 (fixed Huffman codes) block. We should
|
||||
; either replace this with a custom decoder, or at least precompute the
|
||||
; Huffman tables. */
|
||||
|
||||
(define l (make-vector 288))
|
||||
|
||||
(step 0 < 144 add1 (lambda (i) (vector-set! l i 8)))
|
||||
(step 144 < 256 add1 (lambda (i) (vector-set! l i 9)))
|
||||
(step 256 < 280 add1 (lambda (i) (vector-set! l i 7)))
|
||||
(step 280 < 288 add1 (lambda (i) (vector-set! l i 8)))
|
||||
|
||||
(let-values ([(tl bl ok?)
|
||||
(huft_build l 288 257 cplens cplext 7 #f)])
|
||||
|
||||
(if (not ok?)
|
||||
#f
|
||||
(begin
|
||||
(step 0 < 30 add1 (lambda (i) (vector-set! l i 5)))
|
||||
(let-values ([(td bd ok?)
|
||||
(huft_build l 30 0 cpdist cpdext 5 #t)])
|
||||
(if (not ok?)
|
||||
#f
|
||||
; /* decompress until an end-of-block code */
|
||||
(inflate_codes tl td bl bd)))))))
|
||||
|
||||
(define (inflate_dynamic)
|
||||
; /* decompress an inflated type 2 (dynamic Huffman codes) block. */
|
||||
|
||||
(begin ; let/ec return
|
||||
|
||||
; /* read in table lengths */
|
||||
; (define junk1 (begin (NEEDBITS 5) (printf "~s ~s\n" bb bk)))
|
||||
(define nl (+ 257 (bitwise-and (GETBITS 5) #x1f)))
|
||||
; (define junk2 (begin (NEEDBITS 5) (printf "~s ~s\n" bb bk)))
|
||||
(define nd (+ 1 (bitwise-and (GETBITS 5) #x1f)))
|
||||
; (define junk3 (begin (NEEDBITS 4) (printf "~s ~s\n" bb bk)))
|
||||
(define nb (+ 4 (bitwise-and (GETBITS 4) #xf)))
|
||||
|
||||
; (define junk8 (printf "~s ~s ~s\n" nl nd nb))
|
||||
|
||||
(define ll (make-vector (+ 286 30)))
|
||||
(define i 0)
|
||||
(define l 0)
|
||||
|
||||
(if (or (> nl 286) (> nd 30))
|
||||
(begin
|
||||
(error 'inflate "bad lengths")
|
||||
#f) ; /* bad lengths */
|
||||
(begin
|
||||
; /* read in bit-length-code lengths */
|
||||
(step 0 < nb add1
|
||||
(lambda (j)
|
||||
(vector-set! ll (vector-ref border j) (bitwise-and (GETBITS 3) 7))))
|
||||
(step nb < 19 add1
|
||||
(lambda (j)
|
||||
(vector-set! ll (vector-ref border j) 0)))
|
||||
|
||||
; /* build decoding table for trees--single level, 7 bit lookup */
|
||||
(let-values ([(tl bl ok?)
|
||||
(huft_build ll 19 19 null null 7 #f)])
|
||||
(if (not ok?)
|
||||
#f
|
||||
(begin
|
||||
; /* read in literal and distance code lengths */
|
||||
(let ([n (+ nl nd)]
|
||||
[m (vector-ref mask_bits bl)])
|
||||
; (printf "bl: ~s\n" bl)
|
||||
(set! i 0)
|
||||
(set! l 0)
|
||||
(let loop ()
|
||||
(when (< i n)
|
||||
(NEEDBITS bl)
|
||||
(let* ([pos (bitwise-and bb m)]
|
||||
[td (vector-ref tl pos)]
|
||||
[dmp (huft-b td)]
|
||||
[j (huft-v td)]
|
||||
[set-lit
|
||||
(lambda (j l)
|
||||
(when (> (+ i j) n)
|
||||
(error 'inflate "bad hop")
|
||||
#;(return #f))
|
||||
(let loop ([j j])
|
||||
(unless (zero? j)
|
||||
(vector-set! ll i l)
|
||||
(set! i (add1 i))
|
||||
(loop (sub1 j)))))])
|
||||
(DUMPBITS dmp)
|
||||
; (printf "pos: ~s j: ~s l: ~s i: ~s\n" pos j l i)
|
||||
(cond
|
||||
[(< j 16) ; /* length of code in bits (0..15) */
|
||||
(vector-set! ll i j)
|
||||
(set! l j) ; /* save last length in l */
|
||||
(set! i (add1 i))]
|
||||
[(= j 16) ; /* repeat last length 3 to 6 times */
|
||||
(let ([j (+ 3 (bitwise-and (GETBITS 2) 3))])
|
||||
(set-lit j l))]
|
||||
[(= j 17) ; /* 3 to 10 zero length codes */
|
||||
(let ([j (+ 3 (bitwise-and (GETBITS 3) 7))])
|
||||
(set-lit j 0)
|
||||
(set! l 0))]
|
||||
[else ; /* j == 18: 11 to 138 zero length codes */
|
||||
(let ([j (+ 11 (bitwise-and (GETBITS 7) #x7f))])
|
||||
(set-lit j 0)
|
||||
(set! l 0))]))
|
||||
(loop)))
|
||||
|
||||
; /* build the decoding tables for literal/length and distance codes */
|
||||
(let-values ([(tl bl ok?)
|
||||
(huft_build ll nl 257 cplens cplext lbits #f)])
|
||||
(if (not ok?)
|
||||
(begin
|
||||
(error 'inflate "incomplete code set")
|
||||
#f) ; /* incomplete code set */
|
||||
(let-values ([(td bd ok?)
|
||||
(huft_build (subvector ll nl) nd 0 cpdist cpdext dbits #f)])
|
||||
(if (not ok?)
|
||||
(begin
|
||||
(error 'inflate "incomplete code set")
|
||||
#f) ; /* incomplete code set */
|
||||
; /* decompress until an end-of-block code */
|
||||
(inflate_codes tl td bl bd)))))))))))))
|
||||
|
||||
(define (inflate_block)
|
||||
; return values: /* last block flag */ ok?
|
||||
; /* decompress an inflated block */
|
||||
|
||||
(define e-result (bitwise-and (GETBITS 1) 1))
|
||||
|
||||
; /* read in block type */
|
||||
(define t (bitwise-and (GETBITS 2) 3))
|
||||
|
||||
(values e-result
|
||||
(case t
|
||||
[(2) (inflate_dynamic)]
|
||||
[(0) (inflate_stored)]
|
||||
[(1) (inflate_fixed)]
|
||||
[else (error 'inflate "unknown inflate type")
|
||||
#f])))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; inflate starts here
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
; /* decompress an inflated entry */
|
||||
; /* initialize window, bit buffer */
|
||||
(set! wp 0)
|
||||
(set! bk 0)
|
||||
(set! bb 0)
|
||||
|
||||
|
||||
; /* decompress until the last block */
|
||||
(let loop ()
|
||||
(let-values ([(e ok?) (inflate_block)])
|
||||
(if ok?
|
||||
(if (zero? e)
|
||||
(loop)
|
||||
(begin
|
||||
; /* Undo too much lookahead. The next read will be byte aligned so we
|
||||
; * can discard unused bits in the last meaningful byte.
|
||||
; */
|
||||
(let loop ()
|
||||
(when (>= bk 8)
|
||||
(set! bk (- bk 8))
|
||||
(set! buf-pos (sub1 buf-pos))
|
||||
(loop)))
|
||||
(read-bytes! buffer input-port 0 buf-pos)
|
||||
(flush-output wp)
|
||||
#t = (void)))
|
||||
#f))))
|
||||
|
||||
(define make-small-endian
|
||||
(case-lambda
|
||||
[(a b) (+ a (arithmetic-shift b 8))]
|
||||
[(a b c d) (+ a
|
||||
(arithmetic-shift b 8)
|
||||
(arithmetic-shift c 16)
|
||||
(arithmetic-shift d 24))]))
|
||||
|
||||
(define (do-gunzip in out name-filter)
|
||||
(let ([header1 (read-byte in)]
|
||||
[header2 (read-byte in)])
|
||||
(unless (and (= header1 #o037) (= header2 #o213))
|
||||
(error 'gnu-unzip "bad header")))
|
||||
(let ([compression-type (read-byte in)])
|
||||
(unless (= compression-type #o010)
|
||||
(error 'gnu-unzip "unknown compression type")))
|
||||
(let* ([flags (read-byte in)]
|
||||
[ascii? (positive? (bitwise-and flags #b1))]
|
||||
[continuation? (positive? (bitwise-and flags #b10))]
|
||||
[has-extra-field? (positive? (bitwise-and flags #b100))]
|
||||
[has-original-filename? (positive? (bitwise-and flags #b1000))]
|
||||
[has-comment? (positive? (bitwise-and flags #b10000))]
|
||||
[encrypted? (positive? (bitwise-and flags #b100000))])
|
||||
(when encrypted?
|
||||
(error 'gnu-unzip "cannot unzip encrypted file"))
|
||||
(when continuation?
|
||||
(error 'gnu-unzip "cannot handle multi-part files"))
|
||||
(let ([unix-mod-time (make-small-endian (read-byte in) (read-byte in)
|
||||
(read-byte in) (read-byte in))]
|
||||
[extra-flags (read-byte in)]
|
||||
[source-os (read-byte in)])
|
||||
(when continuation?
|
||||
(let ([part-number (make-small-endian (read-byte in) (read-byte in))])
|
||||
'ok))
|
||||
(when has-extra-field?
|
||||
(let ([len (make-small-endian (read-byte in) (read-byte in))])
|
||||
(let loop ([len len])
|
||||
(unless (zero? len)
|
||||
(read-byte in)
|
||||
(loop (sub1 len))))))
|
||||
(let* ([read-null-term-string
|
||||
(lambda ()
|
||||
(let loop ([s null])
|
||||
(let ([r (read-byte in)])
|
||||
(if (zero? r)
|
||||
(list->bytes (reverse s))
|
||||
(loop (cons r s))))))]
|
||||
[original-filename (and has-original-filename?
|
||||
(read-null-term-string))]
|
||||
[comment (and has-comment? (read-null-term-string))])
|
||||
(when encrypted?
|
||||
(let loop ([n 12])
|
||||
(unless (zero? n)
|
||||
(read-byte in)
|
||||
(loop (sub1 n)))))
|
||||
|
||||
(let-values ([(out close?) (if out
|
||||
(values out #f)
|
||||
(let-values ([(fn orig?)
|
||||
(if original-filename
|
||||
(values (bytes->path original-filename) #t)
|
||||
(values "unzipped" #f))])
|
||||
(values (open-output-file (name-filter fn orig?) #:exists 'truncate)
|
||||
#t)))])
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda () (begin0 (inflate in out)
|
||||
(read-bytes 8 in))) ; read CRC32 and ISIZE
|
||||
(lambda () (when close? (close-output-port out)))))))))
|
||||
|
||||
(define (gunzip-through-ports in out)
|
||||
(do-gunzip in out void))
|
||||
|
||||
(define gunzip
|
||||
(case-lambda
|
||||
[(src) (gunzip src (lambda (name from-file?) name))]
|
||||
[(src name-filter)
|
||||
(let ([in (open-input-file src #:mode 'binary)])
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda () (do-gunzip in #f name-filter))
|
||||
(lambda () (close-input-port in))))]))
|
||||
;; deprecated library, see `file/gunzip`
|
||||
|
||||
(require file/gunzip)
|
||||
(provide (all-from-out file/gunzip))
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,207 +1,6 @@
|
|||
#lang racket/base
|
||||
(provide process
|
||||
process*
|
||||
process/ports
|
||||
process*/ports
|
||||
system
|
||||
system*
|
||||
system/exit-code
|
||||
system*/exit-code)
|
||||
|
||||
(require "private/streams.rkt")
|
||||
;; deprecated library, see `racket/system`
|
||||
|
||||
;; Helpers: ----------------------------------------
|
||||
|
||||
(define (shell-path/args who argstr)
|
||||
(case (system-type)
|
||||
[(unix macosx) (append '("/bin/sh" "-c") (list argstr))]
|
||||
[(windows) (let ([cmd
|
||||
(let ([d (find-system-path 'sys-dir)])
|
||||
(let ([cmd (build-path d "cmd.exe")])
|
||||
(if (file-exists? cmd)
|
||||
cmd
|
||||
(let ([cmd (build-path d "command.com")])
|
||||
(if (file-exists? cmd)
|
||||
cmd
|
||||
;; One last try: up a dir
|
||||
(build-path d 'up "command.com"))))))])
|
||||
(list cmd
|
||||
'exact
|
||||
(format "~a /c \"~a\"" (path->string cmd) argstr)))]
|
||||
[else (raise-mismatch-error
|
||||
who
|
||||
(format "~a: don't know what shell to use for platform: " who)
|
||||
(system-type))]))
|
||||
|
||||
(define (check-exe who exe)
|
||||
(unless (path-string? exe)
|
||||
(raise-argument-error who "path-string?" exe))
|
||||
exe)
|
||||
|
||||
(define (path-or-ok-string? s)
|
||||
;; use `path-string?' t check for nul characters in a string,
|
||||
;; but allow the empty string (which is not an ok path), too:
|
||||
(or (path-string? s)
|
||||
(equal? "" s)))
|
||||
|
||||
(define (string-no-nuls? s)
|
||||
(and (string? s) (path-or-ok-string? s)))
|
||||
|
||||
(define (bytes-no-nuls? s)
|
||||
(and (bytes? s)
|
||||
(not (regexp-match? #rx#"\0" s))))
|
||||
|
||||
(define (check-args who args)
|
||||
(cond
|
||||
[(null? args) (void)]
|
||||
[(eq? (car args) 'exact)
|
||||
(when (null? (cdr args))
|
||||
(raise-mismatch-error
|
||||
who
|
||||
"expected a single string argument after: "
|
||||
(car args)))
|
||||
(unless (and (>= 2 (length args))
|
||||
(string? (cadr args))
|
||||
(path-or-ok-string? (cadr args)))
|
||||
(raise-mismatch-error who
|
||||
"expected a single string argument after 'exact, given: "
|
||||
(cadr args)))
|
||||
(when (pair? (cddr args))
|
||||
(raise-mismatch-error
|
||||
who
|
||||
"expected a single string argument after 'exact, given additional argument: "
|
||||
(caddr args)))]
|
||||
[else
|
||||
(for ([s (in-list args)])
|
||||
(unless (or (path-or-ok-string? s)
|
||||
(bytes-no-nuls? s))
|
||||
(raise-argument-error
|
||||
who
|
||||
(string-append "(or/c path-string?\n"
|
||||
" (and/c bytes? (lambda (bs) (not (memv 0 (bytes->list bs))))))")
|
||||
s)))])
|
||||
args)
|
||||
|
||||
(define (check-command who str)
|
||||
(unless (or (string-no-nuls? str)
|
||||
(bytes-no-nuls? str))
|
||||
(raise-argument-error
|
||||
who
|
||||
(string-append "(or/c (and/c string? (lambda (s) (not (memv #\\nul (string->list s)))))\n"
|
||||
" (and/c bytes? (lambda (bs) (not (memv 0 (bytes->list bs))))))")
|
||||
str)))
|
||||
|
||||
;; Old-style functions: ----------------------------------------
|
||||
|
||||
(define (do-process*/ports who cout cin cerr exe . args)
|
||||
(let-values ([(subp out in err) (apply subprocess
|
||||
(if-stream-out who cout)
|
||||
(if-stream-in who cin)
|
||||
(if-stream-out who cerr #t)
|
||||
(check-exe who exe)
|
||||
(check-args who args))]
|
||||
[(it-ready) (make-semaphore)])
|
||||
(let ([so (streamify-out cout out)]
|
||||
[si (streamify-in cin in (lambda (ok?)
|
||||
(if ok?
|
||||
(semaphore-post it-ready)
|
||||
(semaphore-wait it-ready))))]
|
||||
[se (streamify-out cerr err)]
|
||||
[aport (lambda (x) (and (port? x) x))])
|
||||
(when (thread? si)
|
||||
;; Wait for process to end, then stop copying input:
|
||||
(thread (lambda ()
|
||||
(sync subp si)
|
||||
(semaphore-wait it-ready)
|
||||
(break-thread si))))
|
||||
(let ([threads-still-going?
|
||||
(lambda ()
|
||||
(ormap (lambda (s) (and (thread? s) (thread-running? s)))
|
||||
(list so si se)))])
|
||||
(define (control m)
|
||||
(case m
|
||||
[(status)
|
||||
(let ([s (subprocess-status subp)])
|
||||
(cond [(or (not (integer? s)) (threads-still-going?))
|
||||
'running]
|
||||
[(zero? s) 'done-ok]
|
||||
[else 'done-error]))]
|
||||
[(exit-code)
|
||||
(if (threads-still-going?)
|
||||
#f
|
||||
(let ([s (subprocess-status subp)]) (and (integer? s) s)))]
|
||||
[(wait)
|
||||
(subprocess-wait subp)
|
||||
(let ([twait (lambda (t) (when (thread? t) (thread-wait t)))])
|
||||
(twait so)
|
||||
(twait si)
|
||||
(twait se))]
|
||||
[(interrupt) (subprocess-kill subp #f)]
|
||||
[(kill) (subprocess-kill subp #t)]
|
||||
[else (raise-argument-error
|
||||
'control-process
|
||||
"(or/c 'status 'exit-code 'wait 'interrupt 'kill)" m)]))
|
||||
(list (aport so)
|
||||
(aport si)
|
||||
(subprocess-pid subp)
|
||||
(aport se)
|
||||
control)))))
|
||||
|
||||
(define (process*/ports cout cin cerr exe . args)
|
||||
(apply do-process*/ports 'process*/ports cout cin cerr exe args))
|
||||
|
||||
(define (process/ports out in err str)
|
||||
(apply do-process*/ports 'process/ports out in err (shell-path/args 'process/ports str)))
|
||||
|
||||
(define (process* exe . args)
|
||||
(apply do-process*/ports 'process* #f #f #f exe args))
|
||||
|
||||
(define (process str)
|
||||
(check-command 'process str)
|
||||
(apply do-process*/ports 'process #f #f #f (shell-path/args 'process str)))
|
||||
|
||||
;; Note: these always use current ports
|
||||
(define (do-system*/exit-code who exe . args)
|
||||
(let ([cout (current-output-port)]
|
||||
[cin (current-input-port)]
|
||||
[cerr (current-error-port)]
|
||||
[it-ready (make-semaphore)])
|
||||
(let-values ([(subp out in err)
|
||||
(apply subprocess
|
||||
(if-stream-out who cout)
|
||||
(if-stream-in who cin)
|
||||
(if-stream-out who cerr #t)
|
||||
(check-exe who exe)
|
||||
(check-args who args))])
|
||||
(let ([ot (streamify-out cout out)]
|
||||
[it (streamify-in cin in (lambda (ok?)
|
||||
(if ok?
|
||||
(semaphore-post it-ready)
|
||||
(semaphore-wait it-ready))))]
|
||||
[et (streamify-out cerr err)])
|
||||
(subprocess-wait subp)
|
||||
(when it
|
||||
;; stop piping output to subprocess
|
||||
(semaphore-wait it-ready)
|
||||
(break-thread it))
|
||||
;; wait for other pipes to run dry:
|
||||
(when (thread? ot) (thread-wait ot))
|
||||
(when (thread? et) (thread-wait et))
|
||||
(when err (close-input-port err))
|
||||
(when out (close-input-port out))
|
||||
(when in (close-output-port in)))
|
||||
(subprocess-status subp))))
|
||||
|
||||
(define (system*/exit-code exe . args)
|
||||
(apply do-system*/exit-code 'system*/exit-code exe args))
|
||||
|
||||
(define (system* exe . args)
|
||||
(zero? (apply do-system*/exit-code 'system* exe args)))
|
||||
|
||||
(define (system str)
|
||||
(check-command 'system str)
|
||||
(zero? (apply do-system*/exit-code 'system (shell-path/args 'system str))))
|
||||
|
||||
(define (system/exit-code str)
|
||||
(check-command 'system/exit-code str)
|
||||
(apply do-system*/exit-code 'system/exit-code (shell-path/args 'system/exit-code str)))
|
||||
(require racket/system)
|
||||
(provide (all-from-out racket/system))
|
||||
|
|
@ -1,172 +1,10 @@
|
|||
(module runtime-path racket/base
|
||||
(require "private/this-expression-source-directory.rkt"
|
||||
racket/list
|
||||
setup/dirs
|
||||
(only-in "private/runtime-path-table.rkt" table)
|
||||
(for-syntax racket/base))
|
||||
#lang racket/base
|
||||
|
||||
(provide define-runtime-path
|
||||
define-runtime-paths
|
||||
define-runtime-path-list
|
||||
define-runtime-module-path-index
|
||||
runtime-paths)
|
||||
|
||||
(define-for-syntax ext-file-table (make-hasheq))
|
||||
;; deprecated library, see `racket/runtime-path`
|
||||
|
||||
(define (lookup-in-table var-ref p)
|
||||
;; This function is designed to cooperate with a table embedded
|
||||
;; in an executable by create-embedding-executable.
|
||||
(let ([modname (variable-reference->resolved-module-path var-ref)])
|
||||
(let ([p (hash-ref
|
||||
table
|
||||
(cons (resolved-module-path-name modname)
|
||||
(if (path? p)
|
||||
(path->bytes p)
|
||||
(if (and (pair? p) (eq? 'module (car p)))
|
||||
(list 'module (cadr p))
|
||||
p)))
|
||||
#f)])
|
||||
(and p
|
||||
(car p)
|
||||
(let* ([p (car p)]
|
||||
[p (if (bytes? p)
|
||||
(bytes->path p)
|
||||
p)])
|
||||
(if (symbol? p)
|
||||
(module-path-index-join (list 'quote p) #f) ; make it a module path index
|
||||
(if (absolute-path? p)
|
||||
p
|
||||
(parameterize ([current-directory (find-system-path 'orig-dir)])
|
||||
(or (find-executable-path (find-system-path 'exec-file) p #t)
|
||||
(build-path (current-directory) p))))))))))
|
||||
|
||||
(define (resolve-paths tag-stx get-base paths)
|
||||
(let ([base #f])
|
||||
(map (lambda (p)
|
||||
(or
|
||||
;; Check table potentially substituted by
|
||||
;; mzc --exe:
|
||||
(and table
|
||||
(lookup-in-table tag-stx p))
|
||||
;; Normal resolution
|
||||
(cond
|
||||
[(and (or (string? p) (path? p))
|
||||
(not (complete-path? p)))
|
||||
(unless base
|
||||
(set! base (get-base)))
|
||||
(path->complete-path p base)]
|
||||
[(string? p) (string->path p)]
|
||||
[(path? p) p]
|
||||
[(and (list? p)
|
||||
(= 2 (length p))
|
||||
(eq? 'so (car p))
|
||||
(string? (cadr p)))
|
||||
(let ([f (path-replace-suffix (cadr p) (system-type 'so-suffix))])
|
||||
(or (ormap (lambda (p)
|
||||
(let ([p (build-path p f)])
|
||||
(and (file-exists? p)
|
||||
p)))
|
||||
(get-lib-search-dirs))
|
||||
(cadr p)))]
|
||||
[(and (list? p)
|
||||
((length p) . > . 1)
|
||||
(eq? 'lib (car p))
|
||||
(andmap string? (cdr p)))
|
||||
(let* ([strs (regexp-split #rx"/"
|
||||
(let ([s (cadr p)])
|
||||
(if (regexp-match? #rx"[./]" s)
|
||||
s
|
||||
(string-append s "/main.rkt"))))])
|
||||
(apply collection-file-path
|
||||
(last strs)
|
||||
(if (and (null? (cddr p))
|
||||
(null? (cdr strs)))
|
||||
(list "mzlib")
|
||||
(append (cddr p) (drop-right strs 1)))))]
|
||||
[(and (list? p)
|
||||
((length p) . = . 3)
|
||||
(eq? 'module (car p))
|
||||
(or (not (caddr p))
|
||||
(variable-reference? (caddr p))))
|
||||
(let ([p (cadr p)]
|
||||
[vr (caddr p)])
|
||||
(unless (module-path? p)
|
||||
(error 'runtime-path "not a module path: ~.s" p))
|
||||
(let ([base (and vr
|
||||
(variable-reference->resolved-module-path vr))])
|
||||
(if (and (pair? p)
|
||||
(eq? (car p) 'submod)
|
||||
(path? (cadr p)))
|
||||
(module-path-index-join `(submod "." ,@(cddr p))
|
||||
(module-path-index-join (cadr p) base))
|
||||
(module-path-index-join p base))))]
|
||||
[else (error 'runtime-path "unknown form: ~.s" p)])))
|
||||
paths)))
|
||||
|
||||
(define-for-syntax (register-ext-files var-ref paths)
|
||||
(let ([modname (variable-reference->resolved-module-path var-ref)])
|
||||
(let ([files (hash-ref ext-file-table modname null)])
|
||||
(hash-set! ext-file-table modname (append paths files)))))
|
||||
|
||||
(define-syntax (-define-runtime-path stx)
|
||||
(syntax-case stx ()
|
||||
[(_ orig-stx (id ...) expr to-list to-values)
|
||||
(let ([ids (syntax->list #'(id ...))])
|
||||
(unless (memq (syntax-local-context) '(module module-begin top-level))
|
||||
(raise-syntax-error #f "allowed only at the top level" #'orig-stx))
|
||||
(for-each (lambda (id)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
#'orig-stx
|
||||
id)))
|
||||
ids)
|
||||
#`(begin
|
||||
(define-values (id ...)
|
||||
(let-values ([(id ...) expr])
|
||||
(let ([get-dir (lambda ()
|
||||
#,(datum->syntax
|
||||
#'orig-stx
|
||||
`(,#'this-expression-source-directory)
|
||||
#'orig-stx))])
|
||||
(apply to-values (resolve-paths (#%variable-reference)
|
||||
get-dir
|
||||
(to-list id ...))))))
|
||||
(begin-for-syntax
|
||||
(register-ext-files
|
||||
(#%variable-reference)
|
||||
(let-values ([(id ...) expr])
|
||||
(to-list id ...))))))]))
|
||||
|
||||
(define-syntax (define-runtime-path stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id expr) #`(-define-runtime-path #,stx (id) expr list values)]))
|
||||
|
||||
(define-syntax (define-runtime-paths stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (id ...) expr) #`(-define-runtime-path #,stx (id ...) expr list values)]))
|
||||
|
||||
(define-syntax (define-runtime-path-list stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id expr) #`(-define-runtime-path #,stx (id) expr values list)]))
|
||||
|
||||
(define-syntax (define-runtime-module-path-index stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id expr) #`(-define-runtime-path #,stx (id) `(module ,expr ,(#%variable-reference)) list values)]))
|
||||
|
||||
(define-syntax (runtime-paths stx)
|
||||
(syntax-case stx ()
|
||||
[(_ mp)
|
||||
#`(quote
|
||||
#,(hash-ref
|
||||
ext-file-table
|
||||
(module-path-index-resolve
|
||||
(let ([p (syntax->datum #'mp)]
|
||||
[base (syntax-source-module stx)])
|
||||
(if (and (pair? p) (eq? (car p) 'submod) (path? (cadr p)))
|
||||
(module-path-index-join `(submod "." ,@(cddr p))
|
||||
(module-path-index-join (cadr p) base))
|
||||
(module-path-index-join p base))))
|
||||
null))]))
|
||||
|
||||
)
|
||||
(require racket/runtime-path)
|
||||
(provide define-runtime-path
|
||||
define-runtime-paths
|
||||
define-runtime-path-list
|
||||
define-runtime-module-path-index
|
||||
runtime-paths)
|
||||
|
|
|
|||
|
|
@ -1,21 +1,6 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base
|
||||
syntax/kerncase
|
||||
syntax/struct
|
||||
racket/struct-info
|
||||
racket/include))
|
||||
|
||||
;; deprecated library, see `racket/shared`
|
||||
|
||||
(require racket/shared)
|
||||
(provide shared)
|
||||
|
||||
(define-for-syntax code-insp (variable-reference->module-declaration-inspector
|
||||
(#%variable-reference)))
|
||||
|
||||
(define undefined (letrec ([x x]) x))
|
||||
(require (only-in racket/base [cons the-cons]))
|
||||
|
||||
(define-syntax shared
|
||||
(lambda (stx)
|
||||
(define make-check-cdr #f)
|
||||
;; Include the implementation.
|
||||
;; See private/shared-body.rkt.
|
||||
(include "private/shared-body.rkt")))
|
||||
|
|
|
|||
|
|
@ -1,27 +1,6 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "private/unit-syntax.rkt"
|
||||
"private/unit-compiletime.rkt")
|
||||
;; deprecated library, see `racket/unit-exptime`
|
||||
|
||||
(provide unit-static-signatures
|
||||
signature-members)
|
||||
|
||||
(define (unit-static-signatures name err-stx)
|
||||
(parameterize ((error-syntax err-stx))
|
||||
(let ((ui (lookup-def-unit name)))
|
||||
(values (apply list (unit-info-import-sig-ids ui))
|
||||
(apply list (unit-info-export-sig-ids ui))))))
|
||||
|
||||
(define (signature-members name err-stx)
|
||||
(parameterize ((error-syntax err-stx))
|
||||
(let ([s (lookup-signature name)])
|
||||
(values
|
||||
;; extends:
|
||||
(and (pair? (cdr (siginfo-names (signature-siginfo s))))
|
||||
(cadr (siginfo-names (signature-siginfo s))))
|
||||
;; vars
|
||||
(apply list (signature-vars s))
|
||||
;; defined vars
|
||||
(apply list (apply append (map car (signature-val-defs s))))
|
||||
;; defined stxs
|
||||
(apply list (apply append (map car (signature-stx-defs s))))))))
|
||||
(require racket/unit-exptime)
|
||||
(provide (all-from-out racket/unit-exptime))
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,269 +1,6 @@
|
|||
;; A modification of Dave Herman's zip module
|
||||
#lang racket/base
|
||||
|
||||
(module zip mzscheme
|
||||
(require mzlib/deflate racket/file mzlib/kw)
|
||||
;; deprecated library, see `file/zip`
|
||||
|
||||
;; ===========================================================================
|
||||
;; DATA DEFINITIONS
|
||||
;; ===========================================================================
|
||||
|
||||
;; An msdos-time or an msdos-date is an exact-integer in the respective format
|
||||
;; described at:
|
||||
;;
|
||||
;; http://msdn.microsoft.com/library/en-us/com/htm/cmf_a2c_25gl.asp
|
||||
|
||||
;; metadata : path * bytes * boolean * integer * integer * nat * integer
|
||||
(define-struct metadata
|
||||
(path name directory? time date compression attributes))
|
||||
|
||||
;; header : metadata * exact-integer * nat * nat * nat
|
||||
(define-struct header (metadata crc compressed uncompressed size))
|
||||
|
||||
;; ===========================================================================
|
||||
;; CONSTANTS etc
|
||||
;; ===========================================================================
|
||||
|
||||
(define *spec-version* 62) ; version 6.2
|
||||
(define *required-version* 20) ; version 2.0
|
||||
(define *compression-level* 8) ; I don't think this is configurable
|
||||
(define *zip-comment* #"packed by Racket - http://racket-lang.org/")
|
||||
|
||||
;; PKZIP specification:
|
||||
;; http://www.pkware.com/company/standards/appnote/
|
||||
|
||||
(define *local-file-header* #x04034b50)
|
||||
(define *archive-extra-record* #x08064b50)
|
||||
(define *central-file-header* #x02014b50)
|
||||
(define *digital-signature* #x05054b50)
|
||||
(define *zip64-end-of-central-directory-record* #x06064b50)
|
||||
(define *zip64-end-of-central-directory-locator* #x07064b50)
|
||||
(define *end-of-central-directory-record* #x06054b50)
|
||||
|
||||
(define *system*
|
||||
(case (system-type)
|
||||
[(unix oskit) 3]
|
||||
[(windows) 0]
|
||||
[(macos) 7]
|
||||
[(macosx) 19]))
|
||||
(define *os-specific-separator-regexp*
|
||||
(case (system-type)
|
||||
[(unix macosx oskit) #rx"/"]
|
||||
[(windows) #rx"\\\\"]
|
||||
[(macos) #rx":"]))
|
||||
|
||||
(provide zip-verbose)
|
||||
(define zip-verbose (make-parameter #f))
|
||||
|
||||
;; ===========================================================================
|
||||
;; FILE CREATION
|
||||
;; ===========================================================================
|
||||
|
||||
;; date->msdos-time : date -> msdos-time
|
||||
(define (date->msdos-time date)
|
||||
(bitwise-ior (ceiling (/ (date-second date) 2))
|
||||
(arithmetic-shift (date-minute date) 5)
|
||||
(arithmetic-shift (date-hour date) 11)))
|
||||
|
||||
;; date->msdos-date : date -> msdos-date
|
||||
(define (date->msdos-date date)
|
||||
(bitwise-ior (date-day date)
|
||||
(arithmetic-shift (date-month date) 5)
|
||||
(arithmetic-shift (- (date-year date) 1980) 9)))
|
||||
|
||||
;; seekable-port? : port -> boolean
|
||||
(define (seekable-port? port)
|
||||
(and (file-stream-port? port)
|
||||
(with-handlers ([void (lambda (exn) #f)])
|
||||
(file-position port (file-position port))
|
||||
#t)))
|
||||
|
||||
(define (write-int n size)
|
||||
(write-bytes (integer->integer-bytes n size #f #f)))
|
||||
|
||||
;; zip-one-entry : metadata boolean -> header
|
||||
(define (zip-one-entry metadata seekable?)
|
||||
(let* ([directory? (metadata-directory? metadata)]
|
||||
[path (metadata-path metadata)]
|
||||
[filename (metadata-name metadata)]
|
||||
[filename-length (bytes-length filename)]
|
||||
[bits (if seekable? 0 #b1000)]
|
||||
[time (metadata-time metadata)]
|
||||
[date (metadata-date metadata)]
|
||||
[compression (metadata-compression metadata)]
|
||||
[mark1 #f]
|
||||
[mark2 #f])
|
||||
(when (zip-verbose)
|
||||
(eprintf "zip: compressing ~a...\n" filename))
|
||||
;; write the contents to the output stream:
|
||||
(write-int *local-file-header* 4) ; signature
|
||||
(write-int *required-version* 2) ; version
|
||||
(write-int bits 2) ; bits
|
||||
(write-int compression 2) ; compression
|
||||
(write-int time 2) ; time
|
||||
(write-int date 2) ; date
|
||||
(when seekable? (set! mark1 (file-position (current-output-port))))
|
||||
(write-int 0 4) ; crc-32
|
||||
(write-int 0 4) ; compressed
|
||||
(write-int 0 4) ; uncompressed
|
||||
(write-int filename-length 2) ; filename-length
|
||||
(write-int 0 2) ; extra-length
|
||||
(write-bytes filename) ; filename
|
||||
(if directory?
|
||||
(make-header metadata 0 0 0 (+ filename-length 30))
|
||||
(let-values ([(uncompressed compressed crc)
|
||||
(with-input-from-file path
|
||||
(lambda ()
|
||||
(deflate (current-input-port)
|
||||
(current-output-port))))])
|
||||
(if seekable?
|
||||
(begin (set! mark2 (file-position (current-output-port)))
|
||||
(file-position (current-output-port) mark1))
|
||||
(write-int #x08074b50 4)) ; EXT signature
|
||||
(write-int crc 4) ; crc-32
|
||||
(write-int compressed 4) ; compressed
|
||||
(write-int uncompressed 4) ; uncompressed
|
||||
(when seekable? (file-position (current-output-port) mark2))
|
||||
|
||||
;; return the header information
|
||||
(make-header metadata crc compressed uncompressed
|
||||
(+ filename-length compressed
|
||||
(if seekable? 30 46)))))))
|
||||
|
||||
;; write-end-of-central-directory : nat nat nat ->
|
||||
(define (write-end-of-central-directory count start size)
|
||||
(let ([comment-length (bytes-length *zip-comment*)])
|
||||
(write-int #x06054b50 4) ; signature
|
||||
(write-int 0 2) ; # this disk
|
||||
(write-int 0 2) ; # disk with start of central dir.
|
||||
(write-int count 2) ; # entries in central dir. on this disk
|
||||
(write-int count 2) ; # entries in central dir.
|
||||
(write-int size 4) ; size of central dir.
|
||||
(write-int start 4) ; offset of start of central dir.
|
||||
(write-int comment-length 2)
|
||||
(write-bytes *zip-comment*)))
|
||||
|
||||
;; write-central-directory : (listof header) ->
|
||||
(define (write-central-directory headers)
|
||||
(let ([count (length headers)])
|
||||
(let loop ([headers headers] [offset 0] [size 0])
|
||||
(if (null? headers)
|
||||
;; no digital signature (why?)
|
||||
(write-end-of-central-directory count offset size)
|
||||
(let* ([header (car headers)]
|
||||
[metadata (header-metadata header)]
|
||||
[filename-length (bytes-length (metadata-name metadata))]
|
||||
[attributes (metadata-attributes metadata)]
|
||||
[compression (metadata-compression metadata)]
|
||||
[version (bitwise-ior *spec-version*
|
||||
(arithmetic-shift *system* 8))])
|
||||
(write-int #x02014b50 4)
|
||||
(write-int version 2)
|
||||
(write-int *required-version* 2)
|
||||
(write-int 0 2)
|
||||
(write-int compression 2)
|
||||
(write-int (metadata-time metadata) 2)
|
||||
(write-int (metadata-date metadata) 2)
|
||||
(write-int (header-crc header) 4)
|
||||
(write-int (header-compressed header) 4)
|
||||
(write-int (header-uncompressed header) 4)
|
||||
(write-int filename-length 2)
|
||||
(write-int 0 2)
|
||||
(write-int 0 2) ; comment length
|
||||
(write-int 0 2)
|
||||
(write-int 0 2) ; internal attributes
|
||||
(write-int attributes 4) ; external attributes
|
||||
(write-int offset 4)
|
||||
(write-bytes (metadata-name metadata))
|
||||
(loop (cdr headers)
|
||||
(+ offset (header-size header))
|
||||
(+ size filename-length 46)))))))
|
||||
|
||||
;; The PKZIP specification includes an entry in the central directory for
|
||||
;; an entry's "external file attributes," which for standard ZIP files is
|
||||
;; the MS-DOS (i.e., FAT) directory attribute byte, and the Unix zip adds
|
||||
;; the Unix bits as the higher two bytes.
|
||||
|
||||
;; This is for reference
|
||||
;; (define *msdos:read-only* #x01)
|
||||
;; (define *msdos:hidden* #x02)
|
||||
;; (define *msdos:system* #x04)
|
||||
;; (define *msdos:volume* #x08)
|
||||
;; (define *msdos:directory* #x10)
|
||||
;; (define *msdos:archive* #x20)
|
||||
;; (define *unix:directory* #o40000)
|
||||
;; (define *unix:char-dev* #o20000)
|
||||
;; (define *unix:fifo* #o10000)
|
||||
;; (define *unix:suid* #o04000)
|
||||
;; (define *unix:sgid* #o02000)
|
||||
;; (define *unix:sticky* #o01000)
|
||||
;; (define *unix:owner-read* #o00400)
|
||||
;; (define *unix:owner-write* #o00200)
|
||||
;; (define *unix:owner-exe* #o00100)
|
||||
;; (define *unix:group-read* #o00040)
|
||||
;; (define *unix:group-write* #o00020)
|
||||
;; (define *unix:group-exe* #o00010)
|
||||
;; (define *unix:other-read* #o00004)
|
||||
;; (define *unix:other-write* #o00002)
|
||||
;; (define *unix:other-exe* #o00001)
|
||||
(define (path-attributes path dir?)
|
||||
(let ([dos (if dir? #x10 0)]
|
||||
[unix (apply bitwise-ior (if dir? #o40000 0)
|
||||
(map (lambda (p)
|
||||
(case p
|
||||
[(read) #o444]
|
||||
[(write) #o200] ; mask out write bits
|
||||
[(execute) #o111]))
|
||||
(file-or-directory-permissions path)))])
|
||||
(bitwise-ior dos (arithmetic-shift unix 16))))
|
||||
|
||||
;; with-trailing-slash : bytes -> bytes
|
||||
(define (with-trailing-slash bytes)
|
||||
(regexp-replace #rx#"/*$" bytes "/"))
|
||||
|
||||
;; with-slash-separator : bytes -> bytes
|
||||
(define (with-slash-separator bytes)
|
||||
(regexp-replace* *os-specific-separator-regexp* bytes #"/"))
|
||||
|
||||
;; build-metadata : relative-path -> metadata
|
||||
(define (build-metadata path)
|
||||
(let* ([mod (seconds->date (file-or-directory-modify-seconds path))]
|
||||
[dir? (directory-exists? path)]
|
||||
[path (cond [(path? path) path]
|
||||
[(string? path) (string->path path)]
|
||||
[(bytes? path) (bytes->path path)])]
|
||||
[name (with-slash-separator (path->bytes path))]
|
||||
[name (if dir? (with-trailing-slash name) name)]
|
||||
[time (date->msdos-time mod)]
|
||||
[date (date->msdos-date mod)]
|
||||
[comp (if dir? 0 *compression-level*)]
|
||||
[attr (path-attributes path dir?)])
|
||||
(make-metadata path name dir? time date comp attr)))
|
||||
|
||||
;; ===========================================================================
|
||||
;; FRONT END
|
||||
;; ===========================================================================
|
||||
|
||||
;; zip-write : (listof relative-path) ->
|
||||
;; writes a zip file to current-output-port
|
||||
(provide zip->output)
|
||||
(define/kw (zip->output files #:optional [out (current-output-port)])
|
||||
(parameterize ([current-output-port out])
|
||||
(let* ([seekable? (seekable-port? (current-output-port))]
|
||||
[headers ; note: Racket's `map' is always left-to-right
|
||||
(map (lambda (file)
|
||||
(zip-one-entry (build-metadata file) seekable?))
|
||||
files)])
|
||||
(when (zip-verbose)
|
||||
(eprintf "zip: writing headers...\n"))
|
||||
(write-central-directory headers))
|
||||
(when (zip-verbose)
|
||||
(eprintf "zip: done.\n"))))
|
||||
|
||||
;; zip : output-file paths ->
|
||||
(provide zip)
|
||||
(define (zip zip-file . paths)
|
||||
(when (null? paths) (error 'zip "no paths specified"))
|
||||
(with-output-to-file zip-file
|
||||
(lambda () (zip->output (pathlist-closure paths)))))
|
||||
|
||||
)
|
||||
(require file/zip)
|
||||
(provide (all-from-out file/zip))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user