Drop unnecessary .scm files
This commit is contained in:
parent
003a1019c7
commit
5566c6c119
|
|
@ -0,0 +1,4 @@
|
|||
((scheme-mode
|
||||
(indent-tabs-mode . nil)
|
||||
(lisp-local-indent
|
||||
unpack-case 1)))
|
||||
|
|
@ -1 +1,3 @@
|
|||
distfiles
|
||||
*.log
|
||||
*.tar
|
||||
*.tgz
|
||||
|
|
|
|||
|
|
@ -1,124 +0,0 @@
|
|||
;; Emacs: this is -*- Scheme -*- code, not a Dockerfile.
|
||||
|
||||
;; Copyright 2019 Lassi Kortela
|
||||
;; SPDX-License-Identifier: ISC
|
||||
|
||||
(define-syntax only-when
|
||||
(syntax-rules ()
|
||||
((_ condition body ...)
|
||||
(if condition (begin body ...) #f))))
|
||||
|
||||
(define (delimit delimiter strings)
|
||||
(if (null? strings) ""
|
||||
(let loop ((strings (cdr strings)) (acc (car strings)))
|
||||
(if (null? strings) acc
|
||||
(loop (cdr strings)
|
||||
(string-append acc delimiter (car strings)))))))
|
||||
|
||||
(define (stringify s)
|
||||
(cond ((string? s) s)
|
||||
((number? s) (number->string s))
|
||||
(else (error "Don't know how to stringify that"))))
|
||||
|
||||
(define (tight . ss) (delimit "" (map stringify ss)))
|
||||
|
||||
(define (words . ss) (delimit " " (delete #f ss)))
|
||||
|
||||
(define (name=value name value)
|
||||
(string-append name "=" value))
|
||||
|
||||
(define (string-list->json strings)
|
||||
(call-with-port (open-output-string)
|
||||
(lambda (out)
|
||||
(parameterize ((current-output-port out))
|
||||
(write-char #\[)
|
||||
(unless (null? strings)
|
||||
(write (car strings))
|
||||
(for-each (lambda (s) (write-string ", ") (write s))
|
||||
(cdr strings)))
|
||||
(write-char #\]))
|
||||
(get-output-string out))))
|
||||
|
||||
(define (quote-string-with-vars s)
|
||||
s)
|
||||
|
||||
(define string-or-glob? string?)
|
||||
(define string-with-vars string?)
|
||||
(define name? string?)
|
||||
(define shellcmd list?)
|
||||
(define (any? x) #t)
|
||||
(define (nat x) (and (integer? x) (exact? x) (>= x 0)))
|
||||
|
||||
;;
|
||||
|
||||
(define (quote-dockerfile-instruction instruction)
|
||||
(unpack-case instruction
|
||||
((blank-line)
|
||||
"")
|
||||
((comment (text string?))
|
||||
;; TODO: Multi-line string should produce multi-line comment.
|
||||
(string-append "# " text))
|
||||
((from (image name?) (as name? ?))
|
||||
(words "FROM" image (only-when as (words "AS" as))))
|
||||
((run (shell shellcmd ?) (exec string? *))
|
||||
(exactly-one-of shell exec)
|
||||
(words "RUN" (cond (shell (shell-quote shell))
|
||||
(exec (string-list->json exec)))))
|
||||
((cmd (shell shellcmd ?) (exec string? *))
|
||||
(exactly-one-of shell exec)
|
||||
(words "CMD" (cond (shell (shell-quote shell))
|
||||
(exec (string-list->json exec)))))
|
||||
((label (name string?) (value string?))
|
||||
(words "LABEL" (name=value name value)))
|
||||
((expose (port nat) (protocol string? ?))
|
||||
(words "EXPOSE" (if protocol (tight port "/" protocol) port)))
|
||||
((env (name string?) (value string?))
|
||||
(words "ENV" (name=value name value)))
|
||||
((add (user name? ?) (group name? ?) (dst string?) (src string-or-glob? +))
|
||||
(words "ADD"
|
||||
(only-when (or user group) (tight "--chown=" user ":" group))
|
||||
(string-list->json (append src (list dst)))))
|
||||
((copy (from string? ?) (user string? ?) (group string? ?)
|
||||
(dst string?) (src string-or-glob? +))
|
||||
(words "COPY"
|
||||
(only-when from (tight "--from=" from))
|
||||
(only-when (or user group) (tight "--chown=" user ":" group))
|
||||
(string-list->json (append src (list dst)))))
|
||||
((entrypoint (shell shellcmd ?) (exec string? *))
|
||||
(exactly-one-of shell exec)
|
||||
(words "ENTRYPOINT" (cond (shell (shell-quote shell))
|
||||
(exec (string-list->json exec)))))
|
||||
((volume (mountpoint string?))
|
||||
(words "VOLUME" (string-list->json (list mountpoint))))
|
||||
((user (user string? ?) (group string? ?) (uid nat ?) (gid nat ?))
|
||||
(exactly-one-of uid user)
|
||||
(at-most-one-of gid group)
|
||||
(at-most-one-of uid group)
|
||||
(at-most-one-of gid user)
|
||||
(words "USER" (tight (or user uid)
|
||||
(only-when (or group gid)
|
||||
(tight ":" (or group gid))))))
|
||||
((workdir (path string-with-vars))
|
||||
(words "WORKDIR" (quote-string-with-vars path)))
|
||||
((arg (name string?) (value string?))
|
||||
(words "ARG" (name=value name value)))
|
||||
((stopsignal (signal name?))
|
||||
(words "STOPSIGNAL" signal))
|
||||
((healthcheck (shell shellcmd ?) (exec string? *) (none any? *) #;option*)
|
||||
#;(at-most-one-of none option*)
|
||||
(exactly-one-of shell exec none)
|
||||
(words "HEALTHCHECK"
|
||||
(cond (shell (words "CMD" (shell-quote shell)))
|
||||
(exec (words "CMD" (string-list->json exec)))
|
||||
(none "NONE"))))
|
||||
(else (error "Unknown Dockerfile instruction" instruction))))
|
||||
|
||||
(define (quote-dockerfile instructions)
|
||||
(call-with-port
|
||||
(open-output-string)
|
||||
(lambda (out)
|
||||
(for-each (lambda (x)
|
||||
(write-string (quote-dockerfile-instruction x) out)
|
||||
(newline out))
|
||||
instructions)
|
||||
(get-output-string out))))
|
||||
|
|
@ -12,4 +12,124 @@
|
|||
(chibi match)
|
||||
(lassik unpack-assoc)
|
||||
(lassik shell-quote))
|
||||
(include "dockerfile.scm"))
|
||||
(begin
|
||||
|
||||
(define-syntax only-when
|
||||
(syntax-rules ()
|
||||
((_ condition body ...)
|
||||
(if condition (begin body ...) #f))))
|
||||
|
||||
(define (delimit delimiter strings)
|
||||
(if (null? strings) ""
|
||||
(let loop ((strings (cdr strings)) (acc (car strings)))
|
||||
(if (null? strings) acc
|
||||
(loop (cdr strings)
|
||||
(string-append acc delimiter (car strings)))))))
|
||||
|
||||
(define (stringify s)
|
||||
(cond ((string? s) s)
|
||||
((number? s) (number->string s))
|
||||
(else (error "Don't know how to stringify that"))))
|
||||
|
||||
(define (tight . ss) (delimit "" (map stringify ss)))
|
||||
|
||||
(define (words . ss) (delimit " " (delete #f ss)))
|
||||
|
||||
(define (name=value name value)
|
||||
(string-append name "=" value))
|
||||
|
||||
(define (string-list->json strings)
|
||||
(call-with-port (open-output-string)
|
||||
(lambda (out)
|
||||
(parameterize ((current-output-port out))
|
||||
(write-char #\[)
|
||||
(unless (null? strings)
|
||||
(write (car strings))
|
||||
(for-each (lambda (s) (write-string ", ") (write s))
|
||||
(cdr strings)))
|
||||
(write-char #\]))
|
||||
(get-output-string out))))
|
||||
|
||||
(define (quote-string-with-vars s)
|
||||
s)
|
||||
|
||||
(define string-or-glob? string?)
|
||||
(define string-with-vars string?)
|
||||
(define name? string?)
|
||||
(define shellcmd list?)
|
||||
(define (any? x) #t)
|
||||
(define (nat x) (and (integer? x) (exact? x) (>= x 0)))
|
||||
|
||||
;;
|
||||
|
||||
(define (quote-dockerfile-instruction instruction)
|
||||
(unpack-case instruction
|
||||
((blank-line)
|
||||
"")
|
||||
((comment (text string?))
|
||||
;; TODO: Multi-line string should produce multi-line comment.
|
||||
(string-append "# " text))
|
||||
((from (image name?) (as name? ?))
|
||||
(words "FROM" image (only-when as (words "AS" as))))
|
||||
((run (shell shellcmd ?) (exec string? *))
|
||||
(exactly-one-of shell exec)
|
||||
(words "RUN" (cond (shell (shell-quote shell))
|
||||
(exec (string-list->json exec)))))
|
||||
((cmd (shell shellcmd ?) (exec string? *))
|
||||
(exactly-one-of shell exec)
|
||||
(words "CMD" (cond (shell (shell-quote shell))
|
||||
(exec (string-list->json exec)))))
|
||||
((label (name string?) (value string?))
|
||||
(words "LABEL" (name=value name value)))
|
||||
((expose (port nat) (protocol string? ?))
|
||||
(words "EXPOSE" (if protocol (tight port "/" protocol) port)))
|
||||
((env (name string?) (value string?))
|
||||
(words "ENV" (name=value name value)))
|
||||
((add (user name? ?) (group name? ?) (dst string?) (src string-or-glob? +))
|
||||
(words "ADD"
|
||||
(only-when (or user group) (tight "--chown=" user ":" group))
|
||||
(string-list->json (append src (list dst)))))
|
||||
((copy (from string? ?) (user string? ?) (group string? ?)
|
||||
(dst string?) (src string-or-glob? +))
|
||||
(words "COPY"
|
||||
(only-when from (tight "--from=" from))
|
||||
(only-when (or user group) (tight "--chown=" user ":" group))
|
||||
(string-list->json (append src (list dst)))))
|
||||
((entrypoint (shell shellcmd ?) (exec string? *))
|
||||
(exactly-one-of shell exec)
|
||||
(words "ENTRYPOINT" (cond (shell (shell-quote shell))
|
||||
(exec (string-list->json exec)))))
|
||||
((volume (mountpoint string?))
|
||||
(words "VOLUME" (string-list->json (list mountpoint))))
|
||||
((user (user string? ?) (group string? ?) (uid nat ?) (gid nat ?))
|
||||
(exactly-one-of uid user)
|
||||
(at-most-one-of gid group)
|
||||
(at-most-one-of uid group)
|
||||
(at-most-one-of gid user)
|
||||
(words "USER" (tight (or user uid)
|
||||
(only-when (or group gid)
|
||||
(tight ":" (or group gid))))))
|
||||
((workdir (path string-with-vars))
|
||||
(words "WORKDIR" (quote-string-with-vars path)))
|
||||
((arg (name string?) (value string?))
|
||||
(words "ARG" (name=value name value)))
|
||||
((stopsignal (signal name?))
|
||||
(words "STOPSIGNAL" signal))
|
||||
((healthcheck (shell shellcmd ?) (exec string? *) (none any? *) #;option*)
|
||||
#;(at-most-one-of none option*)
|
||||
(exactly-one-of shell exec none)
|
||||
(words "HEALTHCHECK"
|
||||
(cond (shell (words "CMD" (shell-quote shell)))
|
||||
(exec (words "CMD" (string-list->json exec)))
|
||||
(none "NONE"))))
|
||||
(else (error "Unknown Dockerfile instruction" instruction))))
|
||||
|
||||
(define (quote-dockerfile instructions)
|
||||
(call-with-port
|
||||
(open-output-string)
|
||||
(lambda (out)
|
||||
(for-each (lambda (x)
|
||||
(write-string (quote-dockerfile-instruction x) out)
|
||||
(newline out))
|
||||
instructions)
|
||||
(get-output-string out))))))
|
||||
|
|
|
|||
|
|
@ -1,103 +0,0 @@
|
|||
;; Copyright 2019 Lassi Kortela
|
||||
;; SPDX-License-Identifier: ISC
|
||||
|
||||
(define (delimit delimiter strings)
|
||||
(if (null? strings) ""
|
||||
(let loop ((strings (cdr strings)) (acc (car strings)))
|
||||
(if (null? strings) acc
|
||||
(loop (cdr strings)
|
||||
(string-append acc delimiter (car strings)))))))
|
||||
|
||||
(define (error* . strings) (error (delimit " " strings)))
|
||||
|
||||
(define (natural? x) (and (integer? x) (exact? x) (>= x 0)))
|
||||
|
||||
(define (the-natural x what)
|
||||
(if (natural? x) (number->string x) (error* what "must be an integer")))
|
||||
|
||||
(define (the-string x what)
|
||||
(if (string? x) x (error* what "must be a string")))
|
||||
|
||||
(define (the-natural-or-string x what)
|
||||
(cond ((string? x) x)
|
||||
((natural? x) (number->string x))
|
||||
(else (error* what "must be an integer or string"))))
|
||||
|
||||
(define (bare-char? char)
|
||||
(case char ((#\- #\. #\/ #\_) #t) (else (ascii-alphanumeric? char))))
|
||||
|
||||
(define (bare-argument? string)
|
||||
(and (not (string=? "" string))
|
||||
(call-with-port (open-input-string string)
|
||||
(lambda (in)
|
||||
(let loop ()
|
||||
(let ((char (read-char in)))
|
||||
(or (eof-object? char)
|
||||
(and (bare-char? char) (loop)))))))))
|
||||
|
||||
(define (quote-string string)
|
||||
(if (bare-argument? string) string
|
||||
(call-with-port
|
||||
(open-input-string string)
|
||||
(lambda (in)
|
||||
(call-with-port
|
||||
(open-output-string)
|
||||
(lambda (out)
|
||||
(write-char #\" out)
|
||||
(let loop ()
|
||||
(let ((char (read-char in)))
|
||||
(unless (eof-object? char)
|
||||
(case char ((#\$ #\` #\" #\\) (write-char #\\ out)))
|
||||
(write-char char out)
|
||||
(loop))))
|
||||
(write-char #\" out)
|
||||
(get-output-string out)))))))
|
||||
|
||||
(define (quote-arg arg)
|
||||
(cond ((string? arg) (quote-string arg))
|
||||
((and (pair? arg) (eq? 'arg (car arg)))
|
||||
(let loop ((parts (cdr arg)) (acc ""))
|
||||
(if (null? parts) acc
|
||||
(let ((part (car parts)))
|
||||
(cond ((and (pair? part) (eq? 'verbatim (car part)))
|
||||
(unless (= 2 (length part))
|
||||
(error "Bad (verbatim ...) argument"))
|
||||
(loop (cdr parts) (string-append acc (cadr part))))
|
||||
(else
|
||||
(loop (cdr parts) (string-append acc part))))))))
|
||||
(else (error "command line argument not a string or glob" arg))))
|
||||
|
||||
(define (redir1 operator path)
|
||||
(string-append operator (quote-string (the-string path "redirect path"))))
|
||||
|
||||
(define (redir2 operator fd path-or-fd)
|
||||
(string-append
|
||||
(the-natural fd "file descriptor")
|
||||
operator
|
||||
(the-natural-or-string path-or-fd "redirect path or file descriptor")))
|
||||
|
||||
(define (cmdgroup group)
|
||||
(match group
|
||||
(('redirect group . fd-map)
|
||||
(let loop ((fd-map fd-map) (acc (cmdgroup group)))
|
||||
(if (null? fd-map) acc
|
||||
(loop (cdr fd-map)
|
||||
(string-append
|
||||
acc " "
|
||||
(match (car fd-map)
|
||||
(('in path) (redir1 "<" path))
|
||||
(('in fd from) (redir2 "<" fd from))
|
||||
(('out path) (redir1 ">" path))
|
||||
(('out fd to) (redir2 ">" fd to))
|
||||
(('append path) (redir1 ">>" path))
|
||||
(('append fd to) (redir2 ">>" fd to))))))))
|
||||
(('subshell group) (string-append "(" (cmdgroup group) ")"))
|
||||
(('begin . groups)
|
||||
(string-append "{ " (delimit "; " (append (map cmdgroup groups)
|
||||
'("}")))))
|
||||
(('and . groups) (delimit " && " (map cmdgroup groups)))
|
||||
(('or . groups) (delimit " || " (map cmdgroup groups)))
|
||||
(('pipe . groups) (delimit " | " (map cmdgroup groups)))
|
||||
(('cmd c . args) (delimit " " (map quote-arg (cons c args))))))
|
||||
|
||||
(define shell-quote cmdgroup)
|
||||
|
|
@ -5,8 +5,109 @@
|
|||
(export shell-quote)
|
||||
(import (scheme base) (scheme write) (chibi match))
|
||||
(cond-expand
|
||||
((library (srfi 175)) (import (srfi 175)))
|
||||
(else (import (scheme char))
|
||||
(begin (define (ascii-alphanumeric? char)
|
||||
(or (char-alphabetic? char) (char-numeric? char))))))
|
||||
(include "shell-quote.scm"))
|
||||
((library (srfi 175)) (import (srfi 175)))
|
||||
(else (import (scheme char))
|
||||
(begin (define (ascii-alphanumeric? char)
|
||||
(or (char-alphabetic? char) (char-numeric? char))))))
|
||||
(begin
|
||||
|
||||
(define (delimit delimiter strings)
|
||||
(if (null? strings) ""
|
||||
(let loop ((strings (cdr strings)) (acc (car strings)))
|
||||
(if (null? strings) acc
|
||||
(loop (cdr strings)
|
||||
(string-append acc delimiter (car strings)))))))
|
||||
|
||||
(define (error* . strings) (error (delimit " " strings)))
|
||||
|
||||
(define (natural? x) (and (integer? x) (exact? x) (>= x 0)))
|
||||
|
||||
(define (the-natural x what)
|
||||
(if (natural? x) (number->string x) (error* what "must be an integer")))
|
||||
|
||||
(define (the-string x what)
|
||||
(if (string? x) x (error* what "must be a string")))
|
||||
|
||||
(define (the-natural-or-string x what)
|
||||
(cond ((string? x) x)
|
||||
((natural? x) (number->string x))
|
||||
(else (error* what "must be an integer or string"))))
|
||||
|
||||
(define (bare-char? char)
|
||||
(case char ((#\- #\. #\/ #\_) #t) (else (ascii-alphanumeric? char))))
|
||||
|
||||
(define (bare-argument? string)
|
||||
(and (not (string=? "" string))
|
||||
(call-with-port (open-input-string string)
|
||||
(lambda (in)
|
||||
(let loop ()
|
||||
(let ((char (read-char in)))
|
||||
(or (eof-object? char)
|
||||
(and (bare-char? char) (loop)))))))))
|
||||
|
||||
(define (quote-string string)
|
||||
(if (bare-argument? string) string
|
||||
(call-with-port
|
||||
(open-input-string string)
|
||||
(lambda (in)
|
||||
(call-with-port
|
||||
(open-output-string)
|
||||
(lambda (out)
|
||||
(write-char #\" out)
|
||||
(let loop ()
|
||||
(let ((char (read-char in)))
|
||||
(unless (eof-object? char)
|
||||
(case char ((#\$ #\` #\" #\\) (write-char #\\ out)))
|
||||
(write-char char out)
|
||||
(loop))))
|
||||
(write-char #\" out)
|
||||
(get-output-string out)))))))
|
||||
|
||||
(define (quote-arg arg)
|
||||
(cond ((string? arg) (quote-string arg))
|
||||
((and (pair? arg) (eq? 'arg (car arg)))
|
||||
(let loop ((parts (cdr arg)) (acc ""))
|
||||
(if (null? parts) acc
|
||||
(let ((part (car parts)))
|
||||
(cond ((and (pair? part) (eq? 'verbatim (car part)))
|
||||
(unless (= 2 (length part))
|
||||
(error "Bad (verbatim ...) argument"))
|
||||
(loop (cdr parts) (string-append acc (cadr part))))
|
||||
(else
|
||||
(loop (cdr parts) (string-append acc part))))))))
|
||||
(else (error "command line argument not a string or glob" arg))))
|
||||
|
||||
(define (redir1 operator path)
|
||||
(string-append operator (quote-string (the-string path "redirect path"))))
|
||||
|
||||
(define (redir2 operator fd path-or-fd)
|
||||
(string-append
|
||||
(the-natural fd "file descriptor")
|
||||
operator
|
||||
(the-natural-or-string path-or-fd "redirect path or file descriptor")))
|
||||
|
||||
(define (cmdgroup group)
|
||||
(match group
|
||||
(('redirect group . fd-map)
|
||||
(let loop ((fd-map fd-map) (acc (cmdgroup group)))
|
||||
(if (null? fd-map) acc
|
||||
(loop (cdr fd-map)
|
||||
(string-append
|
||||
acc " "
|
||||
(match (car fd-map)
|
||||
(('in path) (redir1 "<" path))
|
||||
(('in fd from) (redir2 "<" fd from))
|
||||
(('out path) (redir1 ">" path))
|
||||
(('out fd to) (redir2 ">" fd to))
|
||||
(('append path) (redir1 ">>" path))
|
||||
(('append fd to) (redir2 ">>" fd to))))))))
|
||||
(('subshell group) (string-append "(" (cmdgroup group) ")"))
|
||||
(('begin . groups)
|
||||
(string-append "{ " (delimit "; " (append (map cmdgroup groups)
|
||||
'("}")))))
|
||||
(('and . groups) (delimit " && " (map cmdgroup groups)))
|
||||
(('or . groups) (delimit " || " (map cmdgroup groups)))
|
||||
(('pipe . groups) (delimit " | " (map cmdgroup groups)))
|
||||
(('cmd c . args) (delimit " " (map quote-arg (cons c args))))))
|
||||
|
||||
(define shell-quote cmdgroup)))
|
||||
|
|
|
|||
|
|
@ -2,15 +2,16 @@
|
|||
set -eu
|
||||
cd "$(dirname "$0")"
|
||||
echo "Entering directory '$PWD'"
|
||||
payload="trivial-tar-writer.scm trivial-tar-writer-test.sh"
|
||||
payload="trivial-tar-writer.sld trivial-tar-writer-test.sh"
|
||||
set -x
|
||||
chibi-scheme -A . trivial-tar-writer-test.scm $payload \
|
||||
chibi-scheme -A .. trivial-tar-writer-test.scm $payload \
|
||||
>trivial-tar-writer-test-chibi.tar
|
||||
gsi-script . trivial-tar-writer-test.scm $payload \
|
||||
gsi-script .. trivial-tar-writer-test.scm $payload \
|
||||
>trivial-tar-writer-test-gambit.tar
|
||||
gosh -A . trivial-tar-writer-test.scm $payload \
|
||||
gosh -A .. trivial-tar-writer-test.scm $payload \
|
||||
>trivial-tar-writer-test-gauche.tar
|
||||
kawa -Dkawa.import.path="$PWD/*.sld" trivial-tar-writer-test.scm $payload \
|
||||
kawa -Dkawa.import.path="$(cd .. && echo "$PWD/*.sld")" \
|
||||
trivial-tar-writer-test.scm $payload \
|
||||
>trivial-tar-writer-test-kawa.tar
|
||||
bsdtar -cf trivial-tar-writer-test-bsd.tar $payload
|
||||
gtar -cf trivial-tar-writer-test-gnu.tar $payload
|
||||
|
|
|
|||
|
|
@ -1,64 +0,0 @@
|
|||
;; Copyright 2019 Lassi Kortela
|
||||
;; SPDX-License-Identifier: ISC
|
||||
|
||||
(define tar-owner (make-parameter (cons 0 "root")))
|
||||
(define tar-group (make-parameter (cons 0 "root")))
|
||||
(define tar-unix-mode (make-parameter #o644))
|
||||
(define tar-unix-time (make-parameter 0))
|
||||
|
||||
(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)
|
||||
(unless (integer? number) (error "tar: not an integer"))
|
||||
(when (< number 0) (error "tar: negative integer"))
|
||||
(let* ((bytes (string->utf8 (number->string number 8)))
|
||||
(nzero (- nbyte 1 (bytevector-length bytes))))
|
||||
(when (< nzero 0) (error "tar: number too big"))
|
||||
(bytevector-append (make-bytevector nzero (char->integer #\0))
|
||||
bytes (bytevector 0))))
|
||||
|
||||
(define (tar-write-file fake-path bytes)
|
||||
(let* ((nbyte (bytevector-length bytes))
|
||||
(nnull (- 512 (truncate-remainder nbyte 512)))
|
||||
(header-before-checksum
|
||||
(bytevector-append
|
||||
(tar-string 100 fake-path)
|
||||
(tar-octal 8 (tar-unix-mode))
|
||||
(tar-octal 8 (car (tar-owner)))
|
||||
(tar-octal 8 (car (tar-group)))
|
||||
(tar-octal 12 nbyte)
|
||||
(tar-octal 12 (tar-unix-time))))
|
||||
(header-after-checksum
|
||||
(bytevector-append
|
||||
(bytevector (char->integer #\space))
|
||||
(bytevector (char->integer #\0))
|
||||
(tar-string 100 "")
|
||||
(tar-string 8 "ustar ")
|
||||
(tar-string 32 (cdr (tar-owner)))
|
||||
(tar-string 32 (cdr (tar-group)))
|
||||
(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 (tar-write-end)
|
||||
(write-bytevector nulls)
|
||||
(write-bytevector nulls))
|
||||
|
|
@ -1,3 +1,6 @@
|
|||
;; Copyright 2019 Lassi Kortela
|
||||
;; SPDX-License-Identifier: ISC
|
||||
|
||||
(define-library (lassik trivial-tar-writer)
|
||||
(export tar-owner
|
||||
tar-group
|
||||
|
|
@ -6,4 +9,66 @@
|
|||
tar-write-file
|
||||
tar-write-end)
|
||||
(import (scheme base))
|
||||
(include "trivial-tar-writer.scm"))
|
||||
(begin
|
||||
|
||||
(define tar-owner (make-parameter (cons 0 "root")))
|
||||
(define tar-group (make-parameter (cons 0 "root")))
|
||||
(define tar-unix-mode (make-parameter #o644))
|
||||
(define tar-unix-time (make-parameter 0))
|
||||
|
||||
(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)
|
||||
(unless (integer? number) (error "tar: not an integer"))
|
||||
(when (< number 0) (error "tar: negative integer"))
|
||||
(let* ((bytes (string->utf8 (number->string number 8)))
|
||||
(nzero (- nbyte 1 (bytevector-length bytes))))
|
||||
(when (< nzero 0) (error "tar: number too big"))
|
||||
(bytevector-append (make-bytevector nzero (char->integer #\0))
|
||||
bytes (bytevector 0))))
|
||||
|
||||
(define (tar-write-file fake-path bytes)
|
||||
(let* ((nbyte (bytevector-length bytes))
|
||||
(nnull (- 512 (truncate-remainder nbyte 512)))
|
||||
(header-before-checksum
|
||||
(bytevector-append
|
||||
(tar-string 100 fake-path)
|
||||
(tar-octal 8 (tar-unix-mode))
|
||||
(tar-octal 8 (car (tar-owner)))
|
||||
(tar-octal 8 (car (tar-group)))
|
||||
(tar-octal 12 nbyte)
|
||||
(tar-octal 12 (tar-unix-time))))
|
||||
(header-after-checksum
|
||||
(bytevector-append
|
||||
(bytevector (char->integer #\space))
|
||||
(bytevector (char->integer #\0))
|
||||
(tar-string 100 "")
|
||||
(tar-string 8 "ustar ")
|
||||
(tar-string 32 (cdr (tar-owner)))
|
||||
(tar-string 32 (cdr (tar-group)))
|
||||
(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 (tar-write-end)
|
||||
(write-bytevector nulls)
|
||||
(write-bytevector nulls))))
|
||||
|
|
|
|||
|
|
@ -1,123 +0,0 @@
|
|||
;; Copyright 2019 Lassi Kortela
|
||||
;; SPDX-License-Identifier: ISC
|
||||
|
||||
(define (unpack-using/many need? type key entry)
|
||||
(if (not entry)
|
||||
(and need? (error "Required key missing" key))
|
||||
(let check ((tail (cdr entry)))
|
||||
(cond ((null? tail)
|
||||
(cdr entry))
|
||||
((not (pair? tail))
|
||||
(error "Values do not form a proper list" key (cdr entry)))
|
||||
((not (type (car tail)))
|
||||
(error "Key has value of the wrong type" key (car tail)))
|
||||
(else (check (cdr tail)))))))
|
||||
|
||||
(define (unpack-using/one need? type key entry)
|
||||
(cond ((not entry)
|
||||
(and need? (error "Required key missing" key)))
|
||||
((not (pair? (cdr entry)))
|
||||
(error "Key is present but has no value" key))
|
||||
((not (null? (cddr entry)))
|
||||
(error "Key has more than one value" key (cdr entry)))
|
||||
((not (type (cadr entry)))
|
||||
(error "Key has value of the wrong type" key (cadr entry)))
|
||||
(else (cadr entry))))
|
||||
|
||||
(define-syntax unpack-using/let
|
||||
(syntax-rules ()
|
||||
((_ (lets ...) () body ...)
|
||||
(let (lets ...) body ...))
|
||||
((_ (lets ...) ((key more-stuff ...) more-rules ...) body ...)
|
||||
(unpack-using/let (lets ... (key #f)) (more-rules ...) body ...))))
|
||||
|
||||
(define-syntax unpack-using/case
|
||||
(syntax-rules ()
|
||||
((_ (cases ...) this-key val)
|
||||
(case this-key
|
||||
cases ...
|
||||
(else (error "Unknown key" this-key))))
|
||||
((_ (cases ...) this-key val (key more-stuff ...) more-rules ...)
|
||||
(unpack-using/case (cases ... ((key)
|
||||
(when key (error "Duplicate key" 'key))
|
||||
(set! key (cons 'key val))))
|
||||
this-key val more-rules ...))))
|
||||
|
||||
(define-syntax unpack-using/rule
|
||||
(syntax-rules (* + ?)
|
||||
((_ (key type *)) (set! key (unpack-using/many #f type 'key key)))
|
||||
((_ (key type +)) (set! key (unpack-using/many #t type 'key key)))
|
||||
((_ (key type ?)) (set! key (unpack-using/one #f type 'key key)))
|
||||
((_ (key type)) (set! key (unpack-using/one #t type 'key key)))))
|
||||
|
||||
(define-syntax unpack-using/set
|
||||
(syntax-rules ()
|
||||
((_ (sets ...))
|
||||
(begin sets ... #f))
|
||||
((_ (sets ...) rule rules ...)
|
||||
(unpack-using/set (sets ... (unpack-using/rule rule)) rules ...))))
|
||||
|
||||
(define-syntax unpack-using
|
||||
(syntax-rules (key val)
|
||||
((_ for-each-pair pairs (rules ...) body ...)
|
||||
(unpack-using/let () (rules ...)
|
||||
(for-each-pair
|
||||
(lambda (key val) (unpack-using/case () key val rules ...))
|
||||
pairs)
|
||||
(unpack-using/set () rules ...)
|
||||
body ...))))
|
||||
|
||||
;;
|
||||
|
||||
(define (alist-for-each proc alist)
|
||||
(cond ((null? alist) #f)
|
||||
((not (pair? alist)) (error "Not a proper list" alist))
|
||||
((not (pair? (car alist))) (error "Alist entry is not a pair" alist))
|
||||
(else (proc (caar alist) (cdar alist))
|
||||
(alist-for-each proc (cdr alist)))))
|
||||
|
||||
(define-syntax unpack
|
||||
(syntax-rules ()
|
||||
((_ alist (rules ...) body ...)
|
||||
(unpack-using alist-for-each alist (rules ...) body ...))))
|
||||
|
||||
(define-syntax unpack-case/aux
|
||||
(syntax-rules ()
|
||||
((_ (cases ...) entry)
|
||||
(case (car entry) cases ...))
|
||||
((_ (cases ...) entry (else body ...))
|
||||
(unpack-case/aux
|
||||
(cases ... (else body ...))
|
||||
entry))
|
||||
((_ (cases ...) entry ((head rules ...) body ...))
|
||||
(unpack-case/aux
|
||||
(cases ... ((head) (unpack (cdr entry) (rules ...) body ...)))
|
||||
entry))
|
||||
((_ (cases ...) entry ((head rules ...) body ...) more-cases ...)
|
||||
(unpack-case/aux
|
||||
(cases ... ((head) (unpack (cdr entry) (rules ...) body ...)))
|
||||
entry more-cases ...))))
|
||||
|
||||
(define-syntax unpack-case
|
||||
(syntax-rules (entry)
|
||||
((_ entry-expr cases ...)
|
||||
(let ((entry entry-expr))
|
||||
(unpack-case/aux () entry cases ...)))))
|
||||
|
||||
;;
|
||||
|
||||
(define (count-truthy . lis)
|
||||
(let loop ((lis lis) (n 0))
|
||||
(if (null? lis) n (loop (cdr lis) (if (car lis) (+ n 1) n)))))
|
||||
|
||||
(define-syntax at-most-one-of
|
||||
(syntax-rules ()
|
||||
((_ identifiers ...)
|
||||
(unless (<= (count-truthy identifiers ...) 1)
|
||||
(error "At most one of these must be given" '(identifiers ...))))))
|
||||
|
||||
(define-syntax exactly-one-of
|
||||
(syntax-rules ()
|
||||
((_ identifiers ...)
|
||||
(unless (= (count-truthy identifiers ...) 1)
|
||||
(error "Exactly one of these must be given" '(identifiers ...))))))
|
||||
|
|
@ -17,4 +17,125 @@
|
|||
|
||||
unpack-case/aux)
|
||||
(import (scheme base))
|
||||
(include "unpack-assoc.scm"))
|
||||
(begin
|
||||
|
||||
(define (unpack-using/many need? type key entry)
|
||||
(if (not entry)
|
||||
(and need? (error "Required key missing" key))
|
||||
(let check ((tail (cdr entry)))
|
||||
(cond ((null? tail)
|
||||
(cdr entry))
|
||||
((not (pair? tail))
|
||||
(error "Values do not form a proper list" key (cdr entry)))
|
||||
((not (type (car tail)))
|
||||
(error "Key has value of the wrong type" key (car tail)))
|
||||
(else (check (cdr tail)))))))
|
||||
|
||||
(define (unpack-using/one need? type key entry)
|
||||
(cond ((not entry)
|
||||
(and need? (error "Required key missing" key)))
|
||||
((not (pair? (cdr entry)))
|
||||
(error "Key is present but has no value" key))
|
||||
((not (null? (cddr entry)))
|
||||
(error "Key has more than one value" key (cdr entry)))
|
||||
((not (type (cadr entry)))
|
||||
(error "Key has value of the wrong type" key (cadr entry)))
|
||||
(else (cadr entry))))
|
||||
|
||||
(define-syntax unpack-using/let
|
||||
(syntax-rules ()
|
||||
((_ (lets ...) () body ...)
|
||||
(let (lets ...) body ...))
|
||||
((_ (lets ...) ((key more-stuff ...) more-rules ...) body ...)
|
||||
(unpack-using/let (lets ... (key #f)) (more-rules ...) body ...))))
|
||||
|
||||
(define-syntax unpack-using/case
|
||||
(syntax-rules ()
|
||||
((_ (cases ...) this-key val)
|
||||
(case this-key
|
||||
cases ...
|
||||
(else (error "Unknown key" this-key))))
|
||||
((_ (cases ...) this-key val (key more-stuff ...) more-rules ...)
|
||||
(unpack-using/case (cases ... ((key)
|
||||
(when key (error "Duplicate key" 'key))
|
||||
(set! key (cons 'key val))))
|
||||
this-key val more-rules ...))))
|
||||
|
||||
(define-syntax unpack-using/rule
|
||||
(syntax-rules (* + ?)
|
||||
((_ (key type *)) (set! key (unpack-using/many #f type 'key key)))
|
||||
((_ (key type +)) (set! key (unpack-using/many #t type 'key key)))
|
||||
((_ (key type ?)) (set! key (unpack-using/one #f type 'key key)))
|
||||
((_ (key type)) (set! key (unpack-using/one #t type 'key key)))))
|
||||
|
||||
(define-syntax unpack-using/set
|
||||
(syntax-rules ()
|
||||
((_ (sets ...))
|
||||
(begin sets ... #f))
|
||||
((_ (sets ...) rule rules ...)
|
||||
(unpack-using/set (sets ... (unpack-using/rule rule)) rules ...))))
|
||||
|
||||
(define-syntax unpack-using
|
||||
(syntax-rules (key val)
|
||||
((_ for-each-pair pairs (rules ...) body ...)
|
||||
(unpack-using/let () (rules ...)
|
||||
(for-each-pair
|
||||
(lambda (key val) (unpack-using/case () key val rules ...))
|
||||
pairs)
|
||||
(unpack-using/set () rules ...)
|
||||
body ...))))
|
||||
|
||||
;;
|
||||
|
||||
(define (alist-for-each proc alist)
|
||||
(cond ((null? alist) #f)
|
||||
((not (pair? alist)) (error "Not a proper list" alist))
|
||||
((not (pair? (car alist))) (error "Alist entry is not a pair" alist))
|
||||
(else (proc (caar alist) (cdar alist))
|
||||
(alist-for-each proc (cdr alist)))))
|
||||
|
||||
(define-syntax unpack
|
||||
(syntax-rules ()
|
||||
((_ alist (rules ...) body ...)
|
||||
(unpack-using alist-for-each alist (rules ...) body ...))))
|
||||
|
||||
(define-syntax unpack-case/aux
|
||||
(syntax-rules ()
|
||||
((_ (cases ...) entry)
|
||||
(case (car entry) cases ...))
|
||||
((_ (cases ...) entry (else body ...))
|
||||
(unpack-case/aux
|
||||
(cases ... (else body ...))
|
||||
entry))
|
||||
((_ (cases ...) entry ((head rules ...) body ...))
|
||||
(unpack-case/aux
|
||||
(cases ... ((head) (unpack (cdr entry) (rules ...) body ...)))
|
||||
entry))
|
||||
((_ (cases ...) entry ((head rules ...) body ...) more-cases ...)
|
||||
(unpack-case/aux
|
||||
(cases ... ((head) (unpack (cdr entry) (rules ...) body ...)))
|
||||
entry more-cases ...))))
|
||||
|
||||
(define-syntax unpack-case
|
||||
(syntax-rules (entry)
|
||||
((_ entry-expr cases ...)
|
||||
(let ((entry entry-expr))
|
||||
(unpack-case/aux () entry cases ...)))))
|
||||
|
||||
;;
|
||||
|
||||
(define (count-truthy . lis)
|
||||
(let loop ((lis lis) (n 0))
|
||||
(if (null? lis) n (loop (cdr lis) (if (car lis) (+ n 1) n)))))
|
||||
|
||||
(define-syntax at-most-one-of
|
||||
(syntax-rules ()
|
||||
((_ identifiers ...)
|
||||
(unless (<= (count-truthy identifiers ...) 1)
|
||||
(error "At most one of these must be given" '(identifiers ...))))))
|
||||
|
||||
(define-syntax exactly-one-of
|
||||
(syntax-rules ()
|
||||
((_ identifiers ...)
|
||||
(unless (= (count-truthy identifiers ...) 1)
|
||||
(error "Exactly one of these must be given" '(identifiers ...))))))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue