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

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

add -strict-types, remove redundant -local, type is interface, note about -strict-types & union return type

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