Changeset 36722 in project


Ignore:
Timestamp:
10/26/18 18:28:33 (3 weeks ago)
Author:
kon
Message:

add raw -> cooked

Location:
release/5/message-digest-primitive/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/5/message-digest-primitive/trunk/message-digest-primitive.egg

    r36142 r36722  
    33
    44((synopsis "Message Digest Primitive")
    5  (version "4.1.1")
     5 (version "4.2.0")
    66 (category crypt)
    77 (author "[[kon lovett]]")
  • release/5/message-digest-primitive/trunk/message-digest-primitive.scm

    r35915 r36722  
    3434  (chicken gc)
    3535  (chicken type)
     36  (chicken foreign)
    3637  (only (chicken memory) allocate free)
    3738  (only type-checks define-check+error-type check-positive-fixnum check-procedure)
     
    5960(define-type message-digest-primitive-context-info (or fixnum procedure))
    6061
     62;(foreign-lambda void ***Update     c-pointer   scheme-pointer  unsigned-int)
     63;(foreign-lambda void ***RawUpdate  c-pointer   c-pointer       unsigned-int)
     64
    6165(define-type message-digest-primitive-raw-update (or boolean procedure))
    6266
    6367(define-type message-digest-primitive (struct message-digest-primitive))
    64 ;assignment of value of type `(procedure message-digest-primitive#*make-message-digest-primitive (* * * * * * * *) (struct message-digest-primitive#message-digest-primitive))' to toplevel variable `message-digest-primitive#*make-message-digest-primitive' does not match declared type `(procedure message-digest-primitive#*make-message-digest-primitive ((or fixnum procedure) fixnum procedure procedure procedure fixnum (or symbol string) (or boolean procedure)) (struct message-digest-primitive))'
    65 (: *make-message-digest-primitive (message-digest-primitive-context-info fixnum procedure procedure procedure fixnum message-digest-primitive-name message-digest-primitive-raw-update --> message-digest-primitive))
     68
     69;assignment of value of type `(procedure
     70;message-digest-primitive#*make-message-digest-primitive (* * * * * * * *)
     71;(struct message-digest-primitive#message-digest-primitive))' to toplevel
     72;variable `message-digest-primitive#*make-message-digest-primitive' does not
     73;match declared type `(procedure
     74;message-digest-primitive#*make-message-digest-primitive ((or fixnum procedure)
     75;fixnum procedure procedure procedure fixnum (or symbol string) (or boolean
     76;procedure)) (struct message-digest-primitive))'
     77(: *make-message-digest-primitive (message-digest-primitive-context-info fixnum procedure procedure procedure fixnum message-digest-primitive-name message-digest-primitive-raw-update -> message-digest-primitive))
    6678(: message-digest-primitive? (* -> boolean : message-digest-primitive))
    6779(: message-digest-primitive-context-info (message-digest-primitive --> message-digest-primitive-context-info))
     
    95107  (check-positive-fixnum loc digest-len 'digest-length)
    96108  (check-procedure loc init 'digest-initializer)
    97   (check-procedure loc update 'digest-updater)
     109  (when update
     110    (check-procedure loc update 'digest-updater) )
    98111  (check-procedure loc final 'digest-finalizer)
    99112  (check-positive-fixnum loc block-len 'block-length)
     
    105118;;
    106119
     120;(: scheme-object-data-pointer ())
     121(define scheme-object-data-pointer
     122  (foreign-lambda* c-pointer ((scheme-pointer psrc)) "C_return( psrc );"))
     123
     124;;
     125
     126(define ((make-scheme-object-updater raw-update) ctx-info obj len)
     127  (raw-update ctx-info (scheme-object-data-pointer obj) len) )
     128
     129;;
     130
    107131;assignment of value of type `(procedure message-digest-primitive#make-message-digest-primitive (* * * * * #!rest) (struct message-digest-primitive#message-digest-primitive))' to toplevel variable `message-digest-primitive#make-message-digest-primitive' does not match declared type `(procedure message-digest-primitive#make-message-digest-primitive ((or fixnum procedure) fixnum procedure procedure procedure #!rest *) (struct message-digest-primitive))'
    108 (: make-message-digest-primitive (message-digest-primitive-context-info fixnum procedure procedure procedure #!rest -> message-digest-primitive))
     132(: make-message-digest-primitive (message-digest-primitive-context-info fixnum procedure (or boolean procedure) procedure #!rest -> message-digest-primitive))
    109133;
    110134(define (make-message-digest-primitive ctx-info digest-len init update final
    111135            #!key (block-length 4) (name (gensym 'mdp)) (raw-update #f))
    112136  (check-message-digest-arguments 'make-message-digest-primitive
    113     ctx-info digest-len init update final
    114     block-length name raw-update)
    115   (*make-message-digest-primitive
    116     ctx-info digest-len init update final
    117     block-length name raw-update) )
     137    ctx-info digest-len init update final block-length name raw-update)
     138  (let (
     139    (update (or update (and raw-update (make-scheme-object-updater raw-update)))) )
     140    ;we know about raw -> cooked
     141    (unless update
     142      (error 'make-message-digest-primitive "missing update & raw-update") )
     143    (*make-message-digest-primitive
     144      ctx-info digest-len init update final block-length name raw-update) ) )
    118145
    119146;;
  • release/5/message-digest-primitive/trunk/tests/message-digest-primitive-test.scm

    r35915 r36722  
    171171)
    172172
     173;
     174#+compiling
     175(begin
     176  (import (chicken foreign) (chicken memory))
     177  (test-group "Raw => Cooked"
     178
     179    (define the-ctx #f)
     180
     181    (define (init ctx)
     182      ;(printf "  Init Ctx: ~S~%" ctx)
     183      (set! the-ctx ctx)
     184      (assert (pointer? ctx)) )
     185
     186    (define raw-update
     187      (foreign-lambda* void ((c-pointer pctx) (c-pointer pdat) (unsigned-int n))
     188        "memmove(pctx, pdat, n);"))
     189
     190    (define (final ctx result)
     191      ;(printf " Final Ctx: ~S Result: ~S~%" ctx result)
     192      (assert (eq? ctx the-ctx))
     193      (assert (not (not result)))
     194      (assert (pointer? ctx))
     195      (assert (or (blob? result) (string? result)))
     196      ; So no mem overflow
     197      (assert (<= DIGEST-LENGTH (if (blob? result) (blob-size result) (string-length result))))
     198      (move-memory! ctx result DIGEST-LENGTH) )
     199
     200    (let* (
     201      (mdp (make-message-digest-primitive CONTEXT-SIZE DIGEST-LENGTH init #f final #:raw-update raw-update))
     202      (ctx (make-message-digest-primitive-context mdp)) )
     203      (test-assert "allocated context" ctx)
     204      (test-assert "generated update"(message-digest-primitive-update mdp))
     205      ((message-digest-primitive-update mdp) ctx "foobar" 3)
     206      (test "f[oo]" #\f (integer->char (pointer-u8-ref ctx)))
     207      (test "fo[o]" #\o (integer->char (pointer-u8-ref (pointer+ ctx 1))))
     208      (test "foo[]" #\o (integer->char (pointer-u8-ref (pointer+ ctx 2))))
     209      ;FIXME Add Life-Cycle Tests
     210      )
     211  )
     212)
     213
    173214;;;
    174215
Note: See TracChangeset for help on using the changeset viewer.