scheme/trivial-tar-writer.scm

65 lines
2.5 KiB
Scheme
Raw Normal View History

2019-06-23 04:53:23 -04:00
;; Copyright 2019 Lassi Kortela
;; SPDX-License-Identifier: ISC
2019-06-22 15:30:44 -04:00
(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))
2019-06-22 15:30:44 -04:00
(define nulls (make-bytevector 512 0))
2019-12-27 08:24:11 -05:00
(define blank-checksum (make-bytevector 7 (char->integer #\space)))
2019-06-22 15:30:44 -04:00
2019-12-27 19:12:24 -05:00
(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))))))
2019-12-27 08:24:11 -05:00
(define (tar-string nbyte string)
2019-06-22 15:30:44 -04:00
(let* ((bytes (string->utf8 string))
(nnull (- nbyte (bytevector-length bytes))))
(when (< nnull 1) (error "tar: string too long"))
2019-12-27 08:24:11 -05:00
(bytevector-append bytes (make-bytevector nnull 0))))
2019-06-22 15:30:44 -04:00
2019-12-27 08:24:11 -05:00
(define (tar-octal nbyte number)
2019-06-22 15:30:44 -04:00
(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"))
2019-12-27 08:24:11 -05:00
(bytevector-append (make-bytevector nzero (char->integer #\0))
bytes (bytevector 0))))
2019-06-22 15:30:44 -04:00
(define (tar-write-file fake-path bytes)
2019-12-27 19:49:28 -05:00
(let* ((nbyte (bytevector-length bytes))
2019-06-22 15:30:44 -04:00
(nnull (- 512 (truncate-remainder nbyte 512)))
2019-12-27 08:24:11 -05:00
(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)))
2019-12-27 08:24:11 -05:00
(tar-octal 12 nbyte)
(tar-octal 12 (tar-unix-time))))
2019-12-27 08:24:11 -05:00
(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)))
2019-12-27 08:24:11 -05:00
(make-bytevector 183 0)))
2019-12-27 19:12:24 -05:00
(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))))))
2019-12-27 08:24:11 -05:00
(write-bytevector header-before-checksum)
(write-bytevector checksum)
(write-bytevector header-after-checksum)
2019-06-22 15:30:44 -04:00
(write-bytevector bytes)
(write-bytevector nulls (current-output-port) 0 nnull)))
2019-06-23 04:55:48 -04:00
(define (tar-write-end)
2019-06-22 15:30:44 -04:00
(write-bytevector nulls)
(write-bytevector nulls))