99 lines
3.3 KiB
Scheme
99 lines
3.3 KiB
Scheme
(import (scheme base)
|
|
(scheme file)
|
|
(srfi 19)
|
|
(srfi 132)
|
|
(srfi 170)
|
|
(srfi 193)
|
|
(crc))
|
|
|
|
(define space (char->integer #\space))
|
|
(define equal (char->integer #\=))
|
|
(define linefeed (char->integer #\newline))
|
|
|
|
(define (add-length-digits length)
|
|
(let fixed-point ((count 1))
|
|
(let* ((digits (number->string (+ count length)))
|
|
(new-count (string-length digits)))
|
|
(if (= count new-count) digits (fixed-point new-count)))))
|
|
|
|
(define (record-length-digits keyword-length value-length)
|
|
(add-length-digits (+ 1 keyword-length 1 value-length 1)))
|
|
|
|
(define (begin-record keyword value-length)
|
|
(let* ((keyword-bytes (string->utf8 keyword))
|
|
(keyword-length (bytevector-length keyword-bytes)))
|
|
(write-bytevector
|
|
(string->utf8 (record-length-digits keyword-length value-length)))
|
|
(write-u8 space)
|
|
(write-bytevector keyword-bytes)
|
|
(write-u8 equal)))
|
|
|
|
(define (pack-string keyword value)
|
|
(let* ((value-bytes (string->utf8 value))
|
|
(value-length (bytevector-length value-bytes)))
|
|
(begin-record keyword value-length)
|
|
(write-bytevector value-bytes)
|
|
(write-u8 linefeed)))
|
|
|
|
(define (pack-number keyword value)
|
|
(pack-string keyword (number->string value)))
|
|
|
|
(define (pack-timestamp keyword time)
|
|
(let ((date (time-utc->date time 0)))
|
|
(pack-string keyword (date->string date "~s"))))
|
|
|
|
(define (pack-header path info)
|
|
(let ((user (user-info (file-info:uid info)))
|
|
(group (group-info (file-info:gid info))))
|
|
(pack-string "path" path)
|
|
(when user (pack-string "uname" (user-info:name user)))
|
|
(when group (pack-string "gname" (group-info:name group)))
|
|
(pack-number "uid" (file-info:uid info))
|
|
(pack-number "gid" (file-info:gid info))
|
|
(pack-timestamp "mtime" (file-info:mtime info))
|
|
(pack-number "size" (file-info:size info))))
|
|
|
|
(define (pack-data path info)
|
|
(let ((size (file-info:size info)))
|
|
(begin-record "data" (+ 2 size))
|
|
(write-u8 linefeed)
|
|
(write-u8 linefeed)
|
|
(call-with-port (open-binary-input-file path)
|
|
(lambda (input)
|
|
(let ((chunk (expt 2 18)))
|
|
(let loop ((crc 0) (remain size))
|
|
(cond ((positive? remain)
|
|
(let ((bytes (read-bytevector (min chunk remain) input)))
|
|
(when (eof-object? bytes) (error "Truncated file"))
|
|
(write-bytevector bytes)
|
|
(loop (crc-update-bytes crc bytes)
|
|
(- remain (bytevector-length bytes)))))
|
|
(else
|
|
(write-u8 linefeed)
|
|
(let ((crc (crc-update-length crc size)))
|
|
(pack-number "cksum" (crc-complement crc)))))))))))
|
|
|
|
(define (pack-file path)
|
|
(let ((info (file-info path #f)))
|
|
(pack-header path info)
|
|
(cond ((file-info-directory? info)
|
|
(pack-files path))
|
|
((file-info-symlink? info)
|
|
(error "Symlink" path))
|
|
((file-info-regular? info)
|
|
(pack-data path info))
|
|
(else
|
|
(error "Cannot pack" path)))))
|
|
|
|
(define (pack-files dir)
|
|
(for-each (lambda (name)
|
|
(pack-file (string-append dir "/" name)))
|
|
(list-sort string<? (directory-files dir))))
|
|
|
|
(define (main)
|
|
(write-string "#! /usr/bin/env feather-archive")
|
|
(newline)
|
|
(for-each pack-file (command-args)))
|
|
|
|
(main)
|