source: project/release/3/message-digest/trunk/message-digest.scm @ 13937

Last change on this file since 13937 was 13937, checked in by Kon Lovett, 11 years ago

Save.

File size: 7.6 KB
Line 
1;;;; message-digest.scm
2;;;; Kon Lovett, Jan '06
3
4;; Issues
5;;
6;; - Caches the bindings of R5RS & SRFI-13 string procedures so byte-oriented!
7;;
8;; - The ->fixnum/blob/... is approximate at best!
9
10
11(eval-when (compile)
12        (declare
13                (not usual-integrations
14      inexact->exact integer? round number? modulo)
15                (fixnum)
16                (inline)
17                (no-procedure-checks)
18                (constant
19                  int->hex
20                        ->fixnum
21                        ->blob
22                        ->blob/shared
23                        byte-string->hexadecimal)
24    (bound-to-procedure
25      message-digest-primitive?)
26                (export
27                        byte-string->substring-list/shared
28                        byte-string->substring-list
29                        byte-string->hexadecimal
30                        ->blob
31                        ->blob/shared
32                        message-digest-chunk-size
33                        make-binary-message-digest
34                        make-message-digest
35                        make-message-digest-primitive
36                        message-digest-primitive?
37                        message-digest-primitive-name
38                        message-digest-primitive-context-info
39                        message-digest-primitive-digest-length
40                        message-digest-primitive-init
41                        message-digest-primitive-update
42                        message-digest-primitive-final
43                        message-digest-primitive-apply) ) )
44
45(require-extension extras srfi-1 srfi-4 srfi-9 srfi-13 srfi-69 lolevel mathh-int miscmacros)
46
47;;;
48
49(define (check-procedure loc obj')
50  (unless (procedure? obj)
51    (error loc "bad argument type - expected a procedure" obj) ) )
52
53(define (check-message-digest-primitive loc obj)
54  (unless (message-digest-primitive? obj)
55    (error loc "bad argument type - expected a message-digest-primitive" obj) ) )
56
57(define (check-context-info loc obj)
58  (unless (or (fixnum? obj) (procedure? obj))
59    (error loc "bad argument type - expected a fixnum or procedure" ctx-info) ) )
60
61;;; Cache
62
63(define byte-string-length string-length)
64(define byte-substring/shared substring/shared)
65(define byte-string-copy string-copy)
66(define byte-string-for-each string-for-each)
67(define list->byte-string list->string)
68(define make-byte-string make-string)
69
70;;;
71
72(define (byte-string->substring-list/shared str chunk-size #!optional (start 0) (end (byte-string-length str)))
73  (let* ((rem (remainder (- end start) chunk-size))
74         (len (- end rem))
75         (sublst
76          (let loop ((pos start) (lst '()))
77            (if (>= pos len) (reverse! lst)
78                (let ((npos (+ pos chunk-size)))
79                  (loop npos (cons (byte-substring/shared str pos npos) lst)))))))
80      (if (zero? rem) sublst
81          (append sublst (list (byte-substring/shared str len end))) ) ) )
82
83(define (byte-string->substring-list str chunk-size #!optional (start 0) (end (byte-string-length str)))
84  (map! byte-string-copy (byte-string->substring-list/shared str chunk-size start end)) )
85
86(define (int->hex ch)
87  (let* ((int (char->integer ch))
88         (str (number->string int 16)))
89    (if (< int 16) (conc #\0 str) str) ) )
90
91(define (byte-string->hexadecimal str #!optional (len (byte-string-length str)))
92  (with-output-to-string (lambda () (byte-string-for-each int->hex str 0 len) ) ) )
93
94;;;
95
96(define (->fixnum obj)
97        (let ((->integer
98         (lambda (obj)
99                                   (cond ((integer? obj)   obj)
100                 ((number? obj)    (round obj))
101                 (else             (hash obj most-positive-fixnum) ) ) ) ) )
102                (cond ((fixnum? obj)    obj)
103          ((char? obj)      (char->integer obj))
104          ((boolean? obj)   (if obj 1 0))
105          (else
106           (let ((i (->integer obj)))
107             (inexact->exact
108              (cond ((< i most-negative-fixnum)   (modulo i most-negative-fixnum))
109                    ((< most-positive-fixnum i)   (modulo i most-positive-fixnum))
110                    (else                         i ) ) ) ) ) ) ) )
111
112(define (->blob obj)
113  (cond ((blob? obj)            obj)
114        ((string? obj)          (string->blob obj))
115        ((list? obj)            (->blob (list->byte-string (map ->fixnum obj))))
116        ((vector? obj)          (->blob (vector->list obj)))
117        ((u8vector? obj)        (u8vector->blob obj))
118        ((s8vector? obj)        (s8vector->blob obj))
119        ((u16vector? obj)       (u16vector->blob obj))
120        ((s16vector? obj)       (s16vector->blob obj))
121        ((u32vector? obj)       (u32vector->blob obj))
122        ((s32vector? obj)       (s32vector->blob obj))
123        ((f32vector? obj)       (f32vector->blob obj))
124        ((f64vector? obj)       (f64vector->blob obj))
125        ((or (number? obj) (char? obj) (boolean? obj)) (->fixnum obj))
126        (else                   (->blob (->string obj)) ) ) )
127
128(define (->blob/shared obj)
129  (cond ((u8vector? obj)        (u8vector->blob/shared obj))
130        ((s8vector? obj)        (s8vector->blob/shared obj))
131        ((u16vector? obj)       (u16vector->blob/shared obj))
132        ((s16vector? obj)       (s16vector->blob/shared obj))
133        ((u32vector? obj)       (u32vector->blob/shared obj))
134        ((s32vector? obj)       (s32vector->blob/shared obj))
135        ((f32vector? obj)       (f32vector->blob/shared obj))
136        ((f64vector? obj)       (f64vector->blob/shared obj))
137        (else                   (->blob obj) ) ) )
138
139;;;
140
141(define-constant CHUNK-SIZE 1024)
142
143(define-parameter message-digest-chunk-size CHUNK-SIZE
144  (lambda (x)
145    (cond ((and (fixnum? x) (positive? x)) x)
146          (else
147           (warning 'message-digest-chunk-size "bad argument type - expected a positive fixnum" x)
148           (message-digest-chunk-size) ) ) ) )
149
150(define-record-type message-digest-primitive
151        (%make-message-digest-primitive ctx-info digest-len init update final name)
152        message-digest-primitive?
153        (ctx-info message-digest-primitive-context-info)
154        (digest-len message-digest-primitive-digest-length)
155        (init message-digest-primitive-init)
156        (update message-digest-primitive-update)
157        (final message-digest-primitive-final)
158        (name message-digest-primitive-name) )
159
160(define-inline (%read-u8vector! siz buf obj)
161  (let ((len (read-u8vector! siz buf obj)))
162    (and (positive? len)
163         len ) ) )
164
165(define (make-binary-message-digest obj ctx-info digest-len init update final #!optional (loc 'make-binary-message-digest))
166        (check-procedure 'make-binary-message-digest init)
167  (check-procedure 'make-binary-message-digest update)
168  (check-procedure 'make-binary-message-digest final)
169  (check-context-info loc ctx-info)
170  (let ((ctx #f))
171    (dynamic-wind
172      (lambda () (set! ctx (if (fixnum? ctx-info) (allocate ctx-info) (ctx-info))) )
173      (lambda ()
174        (init ctx)
175        (cond ((string? obj)
176               (update ctx obj (byte-string-length obj)) )
177              ((input-port? obj)
178               (let* ((siz (message-digest-chunk-size))
179                      (buf (make-u8vector siz)))
180                 (while* (%read-u8vector! siz buf obj) (update ctx buf it)) ) )
181              (else
182               (let ((blb (->blob/shared obj)))
183                (update ctx blb (blob-size blb)) ) ) )
184        (let ((result (make-byte-string digest-len)))
185          (final ctx result)
186          result ) )
187      (lambda () (when (fixnum? ctx-info) (free ctx)) ) ) ) )
188
189(define (make-message-digest obj ctx-info digest-len init update final . caller)
190        (string->hexadecimal
191   (make-binary-message-digest obj
192    ctx-info digest-len
193    init update final
194    (optional caller 'make-message-digest))
195   digest-len) )
196
197(define (make-message-digest-primitive ctx-info digest-len init update final . name)
198        (%make-message-digest-primitive
199   ctx-info digest-len
200   init update final
201   (optional name (gensym "mdp"))) )
202
203(define (message-digest-primitive-apply md-prim obj . caller)
204  (check-message-digest-primitive 'message-digest-primitive-apply md-prim)
205        (make-binary-message-digest obj
206         (message-digest-primitive-context-info md-prim)
207         (message-digest-primitive-digest-length md-prim)
208         (message-digest-primitive-init md-prim)
209         (message-digest-primitive-update md-prim)
210         (message-digest-primitive-final md-prim)
211         (optional caller 'message-digest-primitive-apply)) )
Note: See TracBrowser for help on using the repository browser.