source: project/release/5/message-digest-utils/trunk/message-digest-chunk.scm @ 38988

Last change on this file since 38988 was 38988, checked in by Kon Lovett, 8 weeks ago

export record id

File size: 7.3 KB
Line 
1;;;;message-digest-chunk.scm  -*- Scheme -*-
2;;;;Kon Lovett, Jul '18
3;;;;Kon Lovett, Aug '17  (message-digest-parameters.scm)
4
5;;Issues
6;;
7;; - Use "chunk-size".
8;;
9;; - Uses 'context-info' to determine whether active context is "own" allocation or
10;; callers. Again, a kludge.
11;;
12;; - Passes u8vector to update phase as a blob.
13
14(module message-digest-chunk
15
16(;export
17  ;chunk
18  message-digest-raw-chunk
19  message-digest-raw-chunk?
20  message-digest-raw-chunk-object
21  message-digest-raw-chunk-size message-digest-raw-chunk-start
22  ;
23  message-digest-chunk-size
24  message-digest-chunk-port-read-maker
25  message-digest-chunk-fileno-read-maker
26  message-digest-chunk-converter)
27
28(import scheme)
29(import (chicken base))
30(import (chicken foreign))
31(import (only (chicken file posix) file-size))
32(import (chicken type))
33(import (only (srfi 4) u8vector->blob/shared subu8vector read-u8vector! make-u8vector))
34
35;; Support
36
37;;
38
39(include "message-digest.types")
40
41(: default-chunk-port-read-maker (input-port #!rest -> procedure))
42(: make-message-digest-raw-chunk (* fixnum fixnum --> message-digest-raw-chunk))
43(: message-digest-raw-chunk? (* -> boolean : message-digest-raw-chunk))
44(: message-digest-raw-chunk-object (message-digest-raw-chunk --> *))
45(: message-digest-raw-chunk-size (message-digest-raw-chunk --> fixnum))
46(: message-digest-raw-chunk-start (message-digest-raw-chunk --> fixnum))
47(: default-chunk-fileno-read-maker (fixnum #!rest -> procedure))
48(: mapped-buffer (symbol fixnum fixnum fixnum -> pointer procedure boolean))
49(: message-digest-chunk-size (#!optional fixnum -> fixnum))
50(: message-digest-chunk-port-read-maker (#!optional (or boolean procedure) -> procedure))
51(: message-digest-chunk-fileno-read-maker (#!optional (or boolean procedure) -> procedure))
52(: message-digest-chunk-converter (#!optional (or boolean procedure) -> (or boolean procedure)))
53
54;;
55
56(define-constant DEFAULT-CHUNK-SIZE 1024)
57
58;;; Update Phase Helpers
59
60(define (default-chunk-port-read-maker port . opts)
61  (let* (
62    (siz (optional opts (message-digest-chunk-size)))
63    (u8buf (make-u8vector siz)) )
64    (lambda ()
65      (let (
66        (len (read-u8vector! siz u8buf port)) )
67        (and
68          (positive? len)
69          (let (
70            (u8buf
71              (if (= len siz)
72                u8buf
73                (subu8vector u8buf 0 len))) )
74            (u8vector->blob/shared u8buf) ) ) ) ) ) )
75
76;(define-type message-digest-raw-chunk (struct message-digest-raw-chunk))
77;assignment of value of type `(procedure
78;message-digest-chunk#make-message-digest-raw-chunk (* * *) (struct
79;message-digest-chunk#message-digest-raw-chunk))' to toplevel variable
80;`message-digest-chunk#make-message-digest-raw-chunk' does not match declared
81;type `(procedure message-digest-chunk#make-message-digest-raw-chunk (* fixnum
82;fixnum) (struct message-digest-raw-chunk))'
83;
84(define-record-type message-digest-raw-chunk
85  (make-message-digest-raw-chunk obj siz beg)
86  message-digest-raw-chunk?
87  (obj message-digest-raw-chunk-object)
88  (siz message-digest-raw-chunk-size message-digest-raw-chunk-size-set!)
89  (beg message-digest-raw-chunk-start) )
90
91(define (default-chunk-fileno-read-maker fd . opts)
92  (let-optionals* opts (
93    (siz (file-size fd))
94    (chk (message-digest-chunk-size)) )
95    ;anything to read?
96    (if (zero? siz)
97      (lambda () #f)
98      ;returns chunk, after reading, or #f
99      ;errors when lolevel problem
100      (let-values (
101        ;buffer used as flag
102        ((buffer cleanup updater)
103          (mapped-buffer 'default-chunk-fileno-read-maker fd siz chk)) )
104        (let (
105          (chunk (and buffer (make-message-digest-raw-chunk buffer chk 0))) )
106          ;no updater means 1) chunk already filled, & 2) last read done
107          (if (not updater)
108            (lambda ()
109              (if buffer
110                (begin
111                  (set! buffer #f)
112                  (message-digest-raw-chunk-size-set! chunk siz)
113                  chunk )
114                (begin
115                  (cleanup)
116                  #f ) ) )
117            (lambda ()
118              (and
119                buffer
120                (if (updater chunk)
121                  chunk
122                  (begin
123                    (set! buffer #f)
124                    (cleanup)
125                    #f ) ) ) ) ) ) ) ) ) )
126
127(cond-expand
128  ((or windows unix)
129    (define (mapped-buffer loc fd siz chk)
130      (import
131        (only memory-mapped-files
132          map-file-to-memory unmap-file-from-memory
133          memory-mapped-file-pointer map/shared prot/read))
134      (let* (
135        (mmap (map-file-to-memory #f siz prot/read map/shared fd))
136        (ptr (memory-mapped-file-pointer mmap))
137        (finalize (cut unmap-file-from-memory mmap)) )
138        (values ptr finalize #f) ) ) )
139  (else
140    ;tested w/ macosx (replaced mmap version)
141    (define (mapped-buffer loc fd siz chk)
142      (import (only (chicken memory) allocate free))
143      (define read-into-buffer
144        (foreign-lambda* bool ((int fd) (c-pointer buffer) (integer size))
145          "return( read( fd, buffer, size ) == size );") )
146      (let* (
147        (ptr
148          (allocate chk) )
149        (finalize
150          (cut free ptr) )
151        ;FIXME assumes offset is 0
152        ;FIXME pass fd in message-digest-raw-chunk?
153        (updater
154          (let ((rem siz))
155            (lambda (chunk)
156              ;
157              (define (reader amt)
158                (let ((ptr (message-digest-raw-chunk-object chunk)))
159                  (unless (read-into-buffer fd ptr amt)
160                    (finalize)
161                    (message-digest-raw-chunk-size-set! chunk 0)
162                    (error loc "problem reading fileno" fd) ) )
163                (message-digest-raw-chunk-size-set! chunk amt)
164                (set! rem (- rem amt))
165                #t )
166              ;
167              (cond
168                ((zero? rem)
169                  #f )
170                ((< (message-digest-raw-chunk-size chunk) rem)
171                  (reader (message-digest-raw-chunk-size chunk)) )
172                (else
173                  (reader rem) ) ) ) ) ) )
174        (values ptr finalize updater) ) ) ) )
175
176;; Message Digest "chunk"
177
178;;
179
180(define message-digest-chunk-size (make-parameter DEFAULT-CHUNK-SIZE
181  (lambda (x)
182    (cond
183      ((positive? x)  x)
184      ((not x)        DEFAULT-CHUNK-SIZE)
185      (else
186        (warning 'message-digest-chunk-size "invalid positive-fixnum" x)
187        (message-digest-chunk-size) ) ) ) ) )
188
189;;
190
191(define message-digest-chunk-port-read-maker (make-parameter default-chunk-port-read-maker
192  (lambda (x)
193    (cond
194      ((procedure? x)   x)
195      ((not x)          default-chunk-port-read-maker)
196      (else
197        (warning 'message-digest-chunk-port-read-maker "invalid procedure" x)
198        (message-digest-chunk-port-read-maker) ) ) ) ) )
199
200;;
201
202(define message-digest-chunk-fileno-read-maker (make-parameter default-chunk-fileno-read-maker
203  (lambda (x)
204    (cond
205      ((procedure? x)   x)
206      ((not x)          default-chunk-fileno-read-maker)
207      (else
208        (warning 'message-digest-chunk-fileno-read-maker "invalid procedure" x)
209        (message-digest-chunk-fileno-read-maker) ) ) ) ) )
210
211;;
212
213(define message-digest-chunk-converter (make-parameter #f
214  (lambda (x)
215    (if (or (not x) (procedure? x))
216      x
217      (begin
218        (warning 'message-digest-chunk-converter "invalid procedure or #f" x)
219        (message-digest-chunk-converter) ) ) ) ) )
220
221) ;module message-digest-chunk
Note: See TracBrowser for help on using the repository browser.