Using a language makes this much cuter. Also use base64.

svn: r17240

original commit: 539519bdad75e2fc8522526017bbec91237403db

collects/framework/private/bday.ss

@@ -1,40 +1,32 @@
-#lang scheme/base
+#lang s-exp framework/private/decode
-(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
 
-  ||\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==

collects/framework/private/decode.ss

@@ -1,20 +1,19 @@
 #lang scheme/base
-(require (for-syntax file/gunzip scheme/base))
+(require (for-syntax scheme/base file/gunzip net/base64))
-(provide decode)
+(provide (except-out (all-from-out scheme/base) #%module-begin)
+         (rename-out [module-begin #%module-begin]))
 
-(define-syntax (decode stx)
+(define-syntax (module-begin 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))
   (syntax-case stx ()
     [(_ x ...)
-     (andmap identifier? (syntax->list #'(x ...)))
+     (andmap (lambda (x) (or identifier? (integer? (syntax-e x))))
-     (datum->syntax stx (decode (syntax->list #'(x ...))) stx)]))
+             (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))]))

collects/framework/private/encode.ss

@@ -1,67 +1,43 @@
 #lang scheme/base
-(require mzlib/deflate
+(require scheme/cmdline scheme/string scheme/match scheme/pretty
-         mzlib/match
+         file/gzip file/gunzip net/base64)
-         mzlib/pretty)
-(require (for-syntax mzlib/inflate
-                     mzlib/string))
 
-(provide encode-sexp
+(define (encode-exprs exprs)
-         encode-module)
+  (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)
+(define (encode-module)
-  (call-with-input-file in-filename
+  (define mod (parameterize ([read-accept-reader #t]) (read)))
-    (λ (port)
+  (when (eof-object? mod) (error 'encode-module "missing module"))
-      (let ([mod (read port)])
+  (match mod
-        (unless (eof-object? (read port))
+    [(list 'module m 'scheme/base (list '#%module-begin exprs ...))
-          (error 'encode-module "found an extra expression"))
+     (write-bytes #"#lang s-exp framework/private/decode\n")
-        (match mod 
+     (write-bytes (regexp-replace* #rx"\r\n" (encode-exprs exprs) #"\n"))]
-          [`(module ,m mzscheme ,@(bodies ...))
+    [else (error 'encode-module "cannot parse module, must use scheme/base")]))
-           (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 (chop-up sym)
+(define (decode-module)
-  (let ([chopping-point 50])
+  (define mod (parameterize ([read-accept-reader #t]) (read)))
-    (let loop ([str (symbol->string sym)])
+  (when (eof-object? mod) (error 'encode-module "missing module"))
-      (cond
+  (match mod
-        [(<= (string-length str) chopping-point)
+    [(list 'module m 'framework/private/decode
-         (list (string->symbol str))]
+           (list '#%module-begin exprs ...))
-        [else
+     (write-bytes #"#lang scheme/base\n")
-         (cons (string->symbol (substring str 0 chopping-point))
+     (let* ([data  (format "~a" exprs)]
-               (loop (substring str chopping-point (string-length str))))]))))
+            [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)
+(command-line #:once-any
-  (define (str->sym string)
+              ["-e" "encode" (encode-module) (exit)]
-    (string->symbol
+              ["-d" "decode" (decode-module) (exit)])
-     (apply 
+(printf "Use `-h' for help\n")
-      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))))