diff --git a/collects/framework/private/bday.ss b/collects/framework/private/bday.ss index 72b3d33c..42dabb81 100644 --- a/collects/framework/private/bday.ss +++ b/collects/framework/private/bday.ss @@ -1,40 +1,32 @@ -#lang scheme/base -(require "decode.ss") -(decode - \5d8f4 - \10ec22010 - \45aff297b02 - \0 \69d544 - \5da867 - \299da9 - \360a3 - \5404db - \cbde0b - \4b571f - \7798f6 - \13ecaf - \2b5f75 - \0cf30bc - \7a62b8d0 - \194bcdfb - \023787789 - \f02\5b091a - \8ab \8eb3d4 - \3a9 \02e040 - \3ac \307a74 - \ca8 \495944 - \6e0 \74fd1 - \9ce5 \d88e21 - \b04 \f66c25 - \a97f \b8d27a - \813 \be13c6 - \0d3e \dd50a2 - \86d3 \3f5ede - \174a \3235ad9 - \ecb40 \2aecb1 - \ad56 \76292fb - \6aeb0 \39ae75f - \8f335 \ea955 - \e7e \2c7 +#lang s-exp framework/private/decode - ||\6||\8||\7||\4||\3||\d||\e||\f||\c||\0||\1) + XY9BD + sIgEEWv + 8pfMgqRV + E3Whn + qXtT + GOjg + AE08 + fYWp + 62Nu + 897D + PMxjx + heAwtc + 7G3Lzfs + CN4 d0m + 4K0G giGp + R+8w JgC4 + MA0w rvkk + XCTR 5GkC + 56T Peux + e8Yo PtsJ + E5X7 jWeY + E74T 1gWf + ryiR 4OjH + y/tK Waem + 1XMZ aIU9 + ttXK LuXV + 1hU2 x7WO + f75G vdLLj + 9Xuc CD6A + \\\\ A== diff --git a/collects/framework/private/decode.ss b/collects/framework/private/decode.ss index 8639bb05..47fdae06 100644 --- a/collects/framework/private/decode.ss +++ b/collects/framework/private/decode.ss @@ -1,20 +1,19 @@ #lang scheme/base -(require (for-syntax file/gunzip scheme/base)) -(provide decode) +(require (for-syntax scheme/base file/gunzip net/base64)) +(provide (except-out (all-from-out scheme/base) #%module-begin) + (rename-out [module-begin #%module-begin])) -(define-syntax (decode stx) - (define (decode stxs) - (define str - (apply string-append (map (λ (x) (symbol->string (syntax-e x))) stxs))) - (define loc - (if (even? (string-length str)) - (for/list ([i (in-range 0 (string-length str) 2)]) - (string->number (substring str i (+ i 2)) 16)) - (error 'decode "missing digit somewhere"))) - (define-values (p-in p-out) (make-pipe)) - (inflate (open-input-bytes (apply bytes loc)) p-out) - (read p-in)) +(define-syntax (module-begin stx) (syntax-case stx () [(_ x ...) - (andmap identifier? (syntax->list #'(x ...))) - (datum->syntax stx (decode (syntax->list #'(x ...))) stx)])) + (andmap (lambda (x) (or identifier? (integer? (syntax-e x)))) + (syntax->list #'(x ...))) + (let* ([data (format "~a" (syntax->datum #'(x ...)))] + [data (substring data 1 (sub1 (string-length data)))] + [data (string->bytes/utf-8 data)] + [in (open-input-bytes (base64-decode data))] + [out (open-output-string)] + [out (begin (inflate in out) (get-output-string out))] + [exprs (read (open-input-string (string-append "(" out ")")))] + [exprs (datum->syntax stx exprs stx)]) + #`(#%module-begin #,@exprs))])) diff --git a/collects/framework/private/encode.ss b/collects/framework/private/encode.ss index 45084ac2..4e3c455c 100644 --- a/collects/framework/private/encode.ss +++ b/collects/framework/private/encode.ss @@ -1,67 +1,43 @@ #lang scheme/base -(require mzlib/deflate - mzlib/match - mzlib/pretty) -(require (for-syntax mzlib/inflate - mzlib/string)) +(require scheme/cmdline scheme/string scheme/match scheme/pretty + file/gzip file/gunzip net/base64) -(provide encode-sexp - encode-module) +(define (encode-exprs exprs) + (define in + (open-input-string + (string-join (map (lambda (x) (format "~s" x)) exprs) " "))) + (define out (open-output-bytes)) + (deflate in out) + (base64-encode (get-output-bytes out))) -(define (encode-module in-filename out-filename) - (call-with-input-file in-filename - (λ (port) - (let ([mod (read port)]) - (unless (eof-object? (read port)) - (error 'encode-module "found an extra expression")) - (match mod - [`(module ,m mzscheme ,@(bodies ...)) - (call-with-output-file out-filename - (λ (oport) - (let ([chopped (chop-up (encode-sexp `(begin ,@bodies)))]) - (fprintf oport "(module ~a mzscheme\n" m) - (fprintf oport " (require framework/private/decode)\n") - (fprintf oport " (decode ~a" (car chopped)) - (for-each (lambda (chopped) - (fprintf oport "\n ~a" chopped)) - (cdr chopped)) - (fprintf oport "))\n"))) - 'truncate 'text)] - [else (error 'encode-module "cannot parse module")]))))) +(define (encode-module) + (define mod (parameterize ([read-accept-reader #t]) (read))) + (when (eof-object? mod) (error 'encode-module "missing module")) + (match mod + [(list 'module m 'scheme/base (list '#%module-begin exprs ...)) + (write-bytes #"#lang s-exp framework/private/decode\n") + (write-bytes (regexp-replace* #rx"\r\n" (encode-exprs exprs) #"\n"))] + [else (error 'encode-module "cannot parse module, must use scheme/base")])) -(define (chop-up sym) - (let ([chopping-point 50]) - (let loop ([str (symbol->string sym)]) - (cond - [(<= (string-length str) chopping-point) - (list (string->symbol str))] - [else - (cons (string->symbol (substring str 0 chopping-point)) - (loop (substring str chopping-point (string-length str))))])))) +(define (decode-module) + (define mod (parameterize ([read-accept-reader #t]) (read))) + (when (eof-object? mod) (error 'encode-module "missing module")) + (match mod + [(list 'module m 'framework/private/decode + (list '#%module-begin exprs ...)) + (write-bytes #"#lang scheme/base\n") + (let* ([data (format "~a" exprs)] + [data (substring data 1 (sub1 (string-length data)))] + [data (string->bytes/utf-8 data)] + [in (open-input-bytes (base64-decode data))] + [out (open-output-string)] + [out (begin (inflate in out) (get-output-string out))] + [exprs (read (open-input-string (string-append "(" out ")")))]) + (for ([expr (in-list exprs)]) + (pretty-print expr)))] + [else (error 'decode-module "cannot parse module, must use scheme/base")])) -(define (encode-sexp sexp) - (define (str->sym string) - (string->symbol - (apply - string-append - (map - (λ (x) - (to-hex x)) - (bytes->list string))))) - - (define (to-hex n) - (let ([digit->hex - (λ (d) - (cond - [(<= d 9) d] - [else (integer->char (+ d -10 (char->integer #\a)))]))]) - (cond - [(< n 16) (format "0~a" (digit->hex n))] - [else (format "~a~a" - (digit->hex (quotient n 16)) - (digit->hex (modulo n 16)))]))) - - (let ([in (open-input-string (format "~s" sexp))] - [out (open-output-bytes)]) - (deflate in out) - (str->sym (get-output-bytes out)))) +(command-line #:once-any + ["-e" "encode" (encode-module) (exit)] + ["-d" "decode" (decode-module) (exit)]) +(printf "Use `-h' for help\n")