source: project/release/4/message-digest/trunk/message-digest-update-item.scm @ 34373

Last change on this file since 34373 was 34373, checked in by Kon Lovett, 3 years ago

add raw-update to prim, use raw-update for mmapped/in-mem file md

File size: 5.0 KB
Line 
1;;;; message-digest-update-item.scm
2;;;; Kon Lovett, Jan '06 (message-digest.scm)
3;;;; Kon Lovett, May '10 (message-digest.scm)
4;;;; Kon Lovett, Apr '12
5;;;; Kon Lovett, Aug '17
6
7;; Issues
8
9(module message-digest-update-item
10
11(;export
12  message-digest-update-object
13  message-digest-update-procedure
14  message-digest-update-port
15  message-digest-update-file)
16
17(import scheme)
18
19(import chicken)
20
21(import
22  (only lolevel number-of-bytes pointer?))
23(require-library
24  lolevel)
25
26(import
27  (only posix
28    file-open file-close
29    open/rdonly
30    directory?))
31(require-library
32  posix)
33
34(import
35  (only miscmacros while*))
36(require-library
37  miscmacros)
38
39(require-extension
40  message-digest-primitive
41  message-digest-type
42  message-digest-chunk
43  message-digest-support
44  type-checks
45  type-errors)
46
47;;; Support
48
49;;
50
51;=> #f or converted-chunk
52(define (chunk-convert obj)
53  (and-let* ((cnv (message-digest-chunk-converter)))
54    (cnv obj) ) )
55
56(define (get-port-chunk-reader in)
57        ((message-digest-chunk-port-read-maker) in) )
58
59(define (get-fileno-chunk-reader fd)
60        ((message-digest-chunk-fileno-read-maker) fd) )
61
62(define (get-update md)
63  (message-digest-primitive-update (message-digest-algorithm md)) )
64
65(define (get-raw-update md)
66  (message-digest-primitive-raw-update (message-digest-algorithm md)) )
67
68;;
69
70(define (do-object-update loc md src)
71  (cond
72    ((input-port? src)    (do-port-update loc md src) )
73    ((procedure? src)     (do-procedure-update loc md src) )
74    (else                 (do-bytes-update loc md src) ) ) )
75
76(define (do-port-update loc md in)
77  (do-procedure-update loc md (get-port-chunk-reader in)) )
78
79(define (do-bytes-update loc md src)
80  (do-byte-source-update
81    loc
82    (message-digest-context md)
83    src
84    (get-update md)
85    (get-raw-update md)) )
86
87(define (do-procedure-update loc md proc)
88  (let ((s-updt (get-update md))
89        (r-updt (get-raw-update md))
90        (ctx (message-digest-context md)) )
91    ;note the 'src' object (return of proc) may or may not be unique
92    (while* (proc)
93      (do-byte-source-update loc ctx it s-updt r-updt) ) ) )
94
95(define (do-byte-source-update loc ctx src s-updt r-updt)
96  (cond
97    ; simple bytes
98    ((blob? src)
99        (s-updt ctx src (number-of-bytes src)) )
100    ((string? src)
101        (do-byte-source-update loc ctx (string->blob src) s-updt r-updt) )
102    ((message-digest-raw-chunk? src)
103      (let* ((obj (message-digest-raw-chunk-object src))
104             (updtr (if (pointer? obj) r-updt s-updt)))
105        (unless updtr
106          (error loc "primitive does not support raw-update") )
107        (updtr ctx obj (message-digest-raw-chunk-size src)) ) )
108    ; more complicated bytes
109    ((object->bytevector-like src) =>
110        (cut do-byte-source-update loc ctx <> s-updt r-updt) )
111    ; too complicated bytes
112    (else
113      (signal-type-error loc "indigestible object" src) ) ) )
114
115;;
116
117;=> #f or bytevector-like
118(define (object->bytevector-like obj)
119  (or
120    (packed-vector->blob/shared obj)
121    (chunk-convert obj)) )
122
123;;; Update Operation
124
125;;
126
127(define (message-digest-update-object md obj)
128  (do-object-update
129    'message-digest-update-object
130    (check-message-digest 'message-digest-update-object md)
131    obj) )
132
133;;
134
135(define (message-digest-update-procedure md proc)
136  (do-procedure-update
137    'message-digest-update-procedure
138    (check-message-digest 'message-digest-update-procedure md)
139    (check-procedure 'message-digest-update-procedure proc)) )
140
141;;
142
143(define (message-digest-update-port md in)
144  (do-port-update
145    'message-digest-update-port
146    (check-message-digest 'message-digest-update-port md)
147    (check-input-port 'message-digest-update-port in)) )
148
149;;
150
151(define (message-digest-update-file md flnm)
152  ;
153  (unless (file-exists? (check-string 'message-digest-update-file flnm))
154    (error 'message-digest-update-file "no such file" flnm) )
155  ;
156  #; ;can't open a directory?
157  (when (directory? flnm)
158    (error 'message-digest-update-file "file is a directory" flnm) )
159  ;
160  (if (get-raw-update (check-message-digest 'message-digest-update-file md))
161    (*message-digest-update-file/fileno 'message-digest-update-file md flnm)
162    (*message-digest-update-file/port 'message-digest-update-file md flnm) ) )
163
164(define (*message-digest-update-file/fileno loc md flnm)
165  (let ((fd (file-open flnm open/rdonly)))
166    (handle-exceptions
167      ;as
168      exn
169      ;with
170      (begin
171        (file-close fd)
172        (abort exn) )
173      ;in
174      (do-procedure-update loc md (get-fileno-chunk-reader fd)) )
175    (file-close fd) ) )
176
177(define (*message-digest-update-file/port loc md flnm)
178  (let ((in (open-input-file flnm)))
179    (handle-exceptions
180      ;as
181      exn
182      ;with
183      (begin
184        (close-input-port in)
185        (abort exn) )
186      ;in
187      (do-port-update loc md in) )
188    (close-input-port in) ) )
189
190#;
191(define (message-digest-update-file md flnm)
192  (let ((in #f))
193        (dynamic-wind
194                (lambda () (set! in (open-input-file flnm)) )
195                (lambda () (do-port-update 'message-digest-update-file md in) )
196        (lambda () (close-input-port in) ) ) ) )
197
198) ;module message-digest-update-item
Note: See TracBrowser for help on using the repository browser.