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

Last change on this file since 35044 was 35044, checked in by kon, 11 months ago

why did i care ?

File size: 4.4 KB
Line 
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
Note: See TracBrowser for help on using the repository browser.