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 | |
---|
27 | (use |
---|
28 | (only posix file-size) |
---|
29 | (only srfi-4 |
---|
30 | u8vector->blob/shared subu8vector |
---|
31 | read-u8vector! make-u8vector) |
---|
32 | miscmacros) |
---|
33 | |
---|
34 | ;;; Update Phase Helpers |
---|
35 | |
---|
36 | ;; |
---|
37 | |
---|
38 | (define (positive-fixnum? obj) |
---|
39 | (and (fixnum? obj) (positive? obj)) ) |
---|
40 | |
---|
41 | ;; |
---|
42 | |
---|
43 | (define (default-chunk-port-read-maker in #!optional (size (message-digest-chunk-size))) |
---|
44 | (let ((u8buf (make-u8vector size))) |
---|
45 | (lambda () |
---|
46 | (let ((len (read-u8vector! size u8buf in))) |
---|
47 | (and |
---|
48 | (positive? len) |
---|
49 | (let ((u8buf (if (fx= len size) u8buf (subu8vector u8buf 0 len)))) |
---|
50 | (u8vector->blob/shared u8buf) ) ) ) ) ) ) |
---|
51 | |
---|
52 | (define-record-type message-digest-raw-chunk |
---|
53 | (make-message-digest-raw-chunk obj siz beg) |
---|
54 | message-digest-raw-chunk? |
---|
55 | (obj message-digest-raw-chunk-object) |
---|
56 | (siz message-digest-raw-chunk-size) |
---|
57 | (beg message-digest-raw-chunk-start) ) |
---|
58 | |
---|
59 | (define (default-chunk-fileno-read-maker fd #!optional (size (file-size fd))) |
---|
60 | (if (zero? size) |
---|
61 | (lambda () |
---|
62 | #f ) |
---|
63 | (let-values (((buffer cleanup) |
---|
64 | (mapped-buffer 'default-chunk-fileno-read-maker fd size))) |
---|
65 | (let ((chunk (make-message-digest-raw-chunk buffer size 0))) |
---|
66 | (lambda () |
---|
67 | (if buffer |
---|
68 | (begin0 |
---|
69 | chunk |
---|
70 | (set! buffer #f)) |
---|
71 | (begin |
---|
72 | (cleanup) |
---|
73 | #f ) ) ) ) ) ) ) |
---|
74 | |
---|
75 | (cond-expand |
---|
76 | ((and windows (not cygwin)) |
---|
77 | (import (only lolevel allocate free)) |
---|
78 | (require-library lolevel) |
---|
79 | (begin |
---|
80 | (define read-into-buffer |
---|
81 | (foreign-lambda* bool ((int fd) (c-pointer buffer) (integer size)) |
---|
82 | "C_return(read(fd, buffer, size) == size);") ) |
---|
83 | (define (mapped-buffer loc fd size) |
---|
84 | (let* ((buffer (allocate size)) |
---|
85 | (finalize (cut free buffer)) ) |
---|
86 | (unless (read-into-buffer fd buffer size) |
---|
87 | (finalize) |
---|
88 | (error loc "cannot read file") ) |
---|
89 | (values buffer finalize) ) ) ) ) |
---|
90 | (else |
---|
91 | (import |
---|
92 | (only posix |
---|
93 | map-file-to-memory unmap-file-from-memory |
---|
94 | memory-mapped-file-pointer |
---|
95 | map/shared |
---|
96 | prot/read)) |
---|
97 | (require-library posix) |
---|
98 | (define (mapped-buffer loc fd size) |
---|
99 | (let* ((mmap (map-file-to-memory #f size prot/read map/shared fd)) |
---|
100 | (ptr (memory-mapped-file-pointer mmap)) |
---|
101 | (finalize (cut unmap-file-from-memory mmap)) ) |
---|
102 | (values ptr finalize) ) ) ) ) |
---|
103 | |
---|
104 | ;; |
---|
105 | |
---|
106 | (define-constant DEFAULT-CHUNK-SIZE 1024) |
---|
107 | |
---|
108 | ;;; Message Digest "chunk" |
---|
109 | |
---|
110 | ;; |
---|
111 | |
---|
112 | (define-parameter message-digest-chunk-size DEFAULT-CHUNK-SIZE |
---|
113 | (lambda (x) |
---|
114 | (cond |
---|
115 | ((positive-fixnum? x) x ) |
---|
116 | ((not x) DEFAULT-CHUNK-SIZE ) |
---|
117 | (else |
---|
118 | (warning 'message-digest-chunk-size "invalid positive-fixnum" x) |
---|
119 | (message-digest-chunk-size) ) ) ) ) |
---|
120 | |
---|
121 | ;; |
---|
122 | |
---|
123 | (define-parameter message-digest-chunk-port-read-maker default-chunk-port-read-maker |
---|
124 | (lambda (x) |
---|
125 | (cond |
---|
126 | ((procedure? x) x ) |
---|
127 | ((not x) default-chunk-port-read-maker ) |
---|
128 | (else |
---|
129 | (warning 'message-digest-chunk-port-read-maker "invalid procedure" x) |
---|
130 | (message-digest-chunk-port-read-maker) ) ) ) ) |
---|
131 | |
---|
132 | (define message-digest-chunk-read-maker message-digest-chunk-port-read-maker) |
---|
133 | |
---|
134 | ;; |
---|
135 | |
---|
136 | (define-parameter message-digest-chunk-fileno-read-maker default-chunk-fileno-read-maker |
---|
137 | (lambda (x) |
---|
138 | (cond |
---|
139 | ((procedure? x) x ) |
---|
140 | ((not x) default-chunk-fileno-read-maker ) |
---|
141 | (else |
---|
142 | (warning 'message-digest-chunk-fileno-read-maker "invalid procedure" x) |
---|
143 | (message-digest-chunk-fileno-read-maker) ) ) ) ) |
---|
144 | |
---|
145 | ;; |
---|
146 | |
---|
147 | (define-parameter message-digest-chunk-converter #f |
---|
148 | (lambda (x) |
---|
149 | (if (or (not x) (procedure? x)) |
---|
150 | x |
---|
151 | (begin |
---|
152 | (warning 'message-digest-chunk-converter "invalid procedure or #f" x) |
---|
153 | (message-digest-chunk-converter) ) ) ) ) |
---|
154 | |
---|
155 | ) ;module message-digest-chunk |
---|