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

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

why did i care ?

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