From 36e400b72a9d2c94b61a327f7032b86cf3708169 Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Sat, 22 Jun 2019 22:30:44 +0300 Subject: [PATCH] Initial commit --- LICENSE | 33 +++++++++++++------------- trivial-tar-writer.scm | 54 ++++++++++++++++++++++++++++++++++++++++++ trivial-tar-writer.sld | 6 +++++ 3 files changed, 77 insertions(+), 16 deletions(-) create mode 100644 trivial-tar-writer.scm create mode 100644 trivial-tar-writer.sld diff --git a/LICENSE b/LICENSE index eb8e2a2..7e4c94c 100644 --- a/LICENSE +++ b/LICENSE @@ -1,21 +1,22 @@ MIT License -Copyright (c) 2019 Scheme Documentation +Copyright 2019 Lassi Kortela -Permission is hereby granted, free of charge, to any person obtaining a copy -of this software and associated documentation files (the "Software"), to deal -in the Software without restriction, including without limitation the rights -to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -SOFTWARE. +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/trivial-tar-writer.scm b/trivial-tar-writer.scm new file mode 100644 index 0000000..6815f45 --- /dev/null +++ b/trivial-tar-writer.scm @@ -0,0 +1,54 @@ +;;; Copyright (c) 2019 Lassi Kortela +;;; SPDX-License-Identifier: ISC + +(define nulls (make-bytevector 512 0)) +(define zeros (make-bytevector 12 (char->integer #\0))) + +(define (tar-poke-string header at nbyte string) + (let* ((bytes (string->utf8 string)) + (nnull (- nbyte (bytevector-length bytes)))) + (when (< nnull 0) (error "tar: string too long")) + (bytevector-copy! header at bytes))) + +(define (tar-poke-octal header at 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))) + +(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-write-file fake-path bytes) + (let* ((header (make-bytevector 512 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) + (write-bytevector bytes) + (write-bytevector nulls (current-output-port) 0 nnull))) + +(define (tar-poke-end) + (write-bytevector nulls) + (write-bytevector nulls)) diff --git a/trivial-tar-writer.sld b/trivial-tar-writer.sld new file mode 100644 index 0000000..3d820c4 --- /dev/null +++ b/trivial-tar-writer.sld @@ -0,0 +1,6 @@ +(define-library (trivial-tar-writer) + (export tar-write-file) + (import (scheme base) + (scheme char) + (scheme write)) + (include "trivial-tar-writer.scm"))