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

Last change on this file was 35349, checked in by Kon Lovett, 20 months ago

add -chunk type, add types

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