source: project/release/4/message-digest/trunk/message-digest-chunk.scm @ 35339

Last change on this file since 35339 was 35339, checked in by kon, 8 months ago

add define-types include, add types, reflow

File size: 4.4 KB
RevLine 
[34375]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?
[34426]16  message-digest-raw-chunk-object
17  message-digest-raw-chunk-size message-digest-raw-chunk-start
[34375]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
[35044]25(import scheme chicken)
26(use
[34375]27  (only posix file-size)
28  (only srfi-4
29    u8vector->blob/shared subu8vector
[35044]30    read-u8vector! make-u8vector)
[35339]31  miscmacros
32  fx-utils
33  typed-define)
[34375]34
[35339]35;;; Support
[34375]36
37;;
38
[35339]39(include "message-digest-types")
[34375]40
[35339]41;;; Update Phase Helpers
[34375]42
43(define (default-chunk-port-read-maker in #!optional (size (message-digest-chunk-size)))
[35339]44  (let (
45    (u8buf (make-u8vector size)) )
[34375]46    (lambda ()
[35339]47      (let (
48        (len (read-u8vector! size u8buf in)) )
[34375]49        (and
50          (positive? len)
[35339]51          (let (
52            (u8buf
53              (if (fx= len size)
54                u8buf
55                (subu8vector u8buf 0 len))) )
[34375]56            (u8vector->blob/shared u8buf) ) ) ) ) ) )
57
58(define-record-type message-digest-raw-chunk
[34426]59  (make-message-digest-raw-chunk obj siz beg)
[34375]60  message-digest-raw-chunk?
61  (obj message-digest-raw-chunk-object)
[34426]62  (siz message-digest-raw-chunk-size)
63  (beg message-digest-raw-chunk-start) )
[34375]64
65(define (default-chunk-fileno-read-maker fd #!optional (size (file-size fd)))
66  (if (zero? size)
67    (lambda ()
68      #f )
[35339]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)) )
[34375]74        (lambda ()
75          (if buffer
76            (begin0
77              chunk
78              (set! buffer #f))
79            (begin
80              (cleanup)
81              #f ) ) ) ) ) ) )
82
83(cond-expand
[35339]84
[34375]85  ((and windows (not cygwin))
[35339]86
[34375]87    (import (only lolevel allocate free))
88    (require-library lolevel)
[35339]89
[34375]90    (begin
[35339]91
[34375]92      (define read-into-buffer
93        (foreign-lambda* bool ((int fd) (c-pointer buffer) (integer size))
94          "C_return(read(fd, buffer, size) == size);") )
[35339]95
[34375]96      (define (mapped-buffer loc fd size)
[35339]97        (let* (
98          (buffer (allocate size))
99          (finalize (cut free buffer)) )
[34375]100          (unless (read-into-buffer fd buffer size)
101            (finalize)
102            (error loc "cannot read file") )
103          (values buffer finalize) ) ) ) )
[35339]104
[34375]105  (else
[35339]106
[34375]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)
[35339]114
[34375]115    (define (mapped-buffer loc fd size)
[35339]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)) )
[34375]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
[35339]133      ((fxpositive? x)  x)
134      ((not x)          DEFAULT-CHUNK-SIZE)
[34375]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
[35339]144      ((procedure? x)   x)
145      ((not x)          default-chunk-port-read-maker)
[34375]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
[35339]157      ((procedure? x)   x)
158      ((not x)          default-chunk-fileno-read-maker)
[34375]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
Note: See TracBrowser for help on using the repository browser.