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

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

use parameters, add res typ param, mv chks into 1st use

File size: 3.5 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
20  chicken
21  (only lolevel number-of-bytes))
22(require-library
23  lolevel)
24
25(import
26  (only miscmacros while*))
27(require-library
28  miscmacros)
29
30(require-extension
31  message-digest-primitive
32  message-digest-type
33  message-digest-parameters
34  message-digest-support
35  type-checks
36  type-errors)
37
38;;; Support
39
40;;
41
42(define (chunk-convert obj)
43  (and-let* ((cnv (message-digest-chunk-converter)))
44    (cnv obj) ) )
45
46(define (get-chunk-reader in)
47        ((message-digest-chunk-read-maker) in) )
48
49(define (get-update md)
50  (message-digest-primitive-update (message-digest-algorithm md)) )
51
52;;
53
54(define (do-object-update loc md src)
55  (cond
56    ((input-port? src)    (do-port-update loc md src) )
57    ((procedure? src)     (do-procedure-update loc md src) )
58    (else                 (do-bytes-update loc md src) ) ) )
59
60(define (do-port-update loc md in)
61  (do-procedure-update loc md (get-chunk-reader in)) )
62
63(define (do-bytes-update loc md src)
64  (do-byte-source-update
65    loc
66    (message-digest-context md)
67    src
68    (get-update md)) )
69
70(define (do-byte-source-update loc ctx src updt)
71  (cond
72    ; simple bytes
73    ((blob? src)
74        (updt ctx src (number-of-bytes src)) )
75    ((string? src)
76        (do-byte-source-update loc ctx (string->blob src) updt) )
77    ; more complicated bytes
78    ((object->bytevector-like src) =>
79        (cut do-byte-source-update loc ctx <> updt) )
80    ; too complicated bytes
81    (else
82      (signal-type-error loc "indigestible object" src) ) ) )
83
84(define (do-procedure-update loc md proc)
85  (let ((updt (get-update md))
86        (ctx (message-digest-context md)) )
87    (while* (proc) (do-byte-source-update loc ctx it updt) ) ) )
88
89(define (object->bytevector-like obj)
90  (or
91    (packed-vector->blob/shared obj)
92    (chunk-convert obj)) )
93
94;;; Update Operation
95
96;;
97
98(define (message-digest-update-object md obj)
99  (do-object-update
100    'message-digest-update-object
101    (check-message-digest 'message-digest-update-object md)
102    obj) )
103
104;;
105
106(define (message-digest-update-procedure md proc)
107  (do-procedure-update
108    'message-digest-update-procedure
109    (check-message-digest 'message-digest-update-procedure md)
110    (check-procedure 'message-digest-update-procedure proc)) )
111
112;;
113
114(define (message-digest-update-port md in)
115  (do-port-update
116    'message-digest-update-port
117    (check-message-digest 'message-digest-update-port md)
118    (check-input-port 'message-digest-update-port in)) )
119
120;;
121
122(define (message-digest-update-file md flnm)
123  (let ((in (open-input-file (check-string 'message-digest-update-file flnm))))
124    (handle-exceptions
125      ;as
126      exn
127      ;with
128      (begin
129        (close-input-port in)
130        (abort exn) )
131      ;in
132      (do-port-update 'message-digest-update-file (check-message-digest 'message-digest-update-file md) in) )
133    (close-input-port in) ) )
134
135#;
136(define (message-digest-update-file md flnm)
137  (check-message-digest 'message-digest-update-file md)
138  (check-string 'message-digest-update-file flnm)
139  (let ((in #f))
140        (dynamic-wind
141                (lambda () (set! in (open-input-file flnm)) )
142                (lambda () (do-port-update 'message-digest-update-file md in) )
143        (lambda () (close-input-port in) ) ) ) )
144
145) ;module message-digest-update-item
Note: See TracBrowser for help on using the repository browser.