source: project/release/4/message-digest/trunk/message-digest.scm @ 15592

Last change on this file since 15592 was 15592, checked in by Kon Lovett, 10 years ago

Save

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