Changeset 34373 in project


Ignore:
Timestamp:
08/26/17 22:31:52 (4 weeks ago)
Author:
kon
Message:

add raw-update to prim, use raw-update for mmapped/in-mem file md

Location:
release/4/message-digest/trunk
Files:
8 edited

Legend:

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

    r34300 r34373  
    1414  message-digest-primitive
    1515  message-digest-type
    16   message-digest-parameters
     16  message-digest-chunk
    1717  message-digest-bv
    1818  message-digest-int)
     
    2020  message-digest-primitive
    2121  message-digest-type
    22   message-digest-parameters
     22  message-digest-chunk
    2323  message-digest-bv
    2424  message-digest-int)
  • release/4/message-digest/trunk/message-digest-parameters.scm

    r34302 r34373  
    44;;;; Kon Lovett, Apr '12
    55
    6 ;; Issues
    7 ;;
    8 ;; - Uses 'context-info' to determine whether active context is "own" allocation or
    9 ;; callers. Again, a kludge.
    10 ;;
    11 ;; - Passes u8vector to update phase as a blob.
     6(module message-digest-parameters ()
    127
    13 (module message-digest-parameters
     8(import scheme chicken)
    149
    15 (;export
    16   ; Parameters
    17   message-digest-chunk-size
    18   message-digest-chunk-read-maker
    19   message-digest-chunk-converter)
    20 
    21 (import scheme)
    22 
    23 (import
    24   chicken
    25   (only srfi-4
    26     u8vector->blob/shared subu8vector
    27     read-u8vector! make-u8vector))
    28 (require-library
    29   srfi-4)
    30 
    31 (require-extension
    32   miscmacros)
    33 
    34 ;;; Update Phase Helpers
    35 
    36 ;;
    37 
    38 (define (positive-fixnum? obj)
    39   (and (fixnum? obj) (positive? obj)) )
    40 
    41 ;;
    42 
    43 (define (default-chunk-read-maker in #!optional (size (message-digest-chunk-size)))
    44   (let ((u8buf (make-u8vector size)))
    45     (lambda ()
    46       (let ((len (read-u8vector! size u8buf in)))
    47         (and
    48           (positive? len)
    49           (let ((u8buf (if (fx= len size) u8buf (subu8vector u8buf 0 len))))
    50             (u8vector->blob/shared u8buf) ) ) ) ) ) )
    51 
    52 ;;
    53 
    54 (define-constant DEFAULT-CHUNK-SIZE 1024)
    55 
    56 ;;; Message Digest "Parameters"
    57 
    58 ;;
    59 
    60 (define-parameter message-digest-chunk-size DEFAULT-CHUNK-SIZE
    61   (lambda (x)
    62     (cond
    63       ((positive-fixnum? x)   x )
    64       ((not x)                DEFAULT-CHUNK-SIZE )
    65       (else
    66         (warning 'message-digest-chunk-size "invalid positive-fixnum" x)
    67         (message-digest-chunk-size) ) ) ) )
    68 
    69 ;;
    70 
    71 (define-parameter message-digest-chunk-read-maker default-chunk-read-maker
    72   (lambda (x)
    73     (cond
    74       ((procedure? x)   x )
    75       ((not x)          default-chunk-read-maker )
    76       (else
    77         (warning 'message-digest-chunk-read-maker "invalid procedure" x)
    78         (message-digest-chunk-read-maker) ) ) ) )
    79 
    80 ;;
    81 
    82 (define-parameter message-digest-chunk-converter #f
    83   (lambda (x)
    84     (if (or (not x) (procedure? x))
    85       x
    86       (begin
    87         (warning 'message-digest-chunk-converter "invalid procedure or #f" x)
    88         (message-digest-chunk-converter) ) ) ) )
     10(reexport message-digest-chunk)
     11(require-library message-digest-chunk)
    8912
    9013) ;module message-digest-parameters
  • release/4/message-digest/trunk/message-digest-primitive.scm

    r34300 r34373  
    1919  message-digest-primitive-init
    2020  message-digest-primitive-update
    21   message-digest-primitive-final)
     21  message-digest-primitive-final
     22  message-digest-primitive-raw-update)
    2223
    2324(import scheme)
     
    4344  (and (fixnum? obj) (positive? obj)) )
    4445
     46(define (primitive-ctx-info? obj)
     47  (or (procedure? obj) (positive-fixnum? obj)) )
     48
     49(define (primitive-name? obj)
     50  (or (symbol? obj) (string? obj)) )
     51
    4552;;; Message Digest Algorithm API
    4653
    4754;;
    4855
    49 (define (check-message-digest-arguments loc ctx-info digest-len init update final block-len name)
    50   (unless (or (procedure? ctx-info) (positive-fixnum? ctx-info))
     56(define (check-message-digest-arguments loc ctx-info digest-len init update final block-len name raw-update)
     57  (unless (primitive-ctx-info? ctx-info)
    5158    (error-argument-type loc ctx-info "positive-fixnum or procedure" 'context-info) )
    5259  (check-positive-fixnum loc digest-len 'digest-length)
     
    5562  (check-procedure loc final 'digest-finalizer)
    5663  (check-positive-fixnum loc block-len 'block-length)
    57   (unless (or (symbol? name) (string? name))
    58     (error-argument-type loc name "symbol or string" 'name) ) )
     64  (unless (primitive-name? name)
     65    (error-argument-type loc name "symbol or string" 'name) )
     66  (when raw-update
     67    (check-procedure loc raw-update 'digest-raw-updater) ) )
    5968
    6069;;
    6170
    6271(define-record-type message-digest-primitive
    63   (*make-message-digest-primitive ctxi digest-len init update final block-len name)
     72  (*make-message-digest-primitive ctxi digest-len init update final block-len name raw-update)
    6473  message-digest-primitive?
    6574  (ctxi message-digest-primitive-context-info)
     
    6978  (final message-digest-primitive-final)
    7079  (block-len message-digest-primitive-block-length)
    71   (name message-digest-primitive-name) )
     80  (name message-digest-primitive-name)
     81  (raw-update message-digest-primitive-raw-update) )
    7282
    7383(define-check+error-type message-digest-primitive)
     
    7888                  (values (car rest) (cdr rest))
    7989                  (values 4 rest) ) ) )
    80     (let ((name (if (null? rest) (gensym "mdp") (car rest) ) ) )
    81       (check-message-digest-arguments 'make-message-digest-primitive
    82         ctx-info digest-len init update final block-len name)
    83       (*make-message-digest-primitive
    84         ctx-info
    85         digest-len
    86         init update final
    87         block-len
    88         name) ) ) )
     90    (let-values (((name rest)
     91                  (if (and (not (null? rest)) (primitive-name? (car rest)))
     92                    (values (car rest) (cdr rest))
     93                    (values (gensym 'mdp) rest) ) ) )
     94      (let-values (((raw-update rest)
     95                    (if (and (not (null? rest)) (procedure? (car rest)))
     96                      (values (car rest) (cdr rest))
     97                      (values #f rest) ) ) )
     98        (check-message-digest-arguments 'make-message-digest-primitive
     99          ctx-info digest-len init update final block-len name raw-update)
     100        (*make-message-digest-primitive
     101          ctx-info
     102          digest-len
     103          init update final
     104          block-len
     105          name
     106          raw-update) ) ) ) )
     107
     108;;
     109
     110(define do-raw-update
     111
    89112
    90113) ;module message-digest-primitive
  • release/4/message-digest/trunk/message-digest-update-item.scm

    r34300 r34373  
    1717(import scheme)
    1818
     19(import chicken)
     20
    1921(import
    20   chicken
    21   (only lolevel number-of-bytes))
     22  (only lolevel number-of-bytes pointer?))
    2223(require-library
    2324  lolevel)
     25
     26(import
     27  (only posix
     28    file-open file-close
     29    open/rdonly
     30    directory?))
     31(require-library
     32  posix)
    2433
    2534(import
     
    3140  message-digest-primitive
    3241  message-digest-type
    33   message-digest-parameters
     42  message-digest-chunk
    3443  message-digest-support
    3544  type-checks
     
    4049;;
    4150
     51;=> #f or converted-chunk
    4252(define (chunk-convert obj)
    4353  (and-let* ((cnv (message-digest-chunk-converter)))
    4454    (cnv obj) ) )
    4555
    46 (define (get-chunk-reader in)
    47         ((message-digest-chunk-read-maker) in) )
     56(define (get-port-chunk-reader in)
     57        ((message-digest-chunk-port-read-maker) in) )
     58
     59(define (get-fileno-chunk-reader fd)
     60        ((message-digest-chunk-fileno-read-maker) fd) )
    4861
    4962(define (get-update md)
    5063  (message-digest-primitive-update (message-digest-algorithm md)) )
     64
     65(define (get-raw-update md)
     66  (message-digest-primitive-raw-update (message-digest-algorithm md)) )
    5167
    5268;;
     
    5975
    6076(define (do-port-update loc md in)
    61   (do-procedure-update loc md (get-chunk-reader in)) )
     77  (do-procedure-update loc md (get-port-chunk-reader in)) )
    6278
    6379(define (do-bytes-update loc md src)
     
    6682    (message-digest-context md)
    6783    src
    68     (get-update md)) )
     84    (get-update md)
     85    (get-raw-update md)) )
    6986
    70 (define (do-byte-source-update loc ctx src updt)
     87(define (do-procedure-update loc md proc)
     88  (let ((s-updt (get-update md))
     89        (r-updt (get-raw-update md))
     90        (ctx (message-digest-context md)) )
     91    ;note the 'src' object (return of proc) may or may not be unique
     92    (while* (proc)
     93      (do-byte-source-update loc ctx it s-updt r-updt) ) ) )
     94
     95(define (do-byte-source-update loc ctx src s-updt r-updt)
    7196  (cond
    7297    ; simple bytes
    7398    ((blob? src)
    74         (updt ctx src (number-of-bytes src)) )
     99        (s-updt ctx src (number-of-bytes src)) )
    75100    ((string? src)
    76         (do-byte-source-update loc ctx (string->blob src) updt) )
     101        (do-byte-source-update loc ctx (string->blob src) s-updt r-updt) )
     102    ((message-digest-raw-chunk? src)
     103      (let* ((obj (message-digest-raw-chunk-object src))
     104             (updtr (if (pointer? obj) r-updt s-updt)))
     105        (unless updtr
     106          (error loc "primitive does not support raw-update") )
     107        (updtr ctx obj (message-digest-raw-chunk-size src)) ) )
    77108    ; more complicated bytes
    78109    ((object->bytevector-like src) =>
    79         (cut do-byte-source-update loc ctx <> updt) )
     110        (cut do-byte-source-update loc ctx <> s-updt r-updt) )
    80111    ; too complicated bytes
    81112    (else
    82113      (signal-type-error loc "indigestible object" src) ) ) )
    83114
    84 (define (do-procedure-update loc md proc)
    85   (let ((updt (get-update md))
    86         (ctx (message-digest-context md)) )
    87     (while* (proc) (do-byte-source-update loc ctx it updt) ) ) )
     115;;
    88116
     117;=> #f or bytevector-like
    89118(define (object->bytevector-like obj)
    90119  (or
     
    121150
    122151(define (message-digest-update-file md flnm)
    123   (let ((in (open-input-file (check-string 'message-digest-update-file flnm))))
     152  ;
     153  (unless (file-exists? (check-string 'message-digest-update-file flnm))
     154    (error 'message-digest-update-file "no such file" flnm) )
     155  ;
     156  #; ;can't open a directory?
     157  (when (directory? flnm)
     158    (error 'message-digest-update-file "file is a directory" flnm) )
     159  ;
     160  (if (get-raw-update (check-message-digest 'message-digest-update-file md))
     161    (*message-digest-update-file/fileno 'message-digest-update-file md flnm)
     162    (*message-digest-update-file/port 'message-digest-update-file md flnm) ) )
     163
     164(define (*message-digest-update-file/fileno loc md flnm)
     165  (let ((fd (file-open flnm open/rdonly)))
     166    (handle-exceptions
     167      ;as
     168      exn
     169      ;with
     170      (begin
     171        (file-close fd)
     172        (abort exn) )
     173      ;in
     174      (do-procedure-update loc md (get-fileno-chunk-reader fd)) )
     175    (file-close fd) ) )
     176
     177(define (*message-digest-update-file/port loc md flnm)
     178  (let ((in (open-input-file flnm)))
    124179    (handle-exceptions
    125180      ;as
     
    130185        (abort exn) )
    131186      ;in
    132       (do-port-update 'message-digest-update-file (check-message-digest 'message-digest-update-file md) in) )
     187      (do-port-update loc md in) )
    133188    (close-input-port in) ) )
    134189
    135190#;
    136191(define (message-digest-update-file md flnm)
    137   (check-message-digest 'message-digest-update-file md)
    138   (check-string 'message-digest-update-file flnm)
    139192  (let ((in #f))
    140193        (dynamic-wind
  • release/4/message-digest/trunk/message-digest.meta

    r34300 r34373  
    2323        "message-digest-bv.scm"
    2424        "message-digest-support.scm"
    25         "message-digest-parameters.scm"
     25        "message-digest-message-digest-chunk.scm"
    2626        "message-digest-int.scm"
    2727        "message-digest-item.scm"
    2828        "message-digest-srfi-4.scm"
    29         "message-digest.meta" "message-digest.setup" "message-digest.release-info" "tests/run.scm" "tests/alpha.txt") )
     29        "message-digest.meta" "message-digest.setup" "message-digest.release-info"
     30        "tests/run.scm" "tests/alpha.txt"
     31        ;DEPRECATED
     32        "message-digest-parameters.scm") )
  • release/4/message-digest/trunk/message-digest.scm

    r34300 r34373  
    1212  message-digest-primitive
    1313  message-digest-type
    14   message-digest-parameters
     14  message-digest-chunk
    1515  message-digest-bv
    1616  message-digest-int
     
    2121  message-digest-primitive
    2222  message-digest-type
    23   message-digest-parameters
     23  message-digest-chunk
    2424  message-digest-bv
    2525  message-digest-int
  • release/4/message-digest/trunk/message-digest.setup

    r34302 r34373  
    55(verify-extension-name "message-digest")
    66
    7 (setup-shared+static-extension-module 'message-digest-primitive (extension-version "3.3.0")
     7(setup-shared+static-extension-module 'message-digest-primitive (extension-version "3.4.0")
    88  #:inline? #t
    99        #:types? #t
     
    1212    -no-procedure-checks-for-toplevel-bindings))
    1313
    14 (setup-shared+static-extension-module 'message-digest-type (extension-version "3.3.0")
     14(setup-shared+static-extension-module 'message-digest-type (extension-version "3.4.0")
    1515  #:inline? #t
    1616        #:types? #t
     
    1919    -no-procedure-checks-for-toplevel-bindings))
    2020
    21 (setup-shared+static-extension-module 'message-digest-parameters (extension-version "3.3.0")
     21(setup-shared+static-extension-module 'message-digest-chunk (extension-version "3.4.0")
    2222  #:inline? #t
    2323        #:types? #t
     
    2626    -no-procedure-checks-for-toplevel-bindings))
    2727
    28 (setup-shared+static-extension-module 'message-digest-support (extension-version "3.3.0")
     28(setup-shared+static-extension-module 'message-digest-parameters (extension-version "3.4.0")
    2929  #:inline? #t
    3030        #:types? #t
     
    3333    -no-procedure-checks-for-toplevel-bindings))
    3434
    35 (setup-shared+static-extension-module 'message-digest-bv (extension-version "3.3.0")
     35(setup-shared+static-extension-module 'message-digest-support (extension-version "3.4.0")
    3636  #:inline? #t
    3737        #:types? #t
     
    4040    -no-procedure-checks-for-toplevel-bindings))
    4141
    42 (setup-shared+static-extension-module 'message-digest-int (extension-version "3.3.0")
     42(setup-shared+static-extension-module 'message-digest-bv (extension-version "3.4.0")
    4343  #:inline? #t
    4444        #:types? #t
     
    4747    -no-procedure-checks-for-toplevel-bindings))
    4848
    49 (setup-shared+static-extension-module 'message-digest-srfi-4 (extension-version "3.3.0")
     49(setup-shared+static-extension-module 'message-digest-int (extension-version "3.4.0")
    5050  #:inline? #t
    5151        #:types? #t
     
    5454    -no-procedure-checks-for-toplevel-bindings))
    5555
    56 (setup-shared+static-extension-module 'message-digest-update-item (extension-version "3.3.0")
     56(setup-shared+static-extension-module 'message-digest-srfi-4 (extension-version "3.4.0")
    5757  #:inline? #t
    5858        #:types? #t
     
    6161    -no-procedure-checks-for-toplevel-bindings))
    6262
    63 (setup-shared+static-extension-module 'message-digest-item (extension-version "3.3.0")
     63(setup-shared+static-extension-module 'message-digest-update-item (extension-version "3.4.0")
    6464  #:inline? #t
    6565        #:types? #t
     
    6868    -no-procedure-checks-for-toplevel-bindings))
    6969
    70 (setup-shared+static-extension-module 'message-digest-port (extension-version "3.3.0")
     70(setup-shared+static-extension-module 'message-digest-item (extension-version "3.4.0")
    7171  #:inline? #t
    7272        #:types? #t
     
    7575    -no-procedure-checks-for-toplevel-bindings))
    7676
    77 (setup-shared+static-extension-module 'message-digest-basic (extension-version "3.3.0")
     77(setup-shared+static-extension-module 'message-digest-port (extension-version "3.4.0")
    7878  #:inline? #t
    7979        #:types? #t
     
    8282    -no-procedure-checks-for-toplevel-bindings))
    8383
    84 (setup-shared+static-extension-module 'message-digest (extension-version "3.3.0")
     84(setup-shared+static-extension-module 'message-digest-basic (extension-version "3.4.0")
    8585  #:inline? #t
    8686        #:types? #t
     
    8888    -optimize-level 3 -debug-level 1
    8989    -no-procedure-checks-for-toplevel-bindings))
     90
     91(setup-shared+static-extension-module 'message-digest (extension-version "3.4.0")
     92  #:inline? #t
     93        #:types? #t
     94  #:compile-options '(
     95    -optimize-level 3 -debug-level 1
     96    -no-procedure-checks-for-toplevel-bindings))
  • release/4/message-digest/trunk/tests/run.scm

    r34302 r34373  
    2222
    2323(define digest-length 5)
     24(define context-size 10)
    2425(define block-length 64)
    25 (define context-size 10)
    26 
    27 (define-constant block-length-default 4)
     26
     27(define-constant BLOCK-LENGTH-DEFAULT 4)
     28
     29(define short-test-filename "alpha.txt")
    2830
    2931;;
     
    3537
    3638;Tests defaults
    37 (test-group "Chunk Read"
     39(test-group "Chunk Read (port)"
    3840  (let ((siz (message-digest-chunk-size))
    39         (in (open-input-file "alpha.txt")))
    40     (let ((rdr ((message-digest-chunk-read-maker) in)))
     41        (in (open-input-file short-test-filename)))
     42    (let ((rdr ((message-digest-chunk-port-read-maker) in)))
    4143      (let ((res (rdr)))
    4244        (test-assert "First chunk type" (blob? res))
     
    5961    (test update (message-digest-primitive-update mdp))
    6062    (test final (message-digest-primitive-final mdp))
    61     (test block-length-default (message-digest-primitive-block-length mdp))
     63    (test BLOCK-LENGTH-DEFAULT (message-digest-primitive-block-length mdp))
    6264    (test-assert (symbol? (message-digest-primitive-name mdp))) )
    6365
     
    6567
    6668  (let ((mdp (make-message-digest-primitive context-size digest-length init update final 'foo)))
    67     (test block-length-default (message-digest-primitive-block-length mdp))
     69    (test BLOCK-LENGTH-DEFAULT (message-digest-primitive-block-length mdp))
    6870    (test 'foo (message-digest-primitive-name mdp)) )
    6971
     
    277279)
    278280
     281;
     282(test-group "Chunk Read (fileno)"
     283
     284  (define (init ctx)
     285    ;(printf "  Init Ctx: ~S~%" ctx)
     286    (assert (pointer? ctx)) )
     287
     288  (define (update ctx bytes count)
     289        ;(printf "Update Ctx: ~S Count: ~S Bytes: ~S~%" ctx count bytes)
     290    (assert (pointer? ctx))
     291    (assert (not (not bytes)))
     292    (assert (<= context-size count))
     293    (move-memory! bytes ctx (min context-size count)) )
     294
     295  (define (raw-update ctx bytes count)
     296        ;(printf "Raw-Update Ctx: ~S Count: ~S Bytes: ~S~%" ctx count bytes)
     297    (assert (pointer? ctx))
     298    (assert (not (not bytes)))
     299    (assert (<= context-size count))
     300    (move-memory! bytes ctx (min context-size count)) )
     301
     302  (define (final ctx result)
     303    ;(printf " Final Ctx: ~S Length: ~S Result: ~S~%" ctx digest-length result)
     304    (assert (pointer? ctx))
     305    (assert (not (not result)))
     306    (assert (<= 0 digest-length))
     307    (move-memory! ctx result digest-length) )
     308
     309  (let ((mdp (make-message-digest-primitive context-size digest-length init update final raw-update)))
     310    (test "6162636465" (message-digest-file mdp short-test-filename 'hex-string)) )
     311)
     312
    279313(test-end)
    280314
Note: See TracChangeset for help on using the changeset viewer.