1 | ;;;;message-digest-chunk.scm |
---|
2 | ;;;;Kon Lovett, Aug '17 (message-digest-parameters.scm) |
---|
3 | |
---|
4 | ;;Issues |
---|
5 | ;; |
---|
6 | ;; - Uses 'context-info' to determine whether active context is "own" allocation or |
---|
7 | ;; callers. Again, a kludge. |
---|
8 | ;; |
---|
9 | ;; - Passes u8vector to update phase as a blob. |
---|
10 | |
---|
11 | (module message-digest-chunk |
---|
12 | |
---|
13 | (;export |
---|
14 | ;chunk |
---|
15 | message-digest-raw-chunk? |
---|
16 | message-digest-raw-chunk-object |
---|
17 | message-digest-raw-chunk-size message-digest-raw-chunk-start |
---|
18 | ; |
---|
19 | message-digest-chunk-size |
---|
20 | message-digest-chunk-port-read-maker |
---|
21 | message-digest-chunk-fileno-read-maker |
---|
22 | message-digest-chunk-read-maker ;DEPRECATED |
---|
23 | message-digest-chunk-converter) |
---|
24 | |
---|
25 | (import scheme chicken) |
---|
26 | (use |
---|
27 | (only posix file-size) |
---|
28 | (only srfi-4 |
---|
29 | u8vector->blob/shared subu8vector |
---|
30 | read-u8vector! make-u8vector) |
---|
31 | miscmacros |
---|
32 | fx-utils |
---|
33 | typed-define) |
---|
34 | |
---|
35 | ;;; Support |
---|
36 | |
---|
37 | ;; |
---|
38 | |
---|
39 | (include "message-digest-types") |
---|
40 | |
---|
41 | ;;; Update Phase Helpers |
---|
42 | |
---|
43 | (define (default-chunk-port-read-maker in #!optional (size (message-digest-chunk-size))) |
---|
44 | (let ( |
---|
45 | (u8buf (make-u8vector size)) ) |
---|
46 | (lambda () |
---|
47 | (let ( |
---|
48 | (len (read-u8vector! size u8buf in)) ) |
---|
49 | (and |
---|
50 | (positive? len) |
---|
51 | (let ( |
---|
52 | (u8buf |
---|
53 | (if (fx= len size) |
---|
54 | u8buf |
---|
55 | (subu8vector u8buf 0 len))) ) |
---|
56 | (u8vector->blob/shared u8buf) ) ) ) ) ) ) |
---|
57 | |
---|
58 | (define-record-type message-digest-raw-chunk |
---|
59 | (make-message-digest-raw-chunk obj siz beg) |
---|
60 | message-digest-raw-chunk? |
---|
61 | (obj message-digest-raw-chunk-object) |
---|
62 | (siz message-digest-raw-chunk-size) |
---|
63 | (beg message-digest-raw-chunk-start) ) |
---|
64 | |
---|
65 | (define (default-chunk-fileno-read-maker fd #!optional (size (file-size fd))) |
---|
66 | (if (zero? size) |
---|
67 | (lambda () |
---|
68 | #f ) |
---|
69 | (let-values ( |
---|
70 | ((buffer cleanup) |
---|
71 | (mapped-buffer 'default-chunk-fileno-read-maker fd size)) ) |
---|
72 | (let ( |
---|
73 | (chunk (make-message-digest-raw-chunk buffer size 0)) ) |
---|
74 | (lambda () |
---|
75 | (if buffer |
---|
76 | (begin0 |
---|
77 | chunk |
---|
78 | (set! buffer #f)) |
---|
79 | (begin |
---|
80 | (cleanup) |
---|
81 | #f ) ) ) ) ) ) ) |
---|
82 | |
---|
83 | (cond-expand |
---|
84 | |
---|
85 | ((and windows (not cygwin)) |
---|
86 | |
---|
87 | (import (only lolevel allocate free)) |
---|
88 | (require-library lolevel) |
---|
89 | |
---|
90 | (begin |
---|
91 | |
---|
92 | (define read-into-buffer |
---|
93 | (foreign-lambda* bool ((int fd) (c-pointer buffer) (integer size)) |
---|
94 | "C_return(read(fd, buffer, size) == size);") ) |
---|
95 | |
---|
96 | (define (mapped-buffer loc fd size) |
---|
97 | (let* ( |
---|
98 | (buffer (allocate size)) |
---|
99 | (finalize (cut free buffer)) ) |
---|
100 | (unless (read-into-buffer fd buffer size) |
---|
101 | (finalize) |
---|
102 | (error loc "cannot read file") ) |
---|
103 | (values buffer finalize) ) ) ) ) |
---|
104 | |
---|
105 | (else |
---|
106 | |
---|
107 | (import |
---|
108 | (only posix |
---|
109 | map-file-to-memory unmap-file-from-memory |
---|
110 | memory-mapped-file-pointer |
---|
111 | map/shared |
---|
112 | prot/read)) |
---|
113 | (require-library posix) |
---|
114 | |
---|
115 | (define (mapped-buffer loc fd size) |
---|
116 | (let* ( |
---|
117 | (mmap (map-file-to-memory #f size prot/read map/shared fd)) |
---|
118 | (ptr (memory-mapped-file-pointer mmap)) |
---|
119 | (finalize (cut unmap-file-from-memory mmap)) ) |
---|
120 | (values ptr finalize) ) ) ) ) |
---|
121 | |
---|
122 | ;; |
---|
123 | |
---|
124 | (define-constant DEFAULT-CHUNK-SIZE 1024) |
---|
125 | |
---|
126 | ;;; Message Digest "chunk" |
---|
127 | |
---|
128 | ;; |
---|
129 | |
---|
130 | (define-parameter message-digest-chunk-size DEFAULT-CHUNK-SIZE |
---|
131 | (lambda (x) |
---|
132 | (cond |
---|
133 | ((fxpositive? x) x) |
---|
134 | ((not x) DEFAULT-CHUNK-SIZE) |
---|
135 | (else |
---|
136 | (warning 'message-digest-chunk-size "invalid positive-fixnum" x) |
---|
137 | (message-digest-chunk-size) ) ) ) ) |
---|
138 | |
---|
139 | ;; |
---|
140 | |
---|
141 | (define-parameter message-digest-chunk-port-read-maker default-chunk-port-read-maker |
---|
142 | (lambda (x) |
---|
143 | (cond |
---|
144 | ((procedure? x) x) |
---|
145 | ((not x) default-chunk-port-read-maker) |
---|
146 | (else |
---|
147 | (warning 'message-digest-chunk-port-read-maker "invalid procedure" x) |
---|
148 | (message-digest-chunk-port-read-maker) ) ) ) ) |
---|
149 | |
---|
150 | (define message-digest-chunk-read-maker message-digest-chunk-port-read-maker) |
---|
151 | |
---|
152 | ;; |
---|
153 | |
---|
154 | (define-parameter message-digest-chunk-fileno-read-maker default-chunk-fileno-read-maker |
---|
155 | (lambda (x) |
---|
156 | (cond |
---|
157 | ((procedure? x) x) |
---|
158 | ((not x) default-chunk-fileno-read-maker) |
---|
159 | (else |
---|
160 | (warning 'message-digest-chunk-fileno-read-maker "invalid procedure" x) |
---|
161 | (message-digest-chunk-fileno-read-maker) ) ) ) ) |
---|
162 | |
---|
163 | ;; |
---|
164 | |
---|
165 | (define-parameter message-digest-chunk-converter #f |
---|
166 | (lambda (x) |
---|
167 | (if (or (not x) (procedure? x)) |
---|
168 | x |
---|
169 | (begin |
---|
170 | (warning 'message-digest-chunk-converter "invalid procedure or #f" x) |
---|
171 | (message-digest-chunk-converter) ) ) ) ) |
---|
172 | |
---|
173 | ) ;module message-digest-chunk |
---|