diff options
Diffstat (limited to 'gz.scm')
| -rw-r--r-- | gz.scm | 155 |
1 files changed, 155 insertions, 0 deletions
@@ -0,0 +1,155 @@ +(import (scheme base) + (chibi bytevector) + ;; (srfi 1) + (srfi 33)) + +(define FTEXT 0) +(define FHCRC 1) +(define FEXTRA 2) +(define FNAME 3) +(define FCOMMENT 4) + +(define (bit-description bit) + (cond ((= bit FTEXT) "File is probably text") + ((= bit FHCRC) "CRC16 Checksum is present") + ((= bit FEXTRA) "Extra Field is present") + ((= bit FNAME) "Filename is present") + ((= bit FCOMMENT) "A Comment is present") + (else "Unknown Bit"))) + +(define (filter proc lst) + (cond ((null? lst) '()) + ((proc (car lst)) (cons (car lst) + (filter proc (cdr lst)))) + (else (filter proc (cdr lst))))) + +(define (parse-flags int) + (filter string? + (map (lambda (bit) + (if (bit-set? bit int) + (string-append (bit-description bit) "\n") + #f)) + (list FTEXT FHCRC FEXTRA FNAME FCOMMENT)))) + +(define (os-name i) + (case i + ((0) "Fat filesystem (MS-DOS, OS/2, NT/Win32)") + ((1) "Amiga") + ((2) "VMS (or OpenVMS)") + ((3) "Unix") + ((4) "VM/CMS") + ((5) "Atari TOS") + ((6) "HPFS fileesystem (OS/2, NT)") + ((7) "Macintosh") + ((8) "Z-System") + ((9) "CP/M") + ((10) "TOPS-20") + ((11) "NTFS filesystem (NT)") + ((12) "QDOS") + ((13) "Acorn RISCOS") + (else "unknown"))) + +(define (bytevector-search bv el idx) + (cond ((>= idx (bytevector-length bv)) #f) + ((equal? el (bytevector-u8-ref bv idx)) idx) + (else (bytevector-search bv el (+ idx 1))))) + +(define make-segment vector) + +(define (get-segment bv addr) + (call/cc + (lambda (return) + (when (> 10 (bytevector-length bv)) + (return (make-segment 0 (bytevector-length bv) + "Not a GZIP file"))) + + (let () + (define ptr 0) + + (define id1 (bytevector-u8-ref bv 0)) + (define id2 (bytevector-u8-ref bv 1)) + (define cm (bytevector-u8-ref bv 2)) + (define flg (bytevector-u8-ref bv 3)) + (define mtime (bytevector-u32-ref-le bv 4)) + (define xfl (bytevector-u8-ref bv 8)) + (define os (bytevector-u8-ref bv 9)) + + (cond ((= addr 0) (return (make-segment 0 1 "ID1 = 31"))) + ((= addr 1) (return (make-segment 1 2 "ID2 = 139"))) + ((= addr 2) (return (make-segment + 2 3 + "CM (Compression Method)\nCM = 8 is deflate"))) + ((= addr 3) (return (make-segment 3 4 + (apply string-append (parse-flags (bytevector-u8-ref bv addr)))))) + ((<= 4 addr 7) (return (make-segment + 4 8 (string-append "mtime=" + (number->string mtime))))) + ((= addr 8) (return (make-segment 8 9 "XFL"))) + ((= addr 9) (return (make-segment 9 10 (string-append "OS: " (os-name os))))) + (else 'continue)) + + (set! ptr (+ ptr 10)) + + (when (bit-set? FEXTRA flg) + (let ((xlen ((bytevector-u16-ref-le bv ptr)))) + (when (<= addr ptr (+ 1 addr)) + (return (make-segment ptr (+ 1 ptr) "XLEN"))) + (set! ptr (+ ptr 2)) + (when (< addr (+ ptr xlen)) + (return (make-segment ptr (+ ptr xlen) "XLEN bytes of extra data"))) + (set! ptr (+ ptr xlen 1)))) + + + ;; utf8->string exists in R7RS, + ;; But we want latin1->string + (when (bit-set? FNAME flg) + (cond ((bytevector-search bv 0 ptr) + => (lambda (idx) + (let ((old ptr)) + (set! ptr (+ idx 1)) + (when (< addr ptr) + (return (make-segment old ptr "Filename")))))) + (else (return (make-segment ptr (bytevector-length bv) + "Unterminated Filename"))))) + + (when (bit-set? FCOMMENT flg) + (cond ((bytevector-search bv 0 ptr) + => (lambda (idx) + (let ((old ptr)) + (set! ptr (+ idx 1)) + (when (< addr ptr) + (return (make-segment old ptr "Comment")))))) + (else (return (make-segment ptr (bytevector-length bv) + "Unterminated Comment"))))) + + (when (bit-set? FHCRC flg) + (when (< addr (+ ptr 2)) + (return + (make-segment ptr (+ ptr 2) + (string-append + "CRC16=" + (number->string + (bytevector-u16-ref-le bv ptr)))))) + (set! ptr (+ ptr 2))) + + (cond ((>= 4 (- (bytevector-length bv) addr)) + (return (make-segment (- (bytevector-length bv) 4) + (bytevector-length bv) + (string-append "ISIZE=" + (number->string + (bytevector-u32-ref-le + bv (- (bytevector-length bv) 4))))))) + ((>= 4 (- (bytevector-length bv) addr 4)) + (return (make-segment (- (bytevector-length bv) 8) + (- (bytevector-length bv) 4) + (string-append "CRC32=" + (number->string + (bytevector-u32-ref-le + bv (- (bytevector-length bv) 8))))))) + ((<= ptr addr (+ ptr (bytevector-length bv) -8)) + (return (make-segment ptr + (- (bytevector-length bv) 8) + "ZLIB compressed payload")))) + + (return (make-segment -1 -1 "No Segment")) + )))) |