lassik
/
scheme
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Do not mutate bytevectors

This commit is contained in:
Lassi Kortela 2019-12-27 15:24:11 +02:00
parent 6141ea5c6b
commit 281497b612
1 changed files with 37 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
trivial-tar-writer.scm
View File

@ -2,51 +2,58 @@
;; SPDX-License-Identifier: ISC
(define nulls (make-bytevector 512 0))
(define zeros (make-bytevector 12 (char->integer #\0)))
(define blank-checksum (make-bytevector 7 (char->integer #\space)))
(define (tar-poke-string! header at nbyte string)
(define (tar-string nbyte string)
(let* ((bytes (string->utf8 string))
(nnull (- nbyte (bytevector-length bytes))))
(when (< nnull 1) (error "tar: string too long"))
(bytevector-copy! header at bytes)
(bytevector-copy! header (+ at (bytevector-length bytes)) nulls 0 nnull)))
(bytevector-append bytes (make-bytevector nnull 0))))
(define (tar-poke-octal! header at nbyte number)
(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-copy! header at zeros 0 nzero)
(bytevector-copy! header (+ at nzero) bytes)
(bytevector-u8-set! header (+ at nbyte -1) 0)))
(bytevector-append (make-bytevector nzero (char->integer #\0))
bytes (bytevector 0))))
(define (tar-header-checksum header)
(let ((n (bytevector-length header)))
(let loop ((i 0) (sum 0))
(if (= i n)
(truncate-remainder sum (expt 8 6))
(loop (+ i 1) (+ sum (bytevector-u8-ref header i)))))))
(define (tar-checksum . vectors)
(let loop-vectors ((vectors vectors) (sum 0))
(if (null? vectors) (truncate-remainder sum (expt 8 6))
(let* ((v (car vectors)) (n (bytevector-length v)))
(let loop-bytes ((i 0) (sum sum))
(if (= i n) (loop-vectors (cdr vectors) sum)
(loop-bytes (+ i 1) (+ sum (bytevector-u8-ref v i)))))))))
(define (tar-write-file fake-path bytes)
(let* ((header (make-bytevector 512 0))
(let* ((unix-time-now 0)
(nbyte (bytevector-length bytes))
(nnull (- 512 (truncate-remainder nbyte 512)))
(unix-time-now 0))
(tar-poke-string! header 0 100 fake-path)
(tar-poke-octal! header 100 8 #o644)
(tar-poke-octal! header 108 8 0)
(tar-poke-octal! header 116 8 0)
(tar-poke-octal! header 124 12 nbyte)
(tar-poke-octal! header 136 12 unix-time-now)
(bytevector-copy! header 148 (make-bytevector 8 (char->integer #\space)))
(bytevector-u8-set! header 156 (char->integer #\0))
(tar-poke-string! header 157 100 "")
(tar-poke-string! header 257 8 "ustar ")
(tar-poke-string! header 265 32 "root")
(tar-poke-string! header 297 32 "root")
(tar-poke-octal! header 148 7 (tar-header-checksum header))
(write-bytevector header)
(header-before-checksum
(bytevector-append
(tar-string 100 fake-path)
(tar-octal 8 #o644)
(tar-octal 8 0)
(tar-octal 8 0)
(tar-octal 12 nbyte)
(tar-octal 12 unix-time-now)))
(header-after-checksum
(bytevector-append
(bytevector (char->integer #\space))
(bytevector (char->integer #\0))
(tar-string 100 "")
(tar-string 8 "ustar ")
(tar-string 32 "root")
(tar-string 32 "root")
(make-bytevector 183 0)))
(checksum (tar-octal 7 (tar-checksum header-before-checksum
blank-checksum
header-after-checksum))))
(write-bytevector header-before-checksum)
(write-bytevector checksum)
(write-bytevector header-after-checksum)
(write-bytevector bytes)
(write-bytevector nulls (current-output-port) 0 nnull)))