145 lines
5.3 KiB
Scheme
145 lines
5.3 KiB
Scheme
(module (pandoc tar)
|
|
|
|
(#;export
|
|
pandoc-tar)
|
|
|
|
(import (scheme)
|
|
(chicken base)
|
|
(cjson)
|
|
;;(srfi 4)
|
|
(only (scheme base)
|
|
bytevector
|
|
bytevector-append
|
|
bytevector-length
|
|
bytevector-u8-ref
|
|
eof-object
|
|
make-bytevector
|
|
read-bytevector
|
|
string->utf8
|
|
truncate-remainder
|
|
utf8->string
|
|
write-bytevector)
|
|
(only (chicken io) read-byte read-string write-byte write-string)
|
|
(only (chicken port)
|
|
copy-port with-input-from-string with-output-to-string)
|
|
(only (scsh-process) run/port run/string)
|
|
(only (pandoc) pandoc-json->sxml))
|
|
|
|
(define (generator->list generator) ; SRFI 158
|
|
(let loop ((list '()))
|
|
(let ((elem (generator)))
|
|
(if (eof-object? elem) (reverse list) (loop (cons elem list))))))
|
|
|
|
(define (bytevector-every? predicate bytes)
|
|
(let loop ((i 0))
|
|
(or (= i (bytevector-length bytes))
|
|
(and (predicate (bytevector-u8-ref bytes i))
|
|
(loop (+ i 1))))))
|
|
|
|
(define (tar-read-file)
|
|
|
|
(define (read-exactly-n-bytes n)
|
|
(let ((bytes (read-bytevector n)))
|
|
(if (or (eof-object? bytes) (< (bytevector-length bytes) n))
|
|
(error "Short read")
|
|
bytes)))
|
|
|
|
(let ((header (read-bytevector 512)))
|
|
|
|
(define (tar-octal-ref offset len)
|
|
(let loop ((offset offset) (len len) (value 0))
|
|
(if (<= len 0) value
|
|
(let ((dig0 (char->integer #\0))
|
|
(dig7 (char->integer #\7))
|
|
(byte (bytevector-u8-ref header offset)))
|
|
(loop (+ offset 1) (- len 1)
|
|
(if (<= dig0 byte dig7)
|
|
(let ((digit (- byte dig0)))
|
|
(+ digit (* value 8)))
|
|
value))))))
|
|
|
|
(cond ((eof-object? header)
|
|
(eof-object))
|
|
((bytevector-every? zero? header)
|
|
(eof-object))
|
|
(else
|
|
(unless (= 512 (bytevector-length header))
|
|
(error "Short read"))
|
|
(let* ((nbyte (tar-octal-ref 124 12))
|
|
(nnull (- 512 (truncate-remainder nbyte 512)))
|
|
(bytes (read-exactly-n-bytes nbyte)))
|
|
(read-exactly-n-bytes nnull)
|
|
bytes)))))
|
|
|
|
(define (tar-write-file filename bytes)
|
|
|
|
(define nulls (make-bytevector 512 0))
|
|
(define blank-checksum (make-bytevector 7 (char->integer #\space)))
|
|
|
|
(define (bytevector-sum bv)
|
|
(let loop ((i (- (bytevector-length bv) 1)) (sum 0))
|
|
(if (< i 0) sum (loop (- i 1) (+ sum (bytevector-u8-ref bv i))))))
|
|
|
|
(define (tar-string nbyte string)
|
|
(let* ((bytes (string->utf8 string))
|
|
(nnull (- nbyte (bytevector-length bytes))))
|
|
(when (< nnull 1) (error "tar: string too long"))
|
|
(bytevector-append bytes (make-bytevector nnull 0))))
|
|
|
|
(define (tar-octal nbyte number)
|
|
(let* ((bytes (string->utf8 (number->string number 8)))
|
|
(nzero (- nbyte 1 (bytevector-length bytes))))
|
|
(bytevector-append (make-bytevector nzero (char->integer #\0))
|
|
bytes (bytevector 0))))
|
|
|
|
(let* ((nbyte (bytevector-length bytes))
|
|
(nnull (- 512 (truncate-remainder nbyte 512)))
|
|
(header-before-checksum
|
|
(bytevector-append
|
|
(tar-string 100 filename)
|
|
(tar-octal 8 #o444)
|
|
(tar-octal 8 0)
|
|
(tar-octal 8 0)
|
|
(tar-octal 12 nbyte)
|
|
(tar-octal 12 0)))
|
|
(header-after-checksum
|
|
(bytevector-append
|
|
(bytevector (char->integer #\space))
|
|
(bytevector (char->integer #\0))
|
|
(tar-string 100 "")
|
|
(tar-string 8 "ustar ")
|
|
(tar-string 32 "")
|
|
(tar-string 32 "")
|
|
(make-bytevector 183 0)))
|
|
(checksum
|
|
(let ((sum (+ (bytevector-sum header-before-checksum)
|
|
(bytevector-sum blank-checksum)
|
|
(bytevector-sum header-after-checksum))))
|
|
(tar-octal 7 (truncate-remainder sum (expt 8 6))))))
|
|
(write-bytevector header-before-checksum)
|
|
(write-bytevector checksum)
|
|
(write-bytevector header-after-checksum)
|
|
(write-bytevector bytes)
|
|
(write-bytevector nulls (current-output-port) 0 nnull)))
|
|
|
|
(define (write-all-to-tar inputs)
|
|
(let loop ((i 0) (inputs inputs))
|
|
(unless (null? inputs)
|
|
(let ((filename (string-append (number->string i) ".md")))
|
|
(tar-write-file filename (car inputs))
|
|
(loop (+ i 1) (cdr inputs))))))
|
|
|
|
(define (pandoc-tar #!optional command-name)
|
|
(let ((command-name (string->symbol (or command-name "pandoc-tar"))))
|
|
(lambda (input-format bytevectors)
|
|
(let* ((stdin
|
|
(with-output-to-string
|
|
(lambda () (write-all-to-tar bytevectors))))
|
|
(stdout
|
|
(run/string (,command-name --from ,input-format --to json)
|
|
(<< ,stdin))))
|
|
(map (lambda (bytes)
|
|
(cjson-schemify (string->cjson (utf8->string bytes))))
|
|
(with-input-from-string stdout
|
|
(lambda () (generator->list tar-read-file)))))))))
|