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

Last change on this file since 35345 was 35345, checked in by kon, 9 months ago

reflow

File size: 5.3 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 chicken)
18(use
19  (only lolevel number-of-bytes pointer?)
20  (only posix
21    file-open file-close
22    open/rdonly
23    directory?)
24    (only miscmacros while*)
25  message-digest-primitive
26  message-digest-type
27  message-digest-chunk
28  message-digest-support
29  type-checks
30  type-errors
31  typed-define)
32
33;;; Support
34
35;;
36
37;=> #f or converted-chunk
38(define (chunk-convert obj)
39  (and-let* (
40    (cnv (message-digest-chunk-converter)) )
41    (cnv obj) ) )
42
43(define (get-port-chunk-reader in)
44        ((message-digest-chunk-port-read-maker) in) )
45
46(define (get-fileno-chunk-reader fd)
47        ((message-digest-chunk-fileno-read-maker) fd) )
48
49(define (get-update md)
50  (message-digest-primitive-update (message-digest-algorithm md)) )
51
52(define (get-raw-update md)
53  (message-digest-primitive-raw-update (message-digest-algorithm md)) )
54
55;;
56
57(define (do-object-update loc md src start end)
58  (cond
59    ((input-port? src)    (do-port-update loc md src start end) )
60    ((procedure? src)     (do-procedure-update loc md src start end) )
61    (else                 (do-bytes-update loc md src start end) ) ) )
62
63(define (do-port-update loc md in start end)
64  (do-procedure-update loc md (get-port-chunk-reader in) start end) )
65
66(define (do-bytes-update loc md src start end)
67  (do-byte-source-update
68    loc
69    (message-digest-context md)
70    src
71    (get-update md)
72    (get-raw-update md)
73    start end) )
74
75(define (do-procedure-update loc md proc start end)
76  (let (
77    (src-updt (get-update md))
78    (raw-updt (get-raw-update md))
79    (ctx (message-digest-context md)) )
80    ;note the 'src' object (return of proc) may or may not be unique
81    (while* (proc)
82      (do-byte-source-update loc ctx it src-updt raw-updt start end) ) ) )
83
84(define (do-byte-source-update loc ctx src src-updt raw-updt start end)
85  (cond
86    ; simple bytes
87    ((blob? src)
88      (let ((src (blob/slice src start end)))
89          (src-updt ctx src (blob-size src)) ) )
90    ((string? src)
91      (let ((src (string/slice src start end)))
92          (src-updt ctx src (string-length src)) ) )
93    ((message-digest-raw-chunk? src)
94      (let* ((obj (message-digest-raw-chunk-object src))
95             (updtr (if (pointer? obj) raw-updt src-updt)))
96        (unless updtr
97          (error loc "primitive does not support raw-update") )
98        (updtr ctx
99          obj
100          (message-digest-raw-chunk-size src)
101          #;(message-digest-raw-chunk-start src)
102          ) ) )
103    ; more complicated bytes
104    ((object->bytevector-like src) =>
105        (cut do-byte-source-update loc ctx <> src-updt raw-updt start end) )
106    ; too complicated bytes
107    (else
108      (signal-type-error loc "indigestible object" src start end) ) ) )
109
110;;
111
112;=> #f or bytevector-like
113(define (object->bytevector-like obj)
114  (or
115    (packed-vector->blob/shared obj)
116    (chunk-convert obj)) )
117
118;;; Update Operation
119
120;;
121
122(define (message-digest-update-object md obj #!optional (start 0) (end #f))
123  (do-object-update
124    'message-digest-update-object
125    (check-message-digest 'message-digest-update-object md)
126    obj
127    start end) )
128
129;;
130
131(define (message-digest-update-procedure md proc)
132  (do-procedure-update
133    'message-digest-update-procedure
134    (check-message-digest 'message-digest-update-procedure md)
135    (check-procedure 'message-digest-update-procedure proc)
136    0 #f) )
137
138;;
139
140(define (message-digest-update-port md in)
141  (do-port-update
142    'message-digest-update-port
143    (check-message-digest 'message-digest-update-port md)
144    (check-input-port 'message-digest-update-port in)
145    0 #f) )
146
147;;
148
149(define (message-digest-update-file md flnm)
150  ;
151  (unless (file-exists? (check-string 'message-digest-update-file flnm))
152    (error 'message-digest-update-file "no such file" flnm) )
153  ;
154  #; ;can't open a directory?
155  (when (directory? flnm)
156    (error 'message-digest-update-file "file is a directory" flnm) )
157  ;
158  (if (get-raw-update (check-message-digest 'message-digest-update-file md))
159    (*message-digest-update-file/fileno 'message-digest-update-file md flnm)
160    (*message-digest-update-file/port 'message-digest-update-file md flnm) ) )
161
162(define (*message-digest-update-file/fileno loc md flnm)
163  (let (
164    (fd (file-open flnm open/rdonly)) )
165    (handle-exceptions
166      ;as
167      exn
168      ;with
169      (begin
170        (file-close fd)
171        (abort exn) )
172      ;in
173      (do-procedure-update loc md (get-fileno-chunk-reader fd) 0 #f) )
174    (file-close fd) ) )
175
176(define (*message-digest-update-file/port loc md flnm)
177  (let (
178    (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 0 #f) )
188    (close-input-port in) ) )
189
190#; ;book implementation
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.