Changeset 36722 in project for release

Timestamp:

10/26/18 18:28:33 (2 years ago)

Author:

Kon Lovett

Message:

add raw -> cooked

Location:

release/5/message-digest-primitive/trunk

Files:

• message-digest-primitive.egg (modified) (1 diff)
• message-digest-primitive.scm (modified) (4 diffs)
• tests/message-digest-primitive-test.scm (modified) (1 diff)

release/5/message-digest-primitive/trunk/message-digest-primitive.egg

@@ -3 +3 @@
 
 ((synopsis "Message Digest Primitive")
- (version "4.1.1")
+ (version "4.2.0")
  (category crypt)
  (author "[[kon lovett]]")

release/5/message-digest-primitive/trunk/message-digest-primitive.scm

@@ -34 +34 @@
   (chicken gc)
   (chicken type)
+  (chicken foreign)
   (only (chicken memory) allocate free)
   (only type-checks define-check+error-type check-positive-fixnum check-procedure)
@@ -59 +60 @@
 (define-type message-digest-primitive-context-info (or fixnum procedure))
 
+;(foreign-lambda void ***Update     c-pointer   scheme-pointer  unsigned-int)
+;(foreign-lambda void ***RawUpdate  c-pointer   c-pointer       unsigned-int)
+
 (define-type message-digest-primitive-raw-update (or boolean procedure))
 
 (define-type message-digest-primitive (struct message-digest-primitive))
-;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))'
-(: *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))
+
+;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))'
+(: *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))
 (: message-digest-primitive? (* -> boolean : message-digest-primitive))
 (: message-digest-primitive-context-info (message-digest-primitive --> message-digest-primitive-context-info))
@@ -95 +107 @@
   (check-positive-fixnum loc digest-len 'digest-length)
   (check-procedure loc init 'digest-initializer)
-  (check-procedure loc update 'digest-updater)
+  (when update
+    (check-procedure loc update 'digest-updater) )
   (check-procedure loc final 'digest-finalizer)
   (check-positive-fixnum loc block-len 'block-length)
@@ -105 +118 @@
 ;;
 
+;(: scheme-object-data-pointer ())
+(define scheme-object-data-pointer
+  (foreign-lambda* c-pointer ((scheme-pointer psrc)) "C_return( psrc );"))
+
+;;
+
+(define ((make-scheme-object-updater raw-update) ctx-info obj len)
+  (raw-update ctx-info (scheme-object-data-pointer obj) len) )
+
+;;
+
 ;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))'
-(: make-message-digest-primitive (message-digest-primitive-context-info fixnum procedure procedure procedure #!rest -> message-digest-primitive))
+(: make-message-digest-primitive (message-digest-primitive-context-info fixnum procedure (or boolean procedure) procedure #!rest -> message-digest-primitive))
 ;
 (define (make-message-digest-primitive ctx-info digest-len init update final
             #!key (block-length 4) (name (gensym 'mdp)) (raw-update #f))
   (check-message-digest-arguments 'make-message-digest-primitive
-    ctx-info digest-len init update final
-    block-length name raw-update)
-  (*make-message-digest-primitive
-    ctx-info digest-len init update final
-    block-length name raw-update) )
+    ctx-info digest-len init update final block-length name raw-update)
+  (let (
+    (update (or update (and raw-update (make-scheme-object-updater raw-update)))) )
+    ;we know about raw -> cooked
+    (unless update
+      (error 'make-message-digest-primitive "missing update & raw-update") )
+    (*make-message-digest-primitive
+      ctx-info digest-len init update final block-length name raw-update) ) )
 
 ;;

release/5/message-digest-primitive/trunk/tests/message-digest-primitive-test.scm

@@ -171 +171 @@
 )
 
+;
+#+compiling
+(begin
+  (import (chicken foreign) (chicken memory))
+  (test-group "Raw => Cooked"
+
+    (define the-ctx #f)
+
+    (define (init ctx)
+      ;(printf "  Init Ctx: ~S~%" ctx)
+      (set! the-ctx ctx)
+      (assert (pointer? ctx)) )
+
+    (define raw-update
+      (foreign-lambda* void ((c-pointer pctx) (c-pointer pdat) (unsigned-int n))
+        "memmove(pctx, pdat, n);"))
+
+    (define (final ctx result)
+      ;(printf " Final Ctx: ~S Result: ~S~%" ctx result)
+      (assert (eq? ctx the-ctx))
+      (assert (not (not result)))
+      (assert (pointer? ctx))
+      (assert (or (blob? result) (string? result)))
+      ; So no mem overflow
+      (assert (<= DIGEST-LENGTH (if (blob? result) (blob-size result) (string-length result))))
+      (move-memory! ctx result DIGEST-LENGTH) )
+
+    (let* (
+      (mdp (make-message-digest-primitive CONTEXT-SIZE DIGEST-LENGTH init #f final #:raw-update raw-update))
+      (ctx (make-message-digest-primitive-context mdp)) )
+      (test-assert "allocated context" ctx)
+      (test-assert "generated update"(message-digest-primitive-update mdp))
+      ((message-digest-primitive-update mdp) ctx "foobar" 3)
+      (test "f[oo]" #\f (integer->char (pointer-u8-ref ctx)))
+      (test "fo[o]" #\o (integer->char (pointer-u8-ref (pointer+ ctx 1))))
+      (test "foo[]" #\o (integer->char (pointer-u8-ref (pointer+ ctx 2))))
+      ;FIXME Add Life-Cycle Tests
+      )
+  )
+)
+
 ;;;