Ignore:
Timestamp:
07/09/18 19:09:54 (2 years ago)
Author:
Kon Lovett
Message:

C5 fixes

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

Legend:

Unmodified
Added
Removed
  • release/5/message-digest-primitive/trunk/tests/message-digest-primitive-test.scm

    r35826 r35827  
    1 ;;;; message-digest-test.scm
     1;;;; message-digest-primitive-test.scm  -*- Scheme -*-
     2;;;; Kon Lovett, Jul '18
    23
    3 ;; Issues
    4 ;;
    5 ;; - Needs many more tests, especially the entire input-port & procedure source stuff.
     4(import test)
    65
    7 (use test)
    8 (use message-digest message-digest-port)
    9 (use files lolevel srfi-4)
    10 (use setup-api)
     6(test-begin "Message Digest Primitive")
     7
     8;;;
     9
     10(import (chicken blob) message-digest-primitive)
    1111
    1212;;
     
    4141
    4242;;
    43 
    44 (test-begin "Message Digest")
    45 
    46 (test 'hex-string (message-digest-result-form 'hex))
    47 
    48 ;Tests defaults
    49 (test-group "Chunk Read (port)"
    50   (let (
    51     (siz (message-digest-chunk-size))
    52     (in (open-input-file SHORT-TEST-FILE-NAME)) )
    53     (let* (
    54       (rdr ((message-digest-chunk-port-read-maker) in))
    55       (res (rdr)) )
    56       (test-assert "First chunk type" (blob? res))
    57       (test "First chunk size" SHORT-TEST-FILE-LENGTH (blob-size res))
    58       (test-assert "No more chunk" (not (rdr))) )
    59     (close-input-port in) )
    60 )
    6143
    6244(test-group "Make Primitive"
     
    9375  (let (
    9476    (mdp
    95       (make-message-digest-primitive CONTEXT-SIZE DIGEST-LENGTH init update final 'foo)) )
     77      (make-message-digest-primitive CONTEXT-SIZE DIGEST-LENGTH init update final #:name 'foo)) )
    9678    (test BLOCK-LENGTH-DEFAULT (message-digest-primitive-block-length mdp))
    9779    (test 'foo (message-digest-primitive-name mdp)) )
     
    9981  (let (
    10082    (mdp
    101       (make-message-digest-primitive CONTEXT-SIZE DIGEST-LENGTH init update final BLOCK-LENGTH)) )
     83      (make-message-digest-primitive CONTEXT-SIZE DIGEST-LENGTH init update final #:block-length BLOCK-LENGTH)) )
    10284    (test BLOCK-LENGTH (message-digest-primitive-block-length mdp))
    10385    (test-assert (symbol? (message-digest-primitive-name mdp))) )
     
    10587  (let (
    10688    (mdp
    107       (make-message-digest-primitive CONTEXT-SIZE DIGEST-LENGTH init update final BLOCK-LENGTH 'foo)) )
     89      (make-message-digest-primitive CONTEXT-SIZE DIGEST-LENGTH init update final #:block-length BLOCK-LENGTH #:name 'foo)) )
    10890    (test BLOCK-LENGTH (message-digest-primitive-block-length mdp))
    10991    (test 'foo (message-digest-primitive-name mdp)) )
     
    141123    (move-memory! ctx result DIGEST-LENGTH) )
    142124
    143   (let (
    144     (mdp (make-message-digest-primitive CONTEXT-SIZE DIGEST-LENGTH init update final)) )
    145     (let (
    146       (md (initialize-message-digest mdp)) )
    147       (test-assert (message-digest? md))
    148       (test-assert (message-digest-update-string md simple-src))
    149       (test simple-res (finalize-message-digest md)) )
    150     (let (
    151       (md (initialize-message-digest mdp))
    152       (blb (make-blob 100)) )
    153       (message-digest-update-string md simple-src)
    154       (test-assert (finalize-message-digest! md blb))
    155       (print "result = " blb) )
    156     (let (
    157       (md (initialize-message-digest mdp))
    158       (str (make-string 100 #\space)) )
    159       (message-digest-update-string md simple-src)
    160       (test-assert (finalize-message-digest! md str))
    161       (print "result = " #\" str #\") )
    162     (let (
    163       (md (initialize-message-digest mdp))
    164       (vec (make-u8vector 100 0)) )
    165       (message-digest-update-string md simple-src)
    166       (test-assert (finalize-message-digest! md vec))
    167       (print "result = " vec) ) )
     125  (let* (
     126    (mdp (make-message-digest-primitive CONTEXT-SIZE DIGEST-LENGTH init update final))
     127    (ctx (make-message-digest-primitive-context (message-digest-primitive-context-info mdp))) )
     128    (test-assert "allocated context" ctx)
     129    ;FIXME Add Life-Cycle Tests
     130    )
    168131)
    169132
     
    202165  (let* (
    203166    (mdp (make-message-digest-primitive make-context DIGEST-LENGTH init update final))
    204     (md (initialize-message-digest mdp)) )
    205     (test-assert (message-digest? md))
    206     (test-assert (message-digest-update-string md simple-src))
    207     (test simple-res (finalize-message-digest md)) )
     167    (ctx (make-message-digest-primitive-context (message-digest-primitive-context-info mdp))) )
     168    (test-assert "allocated context" ctx)
     169    ;FIXME Add Life-Cycle Tests
     170    )
    208171)
    209172
    210 (let ()
     173;;;
    211174
    212         (define the-ctx #f)
    213 
    214   (define (make-context)
    215     ;Init to 0 necessary since DIGEST-LENGTH is possibly > than
    216     ;the input size! (Actually just needs to be a known value,
    217     ;`(integer->char #xff)' would work as well.)
    218     (string->blob (make-string CONTEXT-SIZE #\nul)) )
    219 
    220   (define (init ctx)
    221     (set! the-ctx ctx) )
    222 
    223   (define (update ctx bytes count)
    224     ;(printf "Update Ctx: ~S Bytes: ~S Count: ~S~%" ctx bytes count) (flush-output)
    225     (assert (eq? ctx the-ctx))
    226     (assert (not (not bytes)))
    227     (assert (< 0 count))
    228     (assert (<= count CONTEXT-SIZE))  ; So no mem overflow
    229     (assert (blob? ctx))
    230     (move-memory! bytes ctx count) )
    231 
    232   (define (final ctx result)
    233     ;(printf " Final Result Size: ~S Ctx: ~S Result: ~S~%" (blob-size result) ctx result) (flush-output)
    234     (assert (eq? ctx the-ctx))
    235     (assert (not (not result)))
    236     (assert (blob? ctx))
    237     (assert (<= (blob-size result) DIGEST-LENGTH))  ; So no mem overflow
    238     (move-memory! ctx result DIGEST-LENGTH) )
    239 
    240   (define mdp (make-message-digest-primitive make-context DIGEST-LENGTH init update final))
    241 
    242   (test-group "u8vector Source"
    243     (let (
    244       (md (initialize-message-digest mdp)) )
    245       (test-assert (message-digest-update-u8vector md (u8vector 1 2 3 4 5)))
    246       (test "0102030405" (finalize-message-digest md)) )
    247   )
    248 
    249   (test-group "u8 Source"
    250     (let (
    251       (md (initialize-message-digest mdp)) )
    252       (test-assert (message-digest-update-u8 md #xA2))
    253       (test "a200000000" (finalize-message-digest md)) )
    254   )
    255 
    256   (test-group "u16-le Source"
    257     (let (
    258       (md (initialize-message-digest mdp)) )
    259       (test-assert (message-digest-update-u16-le md #xA2B2))
    260       (test "b2a2000000" (finalize-message-digest md)) )
    261   )
    262 
    263   (test-group "u32-be Source"
    264     (let (
    265       (md (initialize-message-digest mdp)) )
    266       (test-assert (message-digest-update-u32-be md 1073741823))
    267       (test "3fffffff00" (finalize-message-digest md)) )
    268   )
    269 
    270   (when (version>=? (chicken-version) "4.6.4")
    271           (test-group "u32-be Source"
    272                         (let (
    273         (md (initialize-message-digest mdp)) )
    274                                 (test-assert (message-digest-update-u32-be md #xA2B2C2D2))
    275                                 (test "a2b2c2d200" (finalize-message-digest md)) )
    276                 ) )
    277 
    278   (when (version>=? (chicken-version) "4.8.1")
    279                 (test-group "u64-be Source"
    280                         (let (
    281         (md (initialize-message-digest mdp)) )
    282                                 (test-assert (message-digest-update-u64-be md #xAB54A98CEB1F0AD2))
    283                                 (test
    284                                   (substring "ab54a98ceb1f0ad2" 0 (fx* 2 (fxmin 8 DIGEST-LENGTH)))
    285                                   (finalize-message-digest md)) )
    286                 ) )
    287 
    288   (test-group "char-u8 Source"
    289     (let (
    290       (md (initialize-message-digest mdp)) )
    291       (test-assert (message-digest-update-char-u8 md #\space))
    292       (test "2000000000" (finalize-message-digest md)) )
    293   )
    294 
    295   (test-group "char-be Source"
    296     (let (
    297       (md (initialize-message-digest mdp)) )
    298       (test-assert (message-digest-update-char-be md #\u0003BB))
    299       (test "000003bb00" (finalize-message-digest md)) )
    300   )
    301 
    302   (test-group "char-le Source"
    303     (let (
    304       (md (initialize-message-digest mdp)) )
    305       (test-assert (message-digest-update-char-le md #\u0003BB))
    306       (test "bb03000000" (finalize-message-digest md)) )
    307   )
    308 
    309   (test-group "Procedure Source"
    310     (let (
    311       (md (initialize-message-digest mdp)) )
    312       (test-assert (message-digest-update-procedure md just-once))
    313       (test simple-res (finalize-message-digest md)) )
    314   )
    315 
    316   (test-group "Port"
    317     (let (
    318       (port (open-output-digest mdp)) )
    319       (test-assert (output-port? port))
    320       (display simple-src port) ;cannot be readable!
    321       (test simple-res (get-output-digest port))
    322       (test-assert (port-closed? port)) )
    323   )
    324 )
    325 
    326 #; ;REMOVED
    327 (begin
    328         (use message-digest-old)
    329 
    330         (define the-ctx #f)
    331 
    332   (define (make-context)
    333     (string->blob (make-string CONTEXT-SIZE #\nul)) )
    334 
    335   (define (init ctx)
    336     (set! the-ctx ctx) )
    337 
    338   (define (update ctx bytes count)
    339     (assert (eq? ctx the-ctx))
    340     (assert (not (not bytes)))
    341     (assert (< 0 count))
    342     (assert (<= count CONTEXT-SIZE))  ; So no mem overflow
    343     (assert (blob? ctx))
    344     (move-memory! bytes ctx count) )
    345 
    346   (define (final ctx result)
    347     (assert (eq? ctx the-ctx))
    348     (assert (not (not result)))
    349     (assert (blob? ctx))
    350     (assert (<= (blob-size result)  DIGEST-LENGTH))  ; So no mem overflow
    351     (move-memory! ctx result DIGEST-LENGTH) )
    352 
    353   (test-group "Primitive Apply (DEPRECATED)"
    354     (let* (
    355       (mdp
    356         (make-message-digest-primitive CONTEXT-SIZE DIGEST-LENGTH init update final))
    357       (res (message-digest-primitive-apply mdp simple-src)) )
    358       (test-assert (string? res))
    359       (test simple-res (byte-string->hexadecimal res)) )
    360   )
    361 
    362   (test-group "Make (DEPRECATED)"
    363     (test simple-src (make-binary-message-digest simple-src make-context DIGEST-LENGTH init update final))
    364     (test simple-res (make-message-digest simple-src make-context DIGEST-LENGTH init update final))
    365   )
    366 )
    367 
    368 ;
    369 (test-group "Chunk Read (fileno)"
    370 
    371         (define the-ctx #f)
    372 
    373   (define (init ctx)
    374     ;(printf "  Init Ctx: ~S~%" ctx)
    375     (assert (pointer? ctx))
    376     (set! the-ctx ctx) )
    377 
    378   (define (update ctx bytes count)
    379         ;(printf "Update Ctx: ~S Count: ~S Bytes: ~S~%" ctx count bytes)
    380     (assert (eq? ctx the-ctx))
    381     (assert (not (not bytes)))
    382     (assert (< 0 count))
    383     (assert (<= count CONTEXT-SIZE))
    384     (assert (pointer? ctx))
    385     (move-memory! bytes ctx count) )
    386 
    387   (define (raw-update ctx bytes count)
    388         ;(printf "Raw-Update Ctx: ~S Count: ~S Bytes: ~S~%" ctx count bytes)
    389     (assert (eq? ctx the-ctx))
    390     (assert (not (not bytes)))
    391     (assert (< 0 count))
    392     (assert (= SHORT-TEST-FILE-LENGTH count))
    393     (assert (pointer? ctx))
    394     (move-memory! bytes ctx (min CONTEXT-SIZE count)) )
    395 
    396   (define (final ctx result)
    397     ;(printf " Final Ctx: ~S Length: ~S Result: ~S~%" ctx DIGEST-LENGTH result)
    398     (assert (eq? ctx the-ctx))
    399     (assert (not (not result)))
    400     (assert (pointer? ctx))
    401     ;(assert (<= 0 DIGEST-LENGTH))
    402     (move-memory! ctx result DIGEST-LENGTH) )
    403 
    404   (let (
    405     (mdp
    406       (make-message-digest-primitive CONTEXT-SIZE DIGEST-LENGTH init update final raw-update)) )
    407     (test "6162636465" (message-digest-file mdp SHORT-TEST-FILE-NAME 'hex-string)) )
    408 )
    409 
    410 (test-end)
     175(test-end "Message Digest Primitive")
    411176
    412177(test-exit)
  • release/5/message-digest-primitive/trunk/tests/run.scm

    r35826 r35827  
    44;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
    55
    6 (use files)
     6(import
     7  (only (chicken pathname) make-pathname)
     8  (only (chicken process) system)
     9  (only (chicken process-context) argv)
     10  (only (chicken format) format))
     11
     12(define *args* (argv))
    713
    814;no -disable-interrupts
    9 (define *csc-options* "-inline-global -scrutinize -optimize-leaf-routines -local -inline -specialize -unsafe -no-trace -no-lambda-info -clustering -lfa2")
    10 
    11 (define *args* (argv))
     15(define *csc-options* "-inline-global \
     16  -specialize -optimize-leaf-routines -clustering -lfa2 \
     17  -local -inline \
     18  -no-trace -no-lambda-info \
     19  -unsafe")
    1220
    1321(define (test-name #!optional (eggnam EGG-NAME))
     
    2937(define (run-test #!optional (eggnam EGG-NAME) (cscopts *csc-options*))
    3038  (let ((tstnam (test-name eggnam)))
    31     (print "*** csi ***")
     39    (format #t "*** csi ***~%")
    3240    (system (string-append "csi -s " (make-pathname #f tstnam "scm")))
    3341    (newline)
    34     (print "*** csc (" cscopts ") ***")
     42    (format #t "*** csc ~s ***~%" cscopts)
    3543    (system (string-append "csc" " " cscopts " " (make-pathname #f tstnam "scm")))
    3644    (system (make-pathname (cond-expand (unix "./") (else #f)) tstnam)) ) )
Note: See TracChangeset for help on using the changeset viewer.