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

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

Dropped use of "ports".

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