Changeset 15592 in project


Ignore:
Timestamp:
08/28/09 05:59:57 (10 years ago)
Author:
Kon Lovett
Message:

Save

Location:
release/4/message-digest/trunk
Files:
1 deleted
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/message-digest/trunk/message-digest.meta

    r15591 r15592  
    77 (doc-from-wiki)
    88 (synopsis "Message Digest Support")
    9  (needs setup-helper mathh miscmacros check-errors)
     9 (needs setup-helper miscmacros check-errors)
    1010 (files
    1111  "tests"
  • release/4/message-digest/trunk/message-digest.scm

    r15591 r15592  
    44;; Issues
    55;;
    6 ;; - Caches the bindings of R5RS & SRFI-13 string procedures so byte-oriented!
     6;; - Renames the bindings of R5RS & SRFI-13 string procedures so byte-oriented!
    77;;
    88;; - The ->fixnum/blob/... is approximate at best!
     
    1111(module message-digest
    1212        (export
     13          ;; Aux
    1314                byte-string->substring-list/shared
    1415                byte-string->substring-list
    1516                byte-string->hexadecimal
    16                 ->blob
    17                 ->blob/shared
    18                 message-digest-chunk-size
     17                ;; Params
     18                message-digest-chunk-size message-digest-chunk-reader message-digest-chunk-converter
     19                ;; Perf
    1920                make-binary-message-digest
    2021                make-message-digest
     22                ;; Type
    2123                make-message-digest-primitive
    2224                message-digest-primitive?
     
    2931                message-digest-primitive-apply)
    3032
    31 (import scheme chicken ports #;data-structures #;lolevel
    32         (only srfi-1 map!)
     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!)
    3340        srfi-4
    34         (only srfi-13 substring/shared string-copy string-for-each
    35                       #;string-length #;list->string #;make-string)
     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))
    3643        (only srfi-69 hash)
    37         #;mathh
     44        miscmacros
    3845        type-checks type-errors)
    39 (import-for-syntax miscmacros)
    40 (require-library ports #;data-structures #;lolevel srfi-1 srfi-4 srfi-13 srfi-69 #;mathh 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)
    4148
    4249(declare
    4350        (not usual-integrations
    44           inexact->exact integer? round number? modulo)
     51          inexact->exact number? integer? round modulo)
    4552        (fixnum)
    4653        (inline)
    47         (no-procedure-checks)
    48         (constant
    49           int->hex
    50                 ->fixnum
    51                 ->blob
    52                 ->blob/shared
    53                 byte-string->hexadecimal) )
    54 
    55 ;;;
    56 
    57 (define (context-info? obj) (or (fixnum? obj) (procedure? obj)))
     54        (no-procedure-checks) )
     55
     56;;;
     57
     58(define (context-info? obj) (or (and (fixnum? obj) (positive? obj)) (procedure? obj)))
    5859
    5960(define-check+error-type message-digest-primitive)
    6061(define-check-type context-info)
    61 (define-error-type context-info "fixnum or procedure")
    62 
    63 
    64 ;;; Cache
    65 
    66 (define byte-string-length string-length)
    67 (define byte-substring/shared substring/shared)
    68 (define byte-string-copy string-copy)
    69 (define byte-string-for-each string-for-each)
    70 (define list->byte-string list->string)
    71 (define make-byte-string make-string)
    72 
    73 ;;;
     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
    7472
    7573(define (byte-string->substring-list/shared str chunk-size #!optional (start 0) (end (byte-string-length str)))
     
    8785  (map! byte-string-copy (byte-string->substring-list/shared str chunk-size start end)) )
    8886
    89 (define (int->hex ch)
     87(define-inline (int->hex ch)
    9088  (let* ((int (char->integer ch))
    9189         (str (number->string int 16)))
    9290    (if (< int 16) (string-append "0" str) str) ) )
    9391
    94 (define (byte-string->hexadecimal str #!optional (len (byte-string-length str)))
    95   (with-output-to-string (lambda () (byte-string-for-each (lambda (x) (display (int->hex x))) str 0 len) ) ) )
    96 
    97 ;;;
    98 
    99 (define (->fixnum obj)
    100         (let ((->integer
    101          (lambda (obj)
    102                                    (cond ((integer? obj)   obj)
    103                  ((number? obj)    (round obj))
    104                  (else             (hash obj most-positive-fixnum) ) ) ) ) )
    105                 (cond ((fixnum? obj)    obj)
    106           ((char? obj)      (char->integer obj))
    107           ((boolean? obj)   (if obj 1 0))
    108           (else
    109            (let ((i (->integer obj)))
    110              (inexact->exact
    111               (cond ((< i most-negative-fixnum)   (modulo i most-negative-fixnum))
    112                     ((< most-positive-fixnum i)   (modulo i most-positive-fixnum))
    113                     (else                         i ) ) ) ) ) ) ) )
    114 
    115 (define (->blob obj)
    116   (cond ((blob? obj)            obj)
    117         ((string? obj)          (string->blob obj))
    118         ((list? obj)            (->blob (list->byte-string (map ->fixnum obj))))
    119         ((vector? obj)          (->blob (vector->list obj)))
    120         ((u8vector? obj)        (u8vector->blob obj))
    121         ((s8vector? obj)        (s8vector->blob obj))
    122         ((u16vector? obj)       (u16vector->blob obj))
    123         ((s16vector? obj)       (s16vector->blob obj))
    124         ((u32vector? obj)       (u32vector->blob obj))
    125         ((s32vector? obj)       (s32vector->blob obj))
    126         ((f32vector? obj)       (f32vector->blob obj))
    127         ((f64vector? obj)       (f64vector->blob obj))
    128         ((or (number? obj) (char? obj) (boolean? obj)) (->fixnum obj))
    129         (else                   (->blob (->string obj)) ) ) )
    130 
    131 (define (->blob/shared obj)
     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)
    132106  (cond ((u8vector? obj)        (u8vector->blob/shared obj))
    133107        ((s8vector? obj)        (s8vector->blob/shared obj))
     
    138112        ((f32vector? obj)       (f32vector->blob/shared obj))
    139113        ((f64vector? obj)       (f64vector->blob/shared obj))
    140         (else                   (->blob obj) ) ) )
    141 
    142 ;;;
    143 
    144 (define-constant CHUNK-SIZE 1024)
    145 
    146 (define-parameter message-digest-chunk-size CHUNK-SIZE
     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
    147126  (lambda (x)
    148127    (cond ((and (fixnum? x) (positive? x)) x)
     
    150129           (warning 'message-digest-chunk-size (make-error-type-message "positive fixnum") x)
    151130           (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;;;
    152184
    153185(define-record-type message-digest-primitive
     
    161193        (name message-digest-primitive-name) )
    162194
    163 (define-inline (%read-u8vector! siz buf obj)
    164   (let ((len (read-u8vector! siz buf obj)))
    165     (and (positive? len)
    166          len ) ) )
    167 
    168 (define (make-binary-message-digest obj ctx-info digest-len init update final #!optional (loc 'make-binary-message-digest))
    169         (check-procedure 'make-binary-message-digest init)
    170   (check-procedure 'make-binary-message-digest update)
    171   (check-procedure 'make-binary-message-digest final)
    172   (check-context-info loc ctx-info)
    173   (let ((ctx #f))
    174     (dynamic-wind
    175       (lambda () (set! ctx (if (fixnum? ctx-info) (allocate ctx-info) (ctx-info))) )
    176       (lambda ()
    177         (init ctx)
    178         (cond ((string? obj)
    179                (update ctx obj (byte-string-length obj)) )
    180               ((input-port? obj)
    181                (let* ((siz (message-digest-chunk-size))
    182                       (buf (make-u8vector siz)))
    183                  (while* (%read-u8vector! siz buf obj) (update ctx buf it)) ) )
    184               (else
    185                (let ((blb (->blob/shared obj)))
    186                 (update ctx blb (blob-size blb)) ) ) )
    187         (let ((result (make-byte-string digest-len)))
    188           (final ctx result)
    189           result ) )
    190       (lambda () (when (fixnum? ctx-info) (free ctx)) ) ) ) )
    191 
    192 (define (make-message-digest obj ctx-info digest-len init update final . caller)
    193         (byte-string->hexadecimal
    194    (make-binary-message-digest obj
    195     ctx-info digest-len
    196     init update final
    197     (optional caller 'make-message-digest))
    198    digest-len) )
    199 
    200195(define (make-message-digest-primitive ctx-info digest-len init update final . name)
    201         (%make-message-digest-primitive
    202    ctx-info digest-len
    203    init update final
    204    (optional name (gensym "mdp"))) )
    205 
    206 (define (message-digest-primitive-apply md-prim obj . caller)
    207   (check-message-digest-primitive 'message-digest-primitive-apply md-prim)
    208         (make-binary-message-digest obj
    209          (message-digest-primitive-context-info md-prim)
    210          (message-digest-primitive-digest-length md-prim)
    211          (message-digest-primitive-init md-prim)
    212          (message-digest-primitive-update md-prim)
    213          (message-digest-primitive-final md-prim)
    214          (optional caller 'message-digest-primitive-apply)) )
     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)) )
    215209
    216210) ;module message-digest
  • release/4/message-digest/trunk/tests/run.scm

    r15591 r15592  
    33(use test)
    44(use message-digest)
     5(use lolevel)
    56
    67;;
    78
    8 (define-test message-digest-test "Message Digest"
    9   (initial
    10                 (define (init ctx)
    11                         (printf "  Init Ctx: ~S~%" ctx))
    12                 (define (update ctx bytes count)
    13                         (printf "Update Ctx: ~S Bytes: ~S Count: ~S~%" ctx bytes count))
    14                 (define (final ctx result)
    15                         (printf " Final Ctx: ~S Result: ~S~%" ctx result))
    16                 (define mdp #f)
    17         )
     9(test-group "Message Digest Aux"
    1810
    19         (expect-equal "2020202020" (make-message-digest "a" 10 5 init update final))
    20 
    21         (expect-set! mdp (make-message-digest-primitive 10 5 init update final))
    22         (expect-true (message-digest-primitive? mdp))
    23         (expect-eqv 10 (message-digest-primitive-context-info mdp))
    24         (expect-eqv 5 (message-digest-primitive-digest-length mdp))
    25         (expect-eq init (message-digest-primitive-init mdp))
    26         (expect-eq update (message-digest-primitive-update mdp))
    27         (expect-eq final (message-digest-primitive-final mdp))
    28 
    29         (expect-set! mdp (make-message-digest-primitive 10 5 init update final 'foo))
    30         (expect-eq 'foo (message-digest-primitive-name mdp))
    31 
    32         (expect-equal '("foo" "bar" "baz") (string->substring-list "foobarbaz" 3))
    33         (expect-equal '("oob" "arb" "az") (string->substring-list "foobarbaz" 3 1))
     11        (test '("foo" "bar" "baz") (byte-string->substring-list "foobarbaz" 3))
     12        (test '("oob" "arb" "az") (byte-string->substring-list "foobarbaz" 3 1))
     13        (test "6162206364" (byte-string->hexadecimal "ab cd"))
    3414)
    3515
    36 (test::styler-set! message-digest-test test::output-style-compact)
    37 (run-test "Message-Digest Tests")
     16(test-group "Message Digest Prim"
     17
     18  (define digest-length 5)
     19  (define chunk-size 10)
     20
     21  (define (init ctx)
     22    #;(printf "  Init Ctx: ~S~%" ctx)
     23    (test-assert (pointer? ctx)) )
     24
     25  (define (update ctx bytes count)
     26    #;(printf "Update Ctx: ~S Bytes: ~S Count: ~S~%" ctx bytes count)
     27    (test-assert (pointer? ctx))
     28    (test-assert (string? bytes))
     29    (test digest-length count)
     30    (move-memory! bytes ctx count) )
     31
     32  (define (final ctx result)
     33    #;(printf " Final Ctx: ~S Result: ~S~%" ctx result)
     34    (test-assert (pointer? ctx))
     35    (test-assert (string? result))
     36    (move-memory! ctx bytes result digest-length) )
     37
     38  (let ((mdp (make-message-digest-primitive chunk-size digest-length init update final 'foo)))
     39
     40      (test-assert (message-digest-primitive? mdp))
     41
     42      (test chunk-size (message-digest-primitive-context-info mdp))
     43      (test digest-length (message-digest-primitive-digest-length mdp))
     44      (test init (message-digest-primitive-init mdp))
     45      (test update (message-digest-primitive-update mdp))
     46      (test final (message-digest-primitive-final mdp))
     47      (test 'foo (message-digest-primitive-name mdp))
     48
     49      (test "6162206364" (byte-string->hexadecimal (message-digest-primitive-apply mdp "ab cd"))) )
     50)
Note: See TracChangeset for help on using the changeset viewer.