preserves/implementations/racket/preserves/preserves/tool.rkt

109 lines
4.8 KiB
Racket

#lang racket/base
(require "main.rkt")
(require racket/match)
(require racket/port)
(require file/sha1)
(require net/base64)
(require racket/exn)
(module+ main
(require racket/cmdline)
(define input-encoding 'none)
(define input-format 'any)
(define output-format 'text)
(define output-encoding 'none)
(define indent? #t)
(define annotations? #t)
(define count +inf.0)
(command-line #:once-each
[("--ie" "--input-encoding") encoding "Input encoding: none, base64, or hex"
(set! input-encoding (string->symbol encoding))]
[("--oe" "--output-encoding") encoding "Output encoding: none, base64, or hex"
(set! output-encoding (string->symbol encoding))]
["--atob" "Text to binary"
(begin (set! input-format 'text)
(set! output-format 'binary))]
["--all" "Read until EOF (default)"
(set! count +inf.0)]
["--count" n "Read n items"
(set! count (string->number n))]
["--btoa" "Binary to text"
(begin (set! input-format 'binary)
(set! output-format 'text))]
[("--ia" "--input-any") "Autodetect input mode (default)"
(set! input-format 'any)]
[("--ib" "--input-binary") "Set binary input mode"
(set! input-format 'binary)]
[("--it" "--input-text") "Set text input mode"
(set! input-format 'text)]
[("--ob" "--output-binary") "Set binary output mode"
(set! output-format 'binary)]
[("--ot" "--output-text") "Set text output mode (default)"
(set! output-format 'text)]
["--indent" "Enable indent and set text output mode (default)"
(set! output-format 'text)
(set! indent? #t)]
["--no-indent" "Disable indent and set text output mode"
(set! output-format 'text)
(set! indent? #f)]
["--annotations" "Output annotations (default)"
(set! annotations? #t)]
["--no-annotations" "Strip annotations"
(set! annotations? #f)])
(void
(match input-encoding
['none (void)]
['hex (let-values (((i o) (make-pipe)))
(define wrapped (current-input-port))
(current-input-port i)
(thread (lambda ()
(with-handlers [(values (lambda (e)
(displayln (exn->string e) (current-error-port))
(exit 1)))]
(let loop ()
(match (read-line wrapped)
[(? eof-object?)
(close-output-port o)]
[line
(write-bytes (hex-string->bytes line) o)
(flush-output o)
(loop)]))))))]
['base64 (let-values (((i o) (make-pipe)))
(define wrapped (current-input-port))
(current-input-port i)
(thread (lambda ()
(with-handlers [(values (lambda (e)
(displayln (exn->string e) (current-error-port))
(exit 1)))]
(let loop ()
(if (eof-object? (peek-byte wrapped))
(close-output-port o)
(begin (base64-decode-stream wrapped o)
(loop))))))))]))
(let loop ((count count))
(when (positive? count)
(define v ((if annotations? values strip-annotations)
(match input-format
['any (read-preserve #:read-syntax? #t #:decode-embedded values #:source "<stdin>")]
['text (read-preserve/text #:read-syntax? #t #:decode-embedded values #:source "<stdin>")]
['binary (read-preserve/binary #:decode-embedded values #:read-syntax? #t)])))
(when (not (eof-object? v))
(define bs
(call-with-output-bytes
(lambda (p)
(match output-format
['text
(write-preserve/text v p #:indent indent? #:encode-embedded values)
(newline)]
['binary
(write-preserve/binary v p #:encode-embedded values #:write-annotations? #t)]))))
(match output-encoding
['none (write-bytes bs)]
['hex (writeln (bytes->hex-string bs))]
['base64 (writeln (base64-encode bs #""))])
(flush-output)
(loop (- count 1))))))