blob: 789c25da8ddaf8afb33328c9b7c538b1c13852a2 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
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"))
))))
|
