Changeset 34300 in project


Ignore:
Timestamp:
08/20/17 21:13:55 (5 weeks ago)
Author:
kon
Message:

use parameters, add res typ param, mv chks into 1st use

Location:
release/4/message-digest
Files:
30 edited
1 copied

Legend:

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

    r26402 r34300  
    11;;;; message-digest-basic.scm
    22;;;; Kon Lovett, May '10
     3;;;; Kon Lovett, Aug '17
    34
    45;; Issues
     
    67(module message-digest-basic ()
    78
    8   (import scheme chicken)
     9(import scheme)
    910
    10         (reexport
    11     message-digest-primitive
    12     message-digest-type
    13     message-digest-parameters
    14     message-digest-bv
    15     message-digest-int)
     11(import chicken)
    1612
    17   (require-library
    18     message-digest-primitive
    19     message-digest-type
    20     message-digest-parameters
    21     message-digest-bv
    22     message-digest-int)
     13(reexport
     14  message-digest-primitive
     15  message-digest-type
     16  message-digest-parameters
     17  message-digest-bv
     18  message-digest-int)
     19(require-library
     20  message-digest-primitive
     21  message-digest-type
     22  message-digest-parameters
     23  message-digest-bv
     24  message-digest-int)
    2325
    2426) ;module message-digest-basic
  • release/4/message-digest/tags/3.2.0/message-digest-bv.scm

    r26402 r34300  
    33;;;; Kon Lovett, May '10 (message-digest.scm)
    44;;;; Kon Lovett, Apr '12
     5;;;; Kon Lovett, Aug '17
    56
    67;; Issues
     
    89(module message-digest-bv
    910
    10   (;export
    11     ;
    12     message-digest-update-blob
    13     message-digest-update-string
    14     message-digest-update-substring  ;DEPRECATED
    15     message-digest-blob
    16     message-digest-string)
     11(;export
     12  ;
     13  message-digest-update-blob
     14  message-digest-update-string
     15  message-digest-update-substring  ;DEPRECATED
     16  message-digest-blob
     17  message-digest-string)
    1718
    18   (import
    19     scheme
    20     chicken
    21     message-digest-primitive
    22     message-digest-type
    23     message-digest-support
    24     (only srfi-13 substring/shared)
    25     (only type-checks
    26       check-blob check-string))
     19(import scheme)
    2720
    28   (require-library
    29         srfi-13
    30     message-digest-primitive
    31     message-digest-type
    32     message-digest-support
    33     type-checks)
     21(import
     22  chicken
     23  (only srfi-13 substring/shared))
     24(require-library
     25  srfi-13)
     26
     27(import
     28  (only type-checks
     29    check-blob check-string))
     30(require-library
     31  type-checks)
     32
     33(require-extension
     34  message-digest-primitive
     35  message-digest-type
     36  message-digest-support)
    3437
    3538;;; Message Digest API
     
    4043
    4144(define (message-digest-update-blob md blb)
    42   (check-message-digest 'message-digest-update-blob md)
    43   (check-blob 'message-digest-update-blob blb)
    44   (*message-digest-update-blob md blb) )
     45  (*message-digest-update-blob
     46    (check-message-digest 'message-digest-update-blob md)
     47    (check-blob 'message-digest-update-blob blb)) )
    4548
    4649;;
    4750
    4851(define (message-digest-update-string md str)
    49   (check-message-digest 'message-digest-update-string md)
    50   (check-string 'message-digest-update-string str)
    51   (*message-digest-update-string md str) )
     52  (*message-digest-update-string
     53    (check-message-digest 'message-digest-update-string md)
     54    (check-string 'message-digest-update-string str)) )
    5255
    5356;;
     
    5558;DEPRECATED
    5659(define (message-digest-update-substring md str start end)
    57   (check-message-digest 'message-digest-update-substring md)
    58   (check-string 'message-digest-update-substring str)
    59   (*message-digest-update-string md (substring/shared str start end)) )
     60  (*message-digest-update-string
     61    (check-message-digest 'message-digest-update-substring md)
     62    (substring/shared (check-string 'message-digest-update-substring str) start end)) )
    6063
    6164;; Single Source API
    6265
    63 (define (message-digest-string mdp str #!optional (result-type 'hex))
     66(define (message-digest-string mdp str #!optional (result-type (message-digest-default-result-type)))
    6467  (let ((md (initialize-message-digest mdp)))
    6568    (message-digest-update-string md str)
    6669    (finalize-message-digest md result-type) ) )
    6770
    68 (define (message-digest-blob mdp blb #!optional (result-type 'hex))
     71(define (message-digest-blob mdp blb #!optional (result-type (message-digest-default-result-type)))
    6972  (let ((md (initialize-message-digest mdp)))
    7073    (message-digest-update-blob md blb)
  • release/4/message-digest/tags/3.2.0/message-digest-int.scm

    r27995 r34300  
    33;;;; Kon Lovett, May '10 (message-digest.scm)
    44;;;; Kon Lovett, Apr '12
     5;;;; Kon Lovett, Aug '17
    56
    67;; Issues
     
    89(module message-digest-int
    910
    10   (;export
    11     message-digest-update-char-u8
    12     message-digest-update-char
    13     message-digest-update-char-be
    14     message-digest-update-char-le
    15     message-digest-update-u8
    16     message-digest-update-u16
    17     message-digest-update-u16-be
    18     message-digest-update-u16-le
    19     message-digest-update-u32
    20     message-digest-update-u32-be
    21     message-digest-update-u32-le
    22     message-digest-update-u64
    23     message-digest-update-u64-be
    24     message-digest-update-u64-le)
     11(;export
     12  message-digest-update-char-u8
     13  message-digest-update-char
     14  message-digest-update-char-be
     15  message-digest-update-char-le
     16  message-digest-update-u8
     17  message-digest-update-u16
     18  message-digest-update-u16-be
     19  message-digest-update-u16-le
     20  message-digest-update-u32
     21  message-digest-update-u32-be
     22  message-digest-update-u32-le
     23  message-digest-update-u64
     24  message-digest-update-u64-be
     25  message-digest-update-u64-le)
    2526
    26   (import
    27     scheme
    28     chicken
    29     message-digest-type
    30     message-digest-support
    31     blob-set-int
    32     (only type-checks
    33       check-integer check-char)
    34     (only type-errors
    35       error-argument-type))
     27(import scheme)
    3628
    37   (require-library
    38     message-digest-type
    39     message-digest-support
    40     blob-set-int
    41     type-checks
    42     type-errors)
     29(import chicken
     30  (only type-checks
     31    check-integer check-char)
     32  (only type-errors
     33    error-argument-type))
     34(require-library
     35  type-checks
     36  type-errors)
     37
     38(require-extension
     39  message-digest-type
     40  message-digest-support
     41  blob-set-int)
    4342
    4443;;; Support
     
    5554
    5655(define (*message-digest-update-uint loc md n size setter)
    57   (check-message-digest loc md)
    58   (check-integer loc n)
    59   (let ((blb (setup-message-digest-buffer! md size)))
    60         (setter blb n 0)
     56  (let ((blb (setup-message-digest-buffer! (check-message-digest loc md) size)))
     57        (setter blb (check-integer loc n) 0)
    6158        (*message-digest-update-blob md blb size) ) )
    6259
     
    6663
    6764(define (message-digest-update-char-u8 md ch)
    68   (check-char 'message-digest-update-char-u8 ch)
    69         (*message-digest-update-uint 'message-digest-update-char-u8 md (char->integer ch) 1 *blob-set-u8!) )
     65        (*message-digest-update-uint
     66          'message-digest-update-char-u8
     67          md
     68          (char->integer (check-char 'message-digest-update-char-u8 ch))
     69          1
     70          *blob-set-u8!) )
    7071
    7172(define (message-digest-update-char-be md ch)
    72   (check-char 'message-digest-update-char ch)
    73         (*message-digest-update-uint 'message-digest-update-char-be md (char->integer ch) 4 *blob-set-u32-be!) )
     73        (*message-digest-update-uint
     74          'message-digest-update-char-be
     75          md
     76          (char->integer (check-char 'message-digest-update-char ch))
     77          4
     78          *blob-set-u32-be!) )
    7479
    7580(define (message-digest-update-char-le md ch)
    76   (check-char 'message-digest-update-char ch)
    77         (*message-digest-update-uint 'message-digest-update-char-le md (char->integer ch) 4 *blob-set-u32-le!) )
     81        (*message-digest-update-uint
     82          'message-digest-update-char-le
     83          md
     84          (char->integer (check-char 'message-digest-update-char ch))
     85          4
     86          *blob-set-u32-le!) )
    7887
    7988;; Unsigned Integer 8, 16, 32, & 64 bits
  • release/4/message-digest/tags/3.2.0/message-digest-item.scm

    r26402 r34300  
    33;;;; Kon Lovett, may '10 (message-digest.scm)
    44;;;; Kon Lovett, Apr '12
     5;;;; Kon Lovett, Aug '17
    56
    67;; Issues
     
    89(module message-digest-item
    910
    10   (;export
    11     message-digest-object
    12     message-digest-file
    13     message-digest-port)
     11(;export
     12  message-digest-object
     13  message-digest-file
     14  message-digest-port)
    1415
    15   (import
    16     scheme
    17     chicken
    18     message-digest-type
    19     message-digest-update-item)
     16(import scheme)
    2017
    21   (require-library
    22     message-digest-type
    23     message-digest-update-item)
     18(import chicken)
     19
     20(require-extension
     21  message-digest-type
     22  message-digest-update-item)
    2423
    2524;;; Single Source API
    2625
    27 (define (message-digest-object mdp obj #!optional (result-type 'hex))
     26(define (message-digest-object mdp obj #!optional (result-type (message-digest-default-result-type)))
    2827  (let ((md (initialize-message-digest mdp)))
    2928    (message-digest-update-object md obj)
    3029    (finalize-message-digest md result-type) ) )
    3130
    32 (define (message-digest-file mdp flnm #!optional (result-type 'hex))
     31(define (message-digest-file mdp flnm #!optional (result-type (message-digest-default-result-type)))
    3332  (let ((md (initialize-message-digest mdp)))
    3433    (message-digest-update-file md flnm)
    3534    (finalize-message-digest md result-type) ) )
    3635
    37 (define (message-digest-port mdp port #!optional (result-type 'hex))
     36(define (message-digest-port mdp port #!optional (result-type (message-digest-default-result-type)))
    3837  (let ((md (initialize-message-digest mdp)))
    3938    (message-digest-update-port md port)
  • release/4/message-digest/tags/3.2.0/message-digest-old.scm

    r26378 r34300  
    33;;;; Kon Lovett, May '10 (message-digest.scm)
    44;;;; Kon Lovett, Apr '12
     5;;;; Kon Lovett, Aug '17
    56
    67;; Issues
     8;;
     9;; - DEPRECATED
    710
    811(module message-digest-old
    912
    10   (;export
    11     string->hex
    12     byte-string->hexadecimal
    13     make-binary-message-digest
    14     make-message-digest
    15     message-digest-primitive-apply)
     13(;export
     14  string->hex
     15  byte-string->hexadecimal
     16  make-binary-message-digest
     17  make-message-digest
     18  message-digest-primitive-apply)
    1619
    17         (import
    18     scheme
    19     chicken
    20     message-digest-basic
    21     message-digest-single
    22     (only string-hexadecimal string->hex))
     20(import scheme)
    2321
    24   (require-library
    25     message-digest-basic
    26     message-digest-single
    27     string-hexadecimal)
     22(import chicken)
     23  (only string-hexadecimal string->hex))
     24(require-library
     25  string-hexadecimal)
     26
     27(require-extension
     28  message-digest-basic
     29  message-digest-single)
    2830
    2931;;; Byte-string Utilities
     
    3537;;
    3638
    37 (define (message-digest-primitive-apply mdp src . args) ;DEPRECATED
     39;DEPRECATED
     40(define (message-digest-primitive-apply mdp src . args)
    3841  (message-digest-object mdp src 'string) )
    3942
    4043;;
    4144
     45;DEPRECATED
    4246(define (make-binary-message-digest src ctx-info digest-len init update final
    43                                     #!optional (name 'make-binary-message-digest)) ;DEPRECATED
     47                                    #!optional (name 'make-binary-message-digest))
    4448  (message-digest-object
    4549    (make-message-digest-primitive ctx-info digest-len init update final name)
     
    4953;;
    5054
     55;DEPRECATED
    5156(define (make-message-digest src ctx-info digest-len init update final
    52                              #!optional (name 'make-message-digest)) ;DEPRECATED
     57                             #!optional (name 'make-message-digest))
    5358  (message-digest-object
    5459    (make-message-digest-primitive ctx-info digest-len init update final name)
  • release/4/message-digest/tags/3.2.0/message-digest-parameters.scm

    r26402 r34300  
    1313(module message-digest-parameters
    1414
    15   (;export
    16     ; Parameters
    17     message-digest-chunk-size
    18     message-digest-chunk-read-maker
    19     message-digest-chunk-converter)
     15(;export
     16  ; Parameters
     17  message-digest-chunk-size
     18  message-digest-chunk-read-maker
     19  message-digest-chunk-converter)
    2020
    21   (import
    22     scheme
    23     chicken
    24     (only srfi-4
    25         u8vector->blob/shared subu8vector
    26         read-u8vector! make-u8vector)
    27     variable-item
    28     (only type-checks
    29                         check-procedure check-positive-fixnum )
    30     (only type-errors
    31       error-argument-type))
     21(import scheme)
    3222
    33   (require-library
    34         srfi-4
    35     variable-item
    36     type-errors
    37     type-checks)
     23(import
     24  chicken
     25  (only srfi-4
     26    u8vector->blob/shared subu8vector
     27    read-u8vector! make-u8vector))
     28(require-library
     29  srfi-4)
    3830
    3931;;; Update Phase Helpers
     32
     33;;
     34
     35(define (positive-fixnum? obj)
     36  (and (fixnum? obj) (positive? obj)) )
    4037
    4138;;
     
    4542    (lambda ()
    4643      (let ((len (read-u8vector! size u8buf in)))
    47         (and (positive? len)
    48              (let ((u8buf (if (fx= len size) u8buf (subu8vector u8buf 0 len))))
    49                (u8vector->blob/shared u8buf) ) ) ) ) ) )
     44        (and
     45          (positive? len)
     46          (let ((u8buf (if (fx= len size) u8buf (subu8vector u8buf 0 len))))
     47            (u8vector->blob/shared u8buf) ) ) ) ) ) )
    5048
    5149;;
     
    5755;;
    5856
    59 (define-checked-variable message-digest-chunk-size
    60   DEFAULT-CHUNK-SIZE
    61   positive-fixnum)
     57(define message-digest-chunk-size (make-parameter DEFAULT-CHUNK-SIZE
     58  (lambda (x)
     59    (cond
     60      ((positive-fixnum? x)   x )
     61      ((not x)                DEFAULT-CHUNK-SIZE )
     62      (else
     63        (warning 'message-digest-chunk-size "invalid positive-fixnum" x)
     64        (message-digest-chunk-size) ) ) ) ) )
    6265
    6366;;
    6467
    65 (define-checked-variable message-digest-chunk-read-maker
    66   default-chunk-read-maker
    67   procedure)
     68(define message-digest-chunk-read-maker (make-parameter default-chunk-read-maker
     69  (lambda (x)
     70    (cond
     71      ((procedure? x)   x )
     72      ((not x)          default-chunk-read-maker )
     73      (else
     74        (warning 'message-digest-chunk-read-maker "invalid procedure" x)
     75        (message-digest-chunk-read-maker) ) ) ) ) )
    6876
    6977;;
    7078
    71 (define-variable message-digest-chunk-converter #f
    72   (lambda (obj)
    73     (if (or (not obj) (procedure? obj)) obj
    74       (error-argument-type 'message-digest-chunk-converter obj "#f or procedure"))))
     79(define message-digest-chunk-converter (make-parameter #f
     80  (lambda (x)
     81    (if (or (not x) (procedure? x))
     82      x
     83      (begin
     84        (warning 'message-digest-chunk-converter "invalid procedure or #f" x)
     85        (message-digest-chunk-converter) ) ) ) ) )
    7586
    7687) ;module message-digest-parameters
  • release/4/message-digest/tags/3.2.0/message-digest-port.scm

    r31014 r34300  
    11;;;; message-digest-port.scm
    22;;;; Kon Lovett, May '10
     3;;;; Kon Lovett, Aug '17
    34
    45;; Issues
     
    89(module message-digest-port
    910
    10         (;export
    11           digest-output-port? check-digest-output-port error-digest-output-port
    12           digest-output-port-name
    13     open-output-digest
    14     get-output-digest
    15     call-with-output-digest
    16     with-output-to-digest)
     11(;export
     12  digest-output-port? check-digest-output-port error-digest-output-port
     13  digest-output-port-name
     14  open-output-digest
     15  get-output-digest
     16  call-with-output-digest
     17  with-output-to-digest)
    1718
    18   (import
    19     scheme
    20     chicken
    21     (only data-structures ->string)
    22     (only ports make-output-port with-input-from-port)
    23     (only srfi-13 string-suffix-length-ci)
    24     (only type-checks define-check+error-type check-output-port)
    25     (only type-errors error-argument-type make-error-type-message signal-type-error)
    26     message-digest-primitive
    27     message-digest-type
    28     message-digest-bv)
     19(import scheme)
    2920
    30   (require-library
    31         data-structures
    32         ports
    33         srfi-13
    34         type-checks
    35         type-errors
    36     message-digest-primitive
    37     message-digest-type
    38     message-digest-bv)
     21(import
     22  chicken
     23  (only data-structures ->string)
     24  (only ports make-output-port with-input-from-port)
     25  (only srfi-13 string-suffix-length-ci))
     26(require-library
     27  data-structures
     28  ports
     29  srfi-13)
     30
     31(import
     32  (only type-checks define-check+error-type check-output-port)
     33  (only type-errors error-argument-type make-error-type-message signal-type-error))
     34(require-library
     35  type-checks
     36  type-errors)
     37
     38(require-extension
     39  message-digest-primitive
     40  message-digest-type
     41  message-digest-bv)
    3942
    4043;;; Message Digest Output Port API
     
    5659;
    5760(define (check-open-digest-output-port loc obj #!optional argnam)
    58   (check-open-port loc (check-output-port loc obj argnam) argnam)
    59   (unless (eq? 'digest (%port-type obj))
    60     (signal-type-error loc (make-error-type-message 'digest-output-port) obj argnam) )
     61  (let ((pt (%port-type (check-open-port loc (check-output-port loc obj argnam) argnam))))
     62    (unless (eq? 'digest pt)
     63      (signal-type-error loc (make-error-type-message 'digest-output-port) obj argnam) ) )
    6164  obj )
    6265
    6366; Synthesize a port-name from a primitive-name
    6467(define (make-digest-port-name mdp)
    65   (let ((nam (->string (or (message-digest-primitive-name mdp) 'digest))))
    66     (let ((remlen (string-suffix-length-ci nam "-primitive")))
    67       (string-append
    68         "("
     68  (let* ((nam (->string (or (message-digest-primitive-name mdp) 'digest)) )
     69         (remlen (string-suffix-length-ci nam "-primitive") ) )
     70    (string-append
     71      "("
    6972        (if (positive? remlen)
    70             (substring nam 0 (fx- (string-length nam) remlen))
    71             nam )
    72         ")") ) ) )
     73          (substring nam 0 (fx- (string-length nam) remlen))
     74          nam )
     75      ")") ) )
    7376
    7477;; Returns a digest-output-port for the MDP
    7578
    7679(define (open-output-digest mdp)
    77   (let* ((md (initialize-message-digest mdp))
     80  (let* ((md (initialize-message-digest mdp) )
    7881         (writer
    7982          (lambda (obj)
    80             ; It will only ever be a string for now.
    81             (if (string? obj) (message-digest-update-string md obj)
    82               (message-digest-update-blob md obj))))
    83          (port (make-output-port writer void)) ) ;use default close behavior
     83            ;it will only ever be a string for now
     84            (if (string? obj)
     85              (message-digest-update-string md obj)
     86              (message-digest-update-blob md obj))) )
     87         (port (make-output-port writer void) ) ) ;use default close behavior
    8488    (##sys#set-port-data! port md)
    8589    (%port-type-set! port 'digest)
     
    8892
    8993(define (digest-output-port? obj)
    90   (and (output-port? obj)
    91        (eq? 'digest (%port-type obj)) ) )
     94  (and
     95    (output-port? obj)
     96    (eq? 'digest (%port-type obj)) ) )
    9297
    9398(define-check+error-type digest-output-port)
    9499
    95100(define (digest-output-port-name p)
    96   (check-digest-output-port 'digest-output-port-name p)
    97   (%port-name p) )
     101  (%port-name (check-digest-output-port 'digest-output-port-name p)) )
    98102
    99103;; Finalizes the digest-output-port and returns the result in the form requested
    100104
    101105(define (*close-output-digest loc digest-port result-type)
    102   (check-open-digest-output-port loc digest-port 'digest-port)
    103   (let ((res (finalize-message-digest (##sys#port-data digest-port) result-type)))
     106  (let ((res
     107          (finalize-message-digest
     108            (##sys#port-data (check-open-digest-output-port loc digest-port 'digest-port))
     109            result-type)))
    104110    (close-output-port digest-port)
    105111    res ) )
    106112
    107 (define (get-output-digest digest-port #!optional (result-type 'hex))
     113(define (get-output-digest digest-port #!optional (result-type (message-digest-default-result-type)))
    108114  (*close-output-digest 'get-output-digest digest-port result-type) )
    109115
     
    113119;; Returns the accumulated output string | blob | u8vector | hexstring
    114120
    115 (define (call-with-output-digest mdp proc #!optional (result-type 'hex))
     121(define (call-with-output-digest mdp proc #!optional (result-type (message-digest-default-result-type)))
    116122  (let ((port (open-output-digest mdp)))
    117123    (proc port)
     
    122128;; Returns the accumulated output string | blob | u8vector | hexstring
    123129
    124 (define (with-output-to-digest mdp thunk #!optional (result-type 'hex))
     130(define (with-output-to-digest mdp thunk #!optional (result-type (message-digest-default-result-type)))
    125131  (call-with-output-digest mdp (cut with-input-from-port <> thunk) result-type) )
    126132
  • release/4/message-digest/tags/3.2.0/message-digest-primitive.scm

    r31014 r34300  
    33;;;; Kon Lovett, May '10 (message-digest.scm)
    44;;;; Kon Lovett, Apr '12
     5;;;; Kon Lovett, Aug '17
    56
    67;; Issues
     
    89(module message-digest-primitive
    910
    10   (;export
    11     ; Algorithm API
    12     make-message-digest-primitive
    13     message-digest-primitive? check-message-digest-primitive error-message-digest-primitive
    14     message-digest-primitive-name
    15     message-digest-primitive-block-length
    16     message-digest-primitive-context-info
    17     message-digest-primitive-digest-length
    18     message-digest-primitive-init
    19     message-digest-primitive-update
    20     message-digest-primitive-final)
     11(;export
     12  ; Algorithm API
     13  make-message-digest-primitive
     14  message-digest-primitive? check-message-digest-primitive error-message-digest-primitive
     15  message-digest-primitive-name
     16  message-digest-primitive-block-length
     17  message-digest-primitive-context-info
     18  message-digest-primitive-digest-length
     19  message-digest-primitive-init
     20  message-digest-primitive-update
     21  message-digest-primitive-final)
    2122
    22   (import
    23     scheme
    24     chicken
    25     (only type-checks
    26       define-check+error-type
    27       check-positive-fixnum
    28       check-procedure)
    29     (only type-errors
    30       error-argument-type))
     23(import scheme)
    3124
    32   (require-library
    33     type-checks
    34     type-errors)
     25(import chicken)
     26
     27(import
     28  (only type-checks
     29    define-check+error-type
     30    check-positive-fixnum
     31    check-procedure)
     32  (only type-errors
     33    error-argument-type))
     34(require-library
     35  type-checks
     36  type-errors)
    3537
    3638;;; Support
  • release/4/message-digest/tags/3.2.0/message-digest-srfi-4.scm

    r33166 r34300  
    33;;;; Kon Lovett, May '10 (message-digest.scm)
    44;;;; Kon Lovett, Apr '12
     5;;;; Kon Lovett, Aug '17
    56
    67;; Issues
     
    1011(module message-digest-srfi-4
    1112
    12   (;export
    13     message-digest-update-bytevector                    ;DEPRECATED
    14     message-digest-update-u8vector
    15     message-digest-update-subu8vector                   ;DEPRECATED
    16     message-digest-update-packed-vector         ;DEPRECATED
    17     message-digest-u8vector)
     13(;export
     14  message-digest-update-bytevector                      ;DEPRECATED
     15  message-digest-update-u8vector
     16  message-digest-update-subu8vector                     ;DEPRECATED
     17  message-digest-update-packed-vector           ;DEPRECATED
     18  message-digest-u8vector)
    1819
    19   (import
    20     scheme
    21     chicken
    22     data-structures
    23     srfi-4
    24     (only lolevel number-of-bytes)
    25     message-digest-primitive
    26     message-digest-type
    27     message-digest-support
    28     message-digest-bv
    29     (only srfi-4-checks check-u8vector)
    30     (only type-errors error-argument-type))
     20(import scheme)
    3121
    32   (require-library
    33     data-structures
    34     srfi-4
    35     lolevel
    36     message-digest-primitive
    37     message-digest-type
    38     message-digest-support
    39     message-digest-bv
    40     type-errors)
     22(import
     23  chicken
     24  data-structures
     25  srfi-4
     26  (only lolevel number-of-bytes))
     27(require-library
     28  data-structures
     29  srfi-4
     30  lolevel)
     31
     32(import
     33  (only srfi-4-checks check-u8vector)
     34  (only type-errors error-argument-type))
     35(require-library
     36  type-errors)
     37
     38(require-extension
     39  message-digest-primitive
     40  message-digest-type
     41  message-digest-support
     42  message-digest-bv)
    4143
    4244;;; Support
     
    4648(define (get-bytevector-object loc obj)
    4749        (cond
    48                 ((string? obj)                                                                          (string->blob obj) )
    49                 ((blob? obj)                                                                                    obj )
    50                 ((packed-vector->blob/shared obj) )
     50                ((string? obj)                                                                            (string->blob obj) )
     51                ((blob? obj)                                                                                      obj )
     52                ((packed-vector->blob/shared obj)   )
    5153                (else
    5254        (error-argument-type loc obj "string, blob, or SRFI 4 vector" obj) ) ) )
     
    7072(define (message-digest-update-packed-vector md pkdvec)
    7173  (let ((blb (packed-vector->blob/shared pkdvec)))
    72     (if blb (message-digest-update-blob md blb)
    73         (error-argument-type 'message-digest-update-packed-vector pkdvec "SRFI 4 vector") ) ) )
     74    (if blb
     75      (message-digest-update-blob md blb)
     76      (error-argument-type 'message-digest-update-packed-vector pkdvec "SRFI 4 vector") ) ) )
    7477
    7578;;
     
    8790;;; Single Source API
    8891
    89 (define (message-digest-u8vector mdp u8vec #!optional (result-type 'hex))
     92(define (message-digest-u8vector mdp u8vec #!optional (result-type (message-digest-default-result-type)))
    9093  (let ((md (initialize-message-digest mdp)))
    9194    (message-digest-update-u8vector md u8vec)
  • release/4/message-digest/tags/3.2.0/message-digest-support.scm

    r27988 r34300  
    33;;;; Kon Lovett, May '10 (message-digest.scm)
    44;;;; Kon Lovett, Apr '12
     5;;;; Kon Lovett, Aug '17
    56
    67;; Issues
     
    1314(module message-digest-support
    1415
    15   (;export
    16         ; Support
    17         packed-vector->blob/shared
    18         *message-digest-update-blob
    19         *message-digest-update-string)
     16(;export
     17  ; Support
     18  packed-vector->blob/shared
     19  *message-digest-update-blob
     20  *message-digest-update-string)
    2021
    21   (import
    22     scheme
    23     chicken
    24     (only lolevel number-of-bytes)
    25     (only srfi-4
    26                         s8vector?
    27                         u8vector?
    28                         s16vector?
    29                         u16vector?
    30                         s32vector?
    31                         u32vector?
    32                         #;u64vector?
    33                         #;u64vector?
    34                         f32vector?
    35                         f64vector?
    36                         u8vector->blob/shared
    37                         s8vector->blob/shared
    38                         s16vector->blob/shared
    39                         u16vector->blob/shared
    40                         s32vector->blob/shared
    41                         u32vector->blob/shared
    42                         #;s64vector->blob/shared
    43                         #;u64vector->blob/shared
    44                         f32vector->blob/shared
    45                         f64vector->blob/shared)
    46     message-digest-primitive
    47                 message-digest-type)
     22(import scheme)
    4823
     24(import
     25  chicken
     26  (only lolevel number-of-bytes)
     27  (only srfi-4
     28    s8vector?
     29    u8vector?
     30    s16vector?
     31    u16vector?
     32    s32vector?
     33    u32vector?
     34    #;u64vector?
     35    #;u64vector?
     36    f32vector?
     37    f64vector?
     38    u8vector->blob/shared
     39    s8vector->blob/shared
     40    s16vector->blob/shared
     41    u16vector->blob/shared
     42    s32vector->blob/shared
     43    u32vector->blob/shared
     44    #;s64vector->blob/shared
     45    #;u64vector->blob/shared
     46    f32vector->blob/shared
     47    f64vector->blob/shared))
     48(require-library
     49  lolevel
     50  srfi-4)
    4951
    50   (require-library
    51     srfi-4
    52     message-digest-primitive
    53     message-digest-type)
     52(require-extension
     53  message-digest-primitive
     54  message-digest-type)
    5455
    5556;;; Support
     
    7576
    7677(define (*message-digest-update-blob md blb #!optional (siz (blob-size blb)))
    77   (let ((mdp (message-digest-algorithm md))
    78         (ctx (message-digest-context md)) )
    79     ((message-digest-primitive-update mdp) ctx blb siz) ) )
     78  ((message-digest-algorithm-update md)
     79    (message-digest-context md)
     80    blb
     81    siz) )
    8082
    8183(define (*message-digest-update-string md str)
    8284        (*message-digest-update-blob md (string->blob str)) )
    8385
     86(define (message-digest-algorithm-update md)
     87  (message-digest-primitive-update (message-digest-algorithm md)) )
     88
    8489) ;module message-digest-support
  • release/4/message-digest/tags/3.2.0/message-digest-type.scm

    r27988 r34300  
    33;;;; Kon Lovett, May '10 (message-digest.scm)
    44;;;; Kon Lovett, Apr '12
     5;;;; Kon Lovett, Aug '17
    56
    67;; Issues
     
    1112(module message-digest-type
    1213
    13   (;export
    14     ; MD API
    15     message-digest? check-message-digest error-message-digest
    16     message-digest-algorithm message-digest-context
    17     initialize-message-digest
    18     finalize-message-digest
    19     setup-message-digest-buffer!)
     14(;export
     15  ; MD API
     16  message-digest-default-result-type
     17  message-digest? check-message-digest error-message-digest
     18  message-digest-algorithm message-digest-context
     19  initialize-message-digest
     20  finalize-message-digest
     21  setup-message-digest-buffer!)
    2022
    21   (import
    22     scheme
    23     chicken
    24     (only lolevel allocate free number-of-bytes)
    25     (only srfi-4 blob->u8vector/shared)
    26     message-digest-primitive
    27     (only blob-hexadecimal blob->hex)
    28     (only string-hexadecimal string->hex)
    29     (only type-checks
    30       define-check+error-type)
    31     (only type-errors
    32       error-argument-type))
     23(import scheme)
    3324
    34   (require-library
    35     lolevel
    36     srfi-4
    37     message-digest-primitive
    38     blob-hexadecimal
    39     string-hexadecimal
    40     type-checks
    41     type-errors)
     25(import
     26  chicken
     27  (only lolevel allocate free number-of-bytes)
     28  (only srfi-4 blob->u8vector/shared))
     29(require-library
     30  lolevel
     31  srfi-4)
     32
     33(import
     34  (only blob-hexadecimal blob->hex)
     35  (only string-hexadecimal string->hex)
     36  (only type-checks
     37    define-check+error-type)
     38  (only type-errors
     39    error-argument-type))
     40(require-library
     41  blob-hexadecimal
     42  string-hexadecimal
     43  type-checks
     44  type-errors)
     45
     46(require-extension
     47  message-digest-primitive)
    4248
    4349;;; Support
    4450
    4551(define-constant MINIMUM-BUFFER-SIZE 8)
     52
     53(define-constant DEFAULT-RESULT-TYPE 'hex-string)
    4654
    4755(define (error-result-form loc obj)
     
    5664      (if (fx= len (blob-size res)) res
    5765        (string->blob (substring (blob->string res) 0 len)) ) )
    58     ((string byte-string)
     66    ((byte-string string)
    5967      (let ((str (blob->string res)))
    6068        (if (fx= len (string-length str)) str
    6169          (substring str 0 len) ) ) )
    62     ((hexstring hex)
     70    ((hex-string hex hexstring)
    6371      (blob->hex res 0 len) )
    6472    ((u8vector)
     
    7280;assumes blob 'res' is of result size
    7381(define (get-result-form loc res rt)
    74   (case rt
    75     ((blob)                                                                             res )
    76     ((string byte-string)                       (blob->string res) )
    77     ((hexstring hex)            (blob->hex res) )
    78     ((u8vector)                 (blob->u8vector/shared res) )
     82  (case (canonical-result-name rt)
     83    ((blob)           res )
     84    ((byte-string)    (blob->string res) )
     85    ((hex-string)     (blob->hex res) )
     86    ((u8vector)       (blob->u8vector/shared res) )
    7987    (else
    8088      (error-result-form loc rt) ) ) )
    8189
     90(define (canonical-result-name x)
     91  (case x
     92    ((blob)                       'blob )
     93    ((byte-string string)         'byte-string )
     94    ((hex-string hex hexstring)   'hex-string )
     95    ((u8vector)                   'u8vector )
     96    (else
     97      #f ) ) )
    8298
    8399;;; Message Digest API
     100
     101;;
     102
     103(define message-digest-default-result-type (make-parameter DEFAULT-RESULT-TYPE
     104  (lambda (x)
     105    (or
     106      (if x (canonical-result-name x) DEFAULT-RESULT-TYPE)
     107      (begin
     108        (warning 'message-digest-default-result-type "invalid result-form" x)
     109        (message-digest-default-result-type) ) ) ) ) )
    84110
    85111;;
     
    98124(define (get-message-digest-primitive-context mdp)
    99125  (let ((ctx-info (message-digest-primitive-context-info mdp)))
    100     (if (procedure? ctx-info) (ctx-info)
     126    (if (procedure? ctx-info)
     127      (ctx-info)
    101128      (set-finalizer! (allocate ctx-info) free) ) ) )
    102129
     
    104131
    105132(define (initialize-message-digest mdp)
    106   (check-message-digest-primitive 'initialize-message-digest mdp)
    107   (let ((ctx (get-message-digest-primitive-context mdp)))
     133  (let ((ctx
     134          (get-message-digest-primitive-context
     135            (check-message-digest-primitive 'initialize-message-digest mdp))))
    108136    ((message-digest-primitive-init mdp) ctx)
    109137    (*make-message-digest mdp ctx #f) ) )
     
    111139;;
    112140
    113 (define (finalize-message-digest md #!optional (result-type 'hex))
    114   (check-message-digest 'finalize-message-digest md)
    115   (let ((mdp (message-digest-algorithm md))
    116         (ctx (message-digest-context md)) )
    117     (let ((res (make-blob (message-digest-primitive-digest-length mdp))))
    118       ((message-digest-primitive-final mdp) ctx res)
    119       (get-result-form 'finalize-message-digest res result-type) ) ) )
     141(define (finalize-message-digest md #!optional (result-type (message-digest-default-result-type)))
     142  (let* ((mdp
     143          (message-digest-algorithm
     144            (check-message-digest 'finalize-message-digest md)))
     145         (res
     146          (make-blob (message-digest-primitive-digest-length mdp))) )
     147      ((message-digest-primitive-final mdp) (message-digest-context md) res)  ;side-effects res
     148      (get-result-form 'finalize-message-digest res result-type) ) )
    120149
    121150;;
     
    124153  (let ((buf (message-digest-buffer md))
    125154        (sz (fxmax sz MINIMUM-BUFFER-SIZE)) )
    126     (if (and buf (fx<= sz (number-of-bytes buf))) buf
    127       (let ((buf (make-blob sz)))
    128         (message-digest-buffer-set! md buf)
    129         buf ) ) ) )
     155    ;enough space? then reuse, otherwise new buffer
     156    (if (and buf (fx<= sz (number-of-bytes buf)))
     157      buf
     158      (new-message-digest-buffer! md sz) ) ) )
     159
     160(define (new-message-digest-buffer! md sz)
     161  (let ((buf (make-blob sz)))
     162    (message-digest-buffer-set! md buf)
     163    buf ) )
    130164
    131165) ;module message-digest-type
  • release/4/message-digest/tags/3.2.0/message-digest-update-item.scm

    r26402 r34300  
    33;;;; Kon Lovett, May '10 (message-digest.scm)
    44;;;; Kon Lovett, Apr '12
     5;;;; Kon Lovett, Aug '17
    56
    67;; Issues
     
    89(module message-digest-update-item
    910
    10   (;export
    11     message-digest-update-object
    12     message-digest-update-procedure
    13     message-digest-update-port
    14     message-digest-update-file)
     11(;export
     12  message-digest-update-object
     13  message-digest-update-procedure
     14  message-digest-update-port
     15  message-digest-update-file)
    1516
    16   (import
    17     scheme
    18     chicken
    19     (only lolevel number-of-bytes)
    20     (only miscmacros while*)
    21     message-digest-primitive
    22     message-digest-type
    23     message-digest-parameters
    24     message-digest-support
    25     type-checks
    26     type-errors)
     17(import scheme)
    2718
    28   (require-library
    29         lolevel
    30     miscmacros
    31     message-digest-primitive
    32     message-digest-type
    33     message-digest-parameters
    34     message-digest-support
    35         type-checks)
     19(import
     20  chicken
     21  (only lolevel number-of-bytes))
     22(require-library
     23  lolevel)
     24
     25(import
     26  (only miscmacros while*))
     27(require-library
     28  miscmacros)
     29
     30(require-extension
     31  message-digest-primitive
     32  message-digest-type
     33  message-digest-parameters
     34  message-digest-support
     35  type-checks
     36  type-errors)
    3637
    3738;;; Support
     
    4041
    4142(define (chunk-convert obj)
    42   (and-let* ((cnv (message-digest-chunk-converter))) (cnv obj)) )
     43  (and-let* ((cnv (message-digest-chunk-converter)))
     44    (cnv obj) ) )
    4345
    4446(define (get-chunk-reader in)
     
    5052;;
    5153
    52 (define (object->bytevector-like obj)
    53   (or (packed-vector->blob/shared obj)
    54       (chunk-convert obj)) )
     54(define (do-object-update loc md src)
     55  (cond
     56    ((input-port? src)    (do-port-update loc md src) )
     57    ((procedure? src)     (do-procedure-update loc md src) )
     58    (else                 (do-bytes-update loc md src) ) ) )
     59
     60(define (do-port-update loc md in)
     61  (do-procedure-update loc md (get-chunk-reader in)) )
     62
     63(define (do-bytes-update loc md src)
     64  (do-byte-source-update
     65    loc
     66    (message-digest-context md)
     67    src
     68    (get-update md)) )
    5569
    5670(define (do-byte-source-update loc ctx src updt)
     
    7387    (while* (proc) (do-byte-source-update loc ctx it updt) ) ) )
    7488
    75 (define (do-port-update loc md in)
    76   (do-procedure-update loc md (get-chunk-reader in)) )
    77 
    78 (define (do-bytes-update loc md src)
    79   (let ((updt (get-update md))
    80         (ctx (message-digest-context md)) )
    81     (do-byte-source-update loc ctx src updt) ) )
    82 
    83 (define (do-object-update loc md src)
    84   (cond
    85     ((input-port? src)    (do-port-update loc md src) )
    86     ((procedure? src)     (do-procedure-update loc md src) )
    87     (else                 (do-bytes-update loc md src) ) ) )
     89(define (object->bytevector-like obj)
     90  (or
     91    (packed-vector->blob/shared obj)
     92    (chunk-convert obj)) )
    8893
    8994;;; Update Operation
     
    9297
    9398(define (message-digest-update-object md obj)
    94   (check-message-digest 'message-digest-update-object md)
    95   (do-object-update 'message-digest-update-object md obj) )
     99  (do-object-update
     100    'message-digest-update-object
     101    (check-message-digest 'message-digest-update-object md)
     102    obj) )
    96103
    97104;;
    98105
    99106(define (message-digest-update-procedure md proc)
    100   (check-message-digest 'message-digest-update-procedure md)
    101   (check-procedure 'message-digest-update-procedure proc)
    102   (do-procedure-update 'message-digest-update-procedure md proc) )
     107  (do-procedure-update
     108    'message-digest-update-procedure
     109    (check-message-digest 'message-digest-update-procedure md)
     110    (check-procedure 'message-digest-update-procedure proc)) )
    103111
    104112;;
    105113
    106114(define (message-digest-update-port md in)
    107   (check-message-digest 'message-digest-update-port md)
    108   (check-input-port 'message-digest-update-port in)
    109   (do-port-update 'message-digest-update-port md in) )
     115  (do-port-update
     116    'message-digest-update-port
     117    (check-message-digest 'message-digest-update-port md)
     118    (check-input-port 'message-digest-update-port in)) )
    110119
    111120;;
    112121
    113122(define (message-digest-update-file md flnm)
    114   (check-message-digest 'message-digest-update-file md)
    115   (check-string 'message-digest-update-file flnm)
    116   (let ((in (open-input-file flnm)))
    117     (handle-exceptions exn
    118         (begin (close-input-port in) (abort exn))
    119       (do-port-update 'message-digest-update-file md in) )
     123  (let ((in (open-input-file (check-string 'message-digest-update-file flnm))))
     124    (handle-exceptions
     125      ;as
     126      exn
     127      ;with
     128      (begin
     129        (close-input-port in)
     130        (abort exn) )
     131      ;in
     132      (do-port-update 'message-digest-update-file (check-message-digest 'message-digest-update-file md) in) )
    120133    (close-input-port in) ) )
    121134
  • release/4/message-digest/tags/3.2.0/message-digest.meta

    r33166 r34300  
    1111        (miscmacros "2.91")
    1212        (check-errors "1.13.0")
    13         (variable-item "1.3.0")
    1413        (blob-utils "1.0.0")
    1514        (string-utils "1.2.1"))
  • release/4/message-digest/tags/3.2.0/message-digest.scm

    r26592 r34300  
    33;;;; Kon Lovett, May '10 (message-digest.scm)
    44;;;; Kon Lovett, Apr '12
     5;;;; Kon Lovett, Aug '17
    56
    67(module message-digest ()
    78
    8   (import scheme chicken)
     9(import scheme chicken)
    910
    10   (reexport
    11     message-digest-primitive
    12     message-digest-type
    13     message-digest-parameters
    14     message-digest-bv
    15     message-digest-int
    16     message-digest-srfi-4
    17     message-digest-update-item
    18     message-digest-item)
    19 
    20   (require-library
    21     message-digest-primitive
    22     message-digest-type
    23     message-digest-parameters
    24     message-digest-bv
    25     message-digest-int
    26     message-digest-srfi-4
    27     message-digest-update-item
    28     message-digest-item)
     11(reexport
     12  message-digest-primitive
     13  message-digest-type
     14  message-digest-parameters
     15  message-digest-bv
     16  message-digest-int
     17  message-digest-srfi-4
     18  message-digest-update-item
     19  message-digest-item)
     20(require-library
     21  message-digest-primitive
     22  message-digest-type
     23  message-digest-parameters
     24  message-digest-bv
     25  message-digest-int
     26  message-digest-srfi-4
     27  message-digest-update-item
     28  message-digest-item)
    2929
    3030) ;module message-digest
  • release/4/message-digest/tags/3.2.0/message-digest.setup

    r33166 r34300  
    55(verify-extension-name "message-digest")
    66
    7 (setup-shared+static-extension-module 'message-digest-primitive (extension-version "3.1.1")
     7(setup-shared+static-extension-module 'message-digest-primitive (extension-version "3.2.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.1.1")
     14(setup-shared+static-extension-module 'message-digest-type (extension-version "3.2.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.1.1")
     21(setup-shared+static-extension-module 'message-digest-parameters (extension-version "3.2.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.1.1")
     28(setup-shared+static-extension-module 'message-digest-support (extension-version "3.2.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.1.1")
     35(setup-shared+static-extension-module 'message-digest-bv (extension-version "3.2.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.1.1")
     42(setup-shared+static-extension-module 'message-digest-int (extension-version "3.2.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.1.1")
     49(setup-shared+static-extension-module 'message-digest-srfi-4 (extension-version "3.2.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.1.1")
     56(setup-shared+static-extension-module 'message-digest-update-item (extension-version "3.2.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.1.1")
     63(setup-shared+static-extension-module 'message-digest-item (extension-version "3.2.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.1.1")
     70(setup-shared+static-extension-module 'message-digest-port (extension-version "3.2.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.1.1")
     77(setup-shared+static-extension-module 'message-digest-basic (extension-version "3.2.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.1.1")
     84(setup-shared+static-extension-module 'message-digest (extension-version "3.2.0")
    8585  #:inline? #t
    8686        #:types? #t
  • release/4/message-digest/trunk/message-digest-basic.scm

    r26402 r34300  
    11;;;; message-digest-basic.scm
    22;;;; Kon Lovett, May '10
     3;;;; Kon Lovett, Aug '17
    34
    45;; Issues
     
    67(module message-digest-basic ()
    78
    8   (import scheme chicken)
     9(import scheme)
    910
    10         (reexport
    11     message-digest-primitive
    12     message-digest-type
    13     message-digest-parameters
    14     message-digest-bv
    15     message-digest-int)
     11(import chicken)
    1612
    17   (require-library
    18     message-digest-primitive
    19     message-digest-type
    20     message-digest-parameters
    21     message-digest-bv
    22     message-digest-int)
     13(reexport
     14  message-digest-primitive
     15  message-digest-type
     16  message-digest-parameters
     17  message-digest-bv
     18  message-digest-int)
     19(require-library
     20  message-digest-primitive
     21  message-digest-type
     22  message-digest-parameters
     23  message-digest-bv
     24  message-digest-int)
    2325
    2426) ;module message-digest-basic
  • release/4/message-digest/trunk/message-digest-bv.scm

    r26402 r34300  
    33;;;; Kon Lovett, May '10 (message-digest.scm)
    44;;;; Kon Lovett, Apr '12
     5;;;; Kon Lovett, Aug '17
    56
    67;; Issues
     
    89(module message-digest-bv
    910
    10   (;export
    11     ;
    12     message-digest-update-blob
    13     message-digest-update-string
    14     message-digest-update-substring  ;DEPRECATED
    15     message-digest-blob
    16     message-digest-string)
     11(;export
     12  ;
     13  message-digest-update-blob
     14  message-digest-update-string
     15  message-digest-update-substring  ;DEPRECATED
     16  message-digest-blob
     17  message-digest-string)
    1718
    18   (import
    19     scheme
    20     chicken
    21     message-digest-primitive
    22     message-digest-type
    23     message-digest-support
    24     (only srfi-13 substring/shared)
    25     (only type-checks
    26       check-blob check-string))
     19(import scheme)
    2720
    28   (require-library
    29         srfi-13
    30     message-digest-primitive
    31     message-digest-type
    32     message-digest-support
    33     type-checks)
     21(import
     22  chicken
     23  (only srfi-13 substring/shared))
     24(require-library
     25  srfi-13)
     26
     27(import
     28  (only type-checks
     29    check-blob check-string))
     30(require-library
     31  type-checks)
     32
     33(require-extension
     34  message-digest-primitive
     35  message-digest-type
     36  message-digest-support)
    3437
    3538;;; Message Digest API
     
    4043
    4144(define (message-digest-update-blob md blb)
    42   (check-message-digest 'message-digest-update-blob md)
    43   (check-blob 'message-digest-update-blob blb)
    44   (*message-digest-update-blob md blb) )
     45  (*message-digest-update-blob
     46    (check-message-digest 'message-digest-update-blob md)
     47    (check-blob 'message-digest-update-blob blb)) )
    4548
    4649;;
    4750
    4851(define (message-digest-update-string md str)
    49   (check-message-digest 'message-digest-update-string md)
    50   (check-string 'message-digest-update-string str)
    51   (*message-digest-update-string md str) )
     52  (*message-digest-update-string
     53    (check-message-digest 'message-digest-update-string md)
     54    (check-string 'message-digest-update-string str)) )
    5255
    5356;;
     
    5558;DEPRECATED
    5659(define (message-digest-update-substring md str start end)
    57   (check-message-digest 'message-digest-update-substring md)
    58   (check-string 'message-digest-update-substring str)
    59   (*message-digest-update-string md (substring/shared str start end)) )
     60  (*message-digest-update-string
     61    (check-message-digest 'message-digest-update-substring md)
     62    (substring/shared (check-string 'message-digest-update-substring str) start end)) )
    6063
    6164;; Single Source API
    6265
    63 (define (message-digest-string mdp str #!optional (result-type 'hex))
     66(define (message-digest-string mdp str #!optional (result-type (message-digest-default-result-type)))
    6467  (let ((md (initialize-message-digest mdp)))
    6568    (message-digest-update-string md str)
    6669    (finalize-message-digest md result-type) ) )
    6770
    68 (define (message-digest-blob mdp blb #!optional (result-type 'hex))
     71(define (message-digest-blob mdp blb #!optional (result-type (message-digest-default-result-type)))
    6972  (let ((md (initialize-message-digest mdp)))
    7073    (message-digest-update-blob md blb)
  • release/4/message-digest/trunk/message-digest-int.scm

    r27995 r34300  
    33;;;; Kon Lovett, May '10 (message-digest.scm)
    44;;;; Kon Lovett, Apr '12
     5;;;; Kon Lovett, Aug '17
    56
    67;; Issues
     
    89(module message-digest-int
    910
    10   (;export
    11     message-digest-update-char-u8
    12     message-digest-update-char
    13     message-digest-update-char-be
    14     message-digest-update-char-le
    15     message-digest-update-u8
    16     message-digest-update-u16
    17     message-digest-update-u16-be
    18     message-digest-update-u16-le
    19     message-digest-update-u32
    20     message-digest-update-u32-be
    21     message-digest-update-u32-le
    22     message-digest-update-u64
    23     message-digest-update-u64-be
    24     message-digest-update-u64-le)
     11(;export
     12  message-digest-update-char-u8
     13  message-digest-update-char
     14  message-digest-update-char-be
     15  message-digest-update-char-le
     16  message-digest-update-u8
     17  message-digest-update-u16
     18  message-digest-update-u16-be
     19  message-digest-update-u16-le
     20  message-digest-update-u32
     21  message-digest-update-u32-be
     22  message-digest-update-u32-le
     23  message-digest-update-u64
     24  message-digest-update-u64-be
     25  message-digest-update-u64-le)
    2526
    26   (import
    27     scheme
    28     chicken
    29     message-digest-type
    30     message-digest-support
    31     blob-set-int
    32     (only type-checks
    33       check-integer check-char)
    34     (only type-errors
    35       error-argument-type))
     27(import scheme)
    3628
    37   (require-library
    38     message-digest-type
    39     message-digest-support
    40     blob-set-int
    41     type-checks
    42     type-errors)
     29(import chicken
     30  (only type-checks
     31    check-integer check-char)
     32  (only type-errors
     33    error-argument-type))
     34(require-library
     35  type-checks
     36  type-errors)
     37
     38(require-extension
     39  message-digest-type
     40  message-digest-support
     41  blob-set-int)
    4342
    4443;;; Support
     
    5554
    5655(define (*message-digest-update-uint loc md n size setter)
    57   (check-message-digest loc md)
    58   (check-integer loc n)
    59   (let ((blb (setup-message-digest-buffer! md size)))
    60         (setter blb n 0)
     56  (let ((blb (setup-message-digest-buffer! (check-message-digest loc md) size)))
     57        (setter blb (check-integer loc n) 0)
    6158        (*message-digest-update-blob md blb size) ) )
    6259
     
    6663
    6764(define (message-digest-update-char-u8 md ch)
    68   (check-char 'message-digest-update-char-u8 ch)
    69         (*message-digest-update-uint 'message-digest-update-char-u8 md (char->integer ch) 1 *blob-set-u8!) )
     65        (*message-digest-update-uint
     66          'message-digest-update-char-u8
     67          md
     68          (char->integer (check-char 'message-digest-update-char-u8 ch))
     69          1
     70          *blob-set-u8!) )
    7071
    7172(define (message-digest-update-char-be md ch)
    72   (check-char 'message-digest-update-char ch)
    73         (*message-digest-update-uint 'message-digest-update-char-be md (char->integer ch) 4 *blob-set-u32-be!) )
     73        (*message-digest-update-uint
     74          'message-digest-update-char-be
     75          md
     76          (char->integer (check-char 'message-digest-update-char ch))
     77          4
     78          *blob-set-u32-be!) )
    7479
    7580(define (message-digest-update-char-le md ch)
    76   (check-char 'message-digest-update-char ch)
    77         (*message-digest-update-uint 'message-digest-update-char-le md (char->integer ch) 4 *blob-set-u32-le!) )
     81        (*message-digest-update-uint
     82          'message-digest-update-char-le
     83          md
     84          (char->integer (check-char 'message-digest-update-char ch))
     85          4
     86          *blob-set-u32-le!) )
    7887
    7988;; Unsigned Integer 8, 16, 32, & 64 bits
  • release/4/message-digest/trunk/message-digest-item.scm

    r26402 r34300  
    33;;;; Kon Lovett, may '10 (message-digest.scm)
    44;;;; Kon Lovett, Apr '12
     5;;;; Kon Lovett, Aug '17
    56
    67;; Issues
     
    89(module message-digest-item
    910
    10   (;export
    11     message-digest-object
    12     message-digest-file
    13     message-digest-port)
     11(;export
     12  message-digest-object
     13  message-digest-file
     14  message-digest-port)
    1415
    15   (import
    16     scheme
    17     chicken
    18     message-digest-type
    19     message-digest-update-item)
     16(import scheme)
    2017
    21   (require-library
    22     message-digest-type
    23     message-digest-update-item)
     18(import chicken)
     19
     20(require-extension
     21  message-digest-type
     22  message-digest-update-item)
    2423
    2524;;; Single Source API
    2625
    27 (define (message-digest-object mdp obj #!optional (result-type 'hex))
     26(define (message-digest-object mdp obj #!optional (result-type (message-digest-default-result-type)))
    2827  (let ((md (initialize-message-digest mdp)))
    2928    (message-digest-update-object md obj)
    3029    (finalize-message-digest md result-type) ) )
    3130
    32 (define (message-digest-file mdp flnm #!optional (result-type 'hex))
     31(define (message-digest-file mdp flnm #!optional (result-type (message-digest-default-result-type)))
    3332  (let ((md (initialize-message-digest mdp)))
    3433    (message-digest-update-file md flnm)
    3534    (finalize-message-digest md result-type) ) )
    3635
    37 (define (message-digest-port mdp port #!optional (result-type 'hex))
     36(define (message-digest-port mdp port #!optional (result-type (message-digest-default-result-type)))
    3837  (let ((md (initialize-message-digest mdp)))
    3938    (message-digest-update-port md port)
  • release/4/message-digest/trunk/message-digest-old.scm

    r26378 r34300  
    33;;;; Kon Lovett, May '10 (message-digest.scm)
    44;;;; Kon Lovett, Apr '12
     5;;;; Kon Lovett, Aug '17
    56
    67;; Issues
     8;;
     9;; - DEPRECATED
    710
    811(module message-digest-old
    912
    10   (;export
    11     string->hex
    12     byte-string->hexadecimal
    13     make-binary-message-digest
    14     make-message-digest
    15     message-digest-primitive-apply)
     13(;export
     14  string->hex
     15  byte-string->hexadecimal
     16  make-binary-message-digest
     17  make-message-digest
     18  message-digest-primitive-apply)
    1619
    17         (import
    18     scheme
    19     chicken
    20     message-digest-basic
    21     message-digest-single
    22     (only string-hexadecimal string->hex))
     20(import scheme)
    2321
    24   (require-library
    25     message-digest-basic
    26     message-digest-single
    27     string-hexadecimal)
     22(import chicken)
     23  (only string-hexadecimal string->hex))
     24(require-library
     25  string-hexadecimal)
     26
     27(require-extension
     28  message-digest-basic
     29  message-digest-single)
    2830
    2931;;; Byte-string Utilities
     
    3537;;
    3638
    37 (define (message-digest-primitive-apply mdp src . args) ;DEPRECATED
     39;DEPRECATED
     40(define (message-digest-primitive-apply mdp src . args)
    3841  (message-digest-object mdp src 'string) )
    3942
    4043;;
    4144
     45;DEPRECATED
    4246(define (make-binary-message-digest src ctx-info digest-len init update final
    43                                     #!optional (name 'make-binary-message-digest)) ;DEPRECATED
     47                                    #!optional (name 'make-binary-message-digest))
    4448  (message-digest-object
    4549    (make-message-digest-primitive ctx-info digest-len init update final name)
     
    4953;;
    5054
     55;DEPRECATED
    5156(define (make-message-digest src ctx-info digest-len init update final
    52                              #!optional (name 'make-message-digest)) ;DEPRECATED
     57                             #!optional (name 'make-message-digest))
    5358  (message-digest-object
    5459    (make-message-digest-primitive ctx-info digest-len init update final name)
  • release/4/message-digest/trunk/message-digest-parameters.scm

    r26402 r34300  
    1313(module message-digest-parameters
    1414
    15   (;export
    16     ; Parameters
    17     message-digest-chunk-size
    18     message-digest-chunk-read-maker
    19     message-digest-chunk-converter)
     15(;export
     16  ; Parameters
     17  message-digest-chunk-size
     18  message-digest-chunk-read-maker
     19  message-digest-chunk-converter)
    2020
    21   (import
    22     scheme
    23     chicken
    24     (only srfi-4
    25         u8vector->blob/shared subu8vector
    26         read-u8vector! make-u8vector)
    27     variable-item
    28     (only type-checks
    29                         check-procedure check-positive-fixnum )
    30     (only type-errors
    31       error-argument-type))
     21(import scheme)
    3222
    33   (require-library
    34         srfi-4
    35     variable-item
    36     type-errors
    37     type-checks)
     23(import
     24  chicken
     25  (only srfi-4
     26    u8vector->blob/shared subu8vector
     27    read-u8vector! make-u8vector))
     28(require-library
     29  srfi-4)
    3830
    3931;;; Update Phase Helpers
     32
     33;;
     34
     35(define (positive-fixnum? obj)
     36  (and (fixnum? obj) (positive? obj)) )
    4037
    4138;;
     
    4542    (lambda ()
    4643      (let ((len (read-u8vector! size u8buf in)))
    47         (and (positive? len)
    48              (let ((u8buf (if (fx= len size) u8buf (subu8vector u8buf 0 len))))
    49                (u8vector->blob/shared u8buf) ) ) ) ) ) )
     44        (and
     45          (positive? len)
     46          (let ((u8buf (if (fx= len size) u8buf (subu8vector u8buf 0 len))))
     47            (u8vector->blob/shared u8buf) ) ) ) ) ) )
    5048
    5149;;
     
    5755;;
    5856
    59 (define-checked-variable message-digest-chunk-size
    60   DEFAULT-CHUNK-SIZE
    61   positive-fixnum)
     57(define message-digest-chunk-size (make-parameter DEFAULT-CHUNK-SIZE
     58  (lambda (x)
     59    (cond
     60      ((positive-fixnum? x)   x )
     61      ((not x)                DEFAULT-CHUNK-SIZE )
     62      (else
     63        (warning 'message-digest-chunk-size "invalid positive-fixnum" x)
     64        (message-digest-chunk-size) ) ) ) ) )
    6265
    6366;;
    6467
    65 (define-checked-variable message-digest-chunk-read-maker
    66   default-chunk-read-maker
    67   procedure)
     68(define message-digest-chunk-read-maker (make-parameter default-chunk-read-maker
     69  (lambda (x)
     70    (cond
     71      ((procedure? x)   x )
     72      ((not x)          default-chunk-read-maker )
     73      (else
     74        (warning 'message-digest-chunk-read-maker "invalid procedure" x)
     75        (message-digest-chunk-read-maker) ) ) ) ) )
    6876
    6977;;
    7078
    71 (define-variable message-digest-chunk-converter #f
    72   (lambda (obj)
    73     (if (or (not obj) (procedure? obj)) obj
    74       (error-argument-type 'message-digest-chunk-converter obj "#f or procedure"))))
     79(define message-digest-chunk-converter (make-parameter #f
     80  (lambda (x)
     81    (if (or (not x) (procedure? x))
     82      x
     83      (begin
     84        (warning 'message-digest-chunk-converter "invalid procedure or #f" x)
     85        (message-digest-chunk-converter) ) ) ) ) )
    7586
    7687) ;module message-digest-parameters
  • release/4/message-digest/trunk/message-digest-port.scm

    r31014 r34300  
    11;;;; message-digest-port.scm
    22;;;; Kon Lovett, May '10
     3;;;; Kon Lovett, Aug '17
    34
    45;; Issues
     
    89(module message-digest-port
    910
    10         (;export
    11           digest-output-port? check-digest-output-port error-digest-output-port
    12           digest-output-port-name
    13     open-output-digest
    14     get-output-digest
    15     call-with-output-digest
    16     with-output-to-digest)
     11(;export
     12  digest-output-port? check-digest-output-port error-digest-output-port
     13  digest-output-port-name
     14  open-output-digest
     15  get-output-digest
     16  call-with-output-digest
     17  with-output-to-digest)
    1718
    18   (import
    19     scheme
    20     chicken
    21     (only data-structures ->string)
    22     (only ports make-output-port with-input-from-port)
    23     (only srfi-13 string-suffix-length-ci)
    24     (only type-checks define-check+error-type check-output-port)
    25     (only type-errors error-argument-type make-error-type-message signal-type-error)
    26     message-digest-primitive
    27     message-digest-type
    28     message-digest-bv)
     19(import scheme)
    2920
    30   (require-library
    31         data-structures
    32         ports
    33         srfi-13
    34         type-checks
    35         type-errors
    36     message-digest-primitive
    37     message-digest-type
    38     message-digest-bv)
     21(import
     22  chicken
     23  (only data-structures ->string)
     24  (only ports make-output-port with-input-from-port)
     25  (only srfi-13 string-suffix-length-ci))
     26(require-library
     27  data-structures
     28  ports
     29  srfi-13)
     30
     31(import
     32  (only type-checks define-check+error-type check-output-port)
     33  (only type-errors error-argument-type make-error-type-message signal-type-error))
     34(require-library
     35  type-checks
     36  type-errors)
     37
     38(require-extension
     39  message-digest-primitive
     40  message-digest-type
     41  message-digest-bv)
    3942
    4043;;; Message Digest Output Port API
     
    5659;
    5760(define (check-open-digest-output-port loc obj #!optional argnam)
    58   (check-open-port loc (check-output-port loc obj argnam) argnam)
    59   (unless (eq? 'digest (%port-type obj))
    60     (signal-type-error loc (make-error-type-message 'digest-output-port) obj argnam) )
     61  (let ((pt (%port-type (check-open-port loc (check-output-port loc obj argnam) argnam))))
     62    (unless (eq? 'digest pt)
     63      (signal-type-error loc (make-error-type-message 'digest-output-port) obj argnam) ) )
    6164  obj )
    6265
    6366; Synthesize a port-name from a primitive-name
    6467(define (make-digest-port-name mdp)
    65   (let ((nam (->string (or (message-digest-primitive-name mdp) 'digest))))
    66     (let ((remlen (string-suffix-length-ci nam "-primitive")))
    67       (string-append
    68         "("
     68  (let* ((nam (->string (or (message-digest-primitive-name mdp) 'digest)) )
     69         (remlen (string-suffix-length-ci nam "-primitive") ) )
     70    (string-append
     71      "("
    6972        (if (positive? remlen)
    70             (substring nam 0 (fx- (string-length nam) remlen))
    71             nam )
    72         ")") ) ) )
     73          (substring nam 0 (fx- (string-length nam) remlen))
     74          nam )
     75      ")") ) )
    7376
    7477;; Returns a digest-output-port for the MDP
    7578
    7679(define (open-output-digest mdp)
    77   (let* ((md (initialize-message-digest mdp))
     80  (let* ((md (initialize-message-digest mdp) )
    7881         (writer
    7982          (lambda (obj)
    80             ; It will only ever be a string for now.
    81             (if (string? obj) (message-digest-update-string md obj)
    82               (message-digest-update-blob md obj))))
    83          (port (make-output-port writer void)) ) ;use default close behavior
     83            ;it will only ever be a string for now
     84            (if (string? obj)
     85              (message-digest-update-string md obj)
     86              (message-digest-update-blob md obj))) )
     87         (port (make-output-port writer void) ) ) ;use default close behavior
    8488    (##sys#set-port-data! port md)
    8589    (%port-type-set! port 'digest)
     
    8892
    8993(define (digest-output-port? obj)
    90   (and (output-port? obj)
    91        (eq? 'digest (%port-type obj)) ) )
     94  (and
     95    (output-port? obj)
     96    (eq? 'digest (%port-type obj)) ) )
    9297
    9398(define-check+error-type digest-output-port)
    9499
    95100(define (digest-output-port-name p)
    96   (check-digest-output-port 'digest-output-port-name p)
    97   (%port-name p) )
     101  (%port-name (check-digest-output-port 'digest-output-port-name p)) )
    98102
    99103;; Finalizes the digest-output-port and returns the result in the form requested
    100104
    101105(define (*close-output-digest loc digest-port result-type)
    102   (check-open-digest-output-port loc digest-port 'digest-port)
    103   (let ((res (finalize-message-digest (##sys#port-data digest-port) result-type)))
     106  (let ((res
     107          (finalize-message-digest
     108            (##sys#port-data (check-open-digest-output-port loc digest-port 'digest-port))
     109            result-type)))
    104110    (close-output-port digest-port)
    105111    res ) )
    106112
    107 (define (get-output-digest digest-port #!optional (result-type 'hex))
     113(define (get-output-digest digest-port #!optional (result-type (message-digest-default-result-type)))
    108114  (*close-output-digest 'get-output-digest digest-port result-type) )
    109115
     
    113119;; Returns the accumulated output string | blob | u8vector | hexstring
    114120
    115 (define (call-with-output-digest mdp proc #!optional (result-type 'hex))
     121(define (call-with-output-digest mdp proc #!optional (result-type (message-digest-default-result-type)))
    116122  (let ((port (open-output-digest mdp)))
    117123    (proc port)
     
    122128;; Returns the accumulated output string | blob | u8vector | hexstring
    123129
    124 (define (with-output-to-digest mdp thunk #!optional (result-type 'hex))
     130(define (with-output-to-digest mdp thunk #!optional (result-type (message-digest-default-result-type)))
    125131  (call-with-output-digest mdp (cut with-input-from-port <> thunk) result-type) )
    126132
  • release/4/message-digest/trunk/message-digest-primitive.scm

    r31014 r34300  
    33;;;; Kon Lovett, May '10 (message-digest.scm)
    44;;;; Kon Lovett, Apr '12
     5;;;; Kon Lovett, Aug '17
    56
    67;; Issues
     
    89(module message-digest-primitive
    910
    10   (;export
    11     ; Algorithm API
    12     make-message-digest-primitive
    13     message-digest-primitive? check-message-digest-primitive error-message-digest-primitive
    14     message-digest-primitive-name
    15     message-digest-primitive-block-length
    16     message-digest-primitive-context-info
    17     message-digest-primitive-digest-length
    18     message-digest-primitive-init
    19     message-digest-primitive-update
    20     message-digest-primitive-final)
     11(;export
     12  ; Algorithm API
     13  make-message-digest-primitive
     14  message-digest-primitive? check-message-digest-primitive error-message-digest-primitive
     15  message-digest-primitive-name
     16  message-digest-primitive-block-length
     17  message-digest-primitive-context-info
     18  message-digest-primitive-digest-length
     19  message-digest-primitive-init
     20  message-digest-primitive-update
     21  message-digest-primitive-final)
    2122
    22   (import
    23     scheme
    24     chicken
    25     (only type-checks
    26       define-check+error-type
    27       check-positive-fixnum
    28       check-procedure)
    29     (only type-errors
    30       error-argument-type))
     23(import scheme)
    3124
    32   (require-library
    33     type-checks
    34     type-errors)
     25(import chicken)
     26
     27(import
     28  (only type-checks
     29    define-check+error-type
     30    check-positive-fixnum
     31    check-procedure)
     32  (only type-errors
     33    error-argument-type))
     34(require-library
     35  type-checks
     36  type-errors)
    3537
    3638;;; Support
  • release/4/message-digest/trunk/message-digest-srfi-4.scm

    r33166 r34300  
    33;;;; Kon Lovett, May '10 (message-digest.scm)
    44;;;; Kon Lovett, Apr '12
     5;;;; Kon Lovett, Aug '17
    56
    67;; Issues
     
    1011(module message-digest-srfi-4
    1112
    12   (;export
    13     message-digest-update-bytevector                    ;DEPRECATED
    14     message-digest-update-u8vector
    15     message-digest-update-subu8vector                   ;DEPRECATED
    16     message-digest-update-packed-vector         ;DEPRECATED
    17     message-digest-u8vector)
     13(;export
     14  message-digest-update-bytevector                      ;DEPRECATED
     15  message-digest-update-u8vector
     16  message-digest-update-subu8vector                     ;DEPRECATED
     17  message-digest-update-packed-vector           ;DEPRECATED
     18  message-digest-u8vector)
    1819
    19   (import
    20     scheme
    21     chicken
    22     data-structures
    23     srfi-4
    24     (only lolevel number-of-bytes)
    25     message-digest-primitive
    26     message-digest-type
    27     message-digest-support
    28     message-digest-bv
    29     (only srfi-4-checks check-u8vector)
    30     (only type-errors error-argument-type))
     20(import scheme)
    3121
    32   (require-library
    33     data-structures
    34     srfi-4
    35     lolevel
    36     message-digest-primitive
    37     message-digest-type
    38     message-digest-support
    39     message-digest-bv
    40     type-errors)
     22(import
     23  chicken
     24  data-structures
     25  srfi-4
     26  (only lolevel number-of-bytes))
     27(require-library
     28  data-structures
     29  srfi-4
     30  lolevel)
     31
     32(import
     33  (only srfi-4-checks check-u8vector)
     34  (only type-errors error-argument-type))
     35(require-library
     36  type-errors)
     37
     38(require-extension
     39  message-digest-primitive
     40  message-digest-type
     41  message-digest-support
     42  message-digest-bv)
    4143
    4244;;; Support
     
    4648(define (get-bytevector-object loc obj)
    4749        (cond
    48                 ((string? obj)                                                                          (string->blob obj) )
    49                 ((blob? obj)                                                                                    obj )
    50                 ((packed-vector->blob/shared obj) )
     50                ((string? obj)                                                                            (string->blob obj) )
     51                ((blob? obj)                                                                                      obj )
     52                ((packed-vector->blob/shared obj)   )
    5153                (else
    5254        (error-argument-type loc obj "string, blob, or SRFI 4 vector" obj) ) ) )
     
    7072(define (message-digest-update-packed-vector md pkdvec)
    7173  (let ((blb (packed-vector->blob/shared pkdvec)))
    72     (if blb (message-digest-update-blob md blb)
    73         (error-argument-type 'message-digest-update-packed-vector pkdvec "SRFI 4 vector") ) ) )
     74    (if blb
     75      (message-digest-update-blob md blb)
     76      (error-argument-type 'message-digest-update-packed-vector pkdvec "SRFI 4 vector") ) ) )
    7477
    7578;;
     
    8790;;; Single Source API
    8891
    89 (define (message-digest-u8vector mdp u8vec #!optional (result-type 'hex))
     92(define (message-digest-u8vector mdp u8vec #!optional (result-type (message-digest-default-result-type)))
    9093  (let ((md (initialize-message-digest mdp)))
    9194    (message-digest-update-u8vector md u8vec)
  • release/4/message-digest/trunk/message-digest-support.scm

    r27988 r34300  
    33;;;; Kon Lovett, May '10 (message-digest.scm)
    44;;;; Kon Lovett, Apr '12
     5;;;; Kon Lovett, Aug '17
    56
    67;; Issues
     
    1314(module message-digest-support
    1415
    15   (;export
    16         ; Support
    17         packed-vector->blob/shared
    18         *message-digest-update-blob
    19         *message-digest-update-string)
     16(;export
     17  ; Support
     18  packed-vector->blob/shared
     19  *message-digest-update-blob
     20  *message-digest-update-string)
    2021
    21   (import
    22     scheme
    23     chicken
    24     (only lolevel number-of-bytes)
    25     (only srfi-4
    26                         s8vector?
    27                         u8vector?
    28                         s16vector?
    29                         u16vector?
    30                         s32vector?
    31                         u32vector?
    32                         #;u64vector?
    33                         #;u64vector?
    34                         f32vector?
    35                         f64vector?
    36                         u8vector->blob/shared
    37                         s8vector->blob/shared
    38                         s16vector->blob/shared
    39                         u16vector->blob/shared
    40                         s32vector->blob/shared
    41                         u32vector->blob/shared
    42                         #;s64vector->blob/shared
    43                         #;u64vector->blob/shared
    44                         f32vector->blob/shared
    45                         f64vector->blob/shared)
    46     message-digest-primitive
    47                 message-digest-type)
     22(import scheme)
    4823
     24(import
     25  chicken
     26  (only lolevel number-of-bytes)
     27  (only srfi-4
     28    s8vector?
     29    u8vector?
     30    s16vector?
     31    u16vector?
     32    s32vector?
     33    u32vector?
     34    #;u64vector?
     35    #;u64vector?
     36    f32vector?
     37    f64vector?
     38    u8vector->blob/shared
     39    s8vector->blob/shared
     40    s16vector->blob/shared
     41    u16vector->blob/shared
     42    s32vector->blob/shared
     43    u32vector->blob/shared
     44    #;s64vector->blob/shared
     45    #;u64vector->blob/shared
     46    f32vector->blob/shared
     47    f64vector->blob/shared))
     48(require-library
     49  lolevel
     50  srfi-4)
    4951
    50   (require-library
    51     srfi-4
    52     message-digest-primitive
    53     message-digest-type)
     52(require-extension
     53  message-digest-primitive
     54  message-digest-type)
    5455
    5556;;; Support
     
    7576
    7677(define (*message-digest-update-blob md blb #!optional (siz (blob-size blb)))
    77   (let ((mdp (message-digest-algorithm md))
    78         (ctx (message-digest-context md)) )
    79     ((message-digest-primitive-update mdp) ctx blb siz) ) )
     78  ((message-digest-algorithm-update md)
     79    (message-digest-context md)
     80    blb
     81    siz) )
    8082
    8183(define (*message-digest-update-string md str)
    8284        (*message-digest-update-blob md (string->blob str)) )
    8385
     86(define (message-digest-algorithm-update md)
     87  (message-digest-primitive-update (message-digest-algorithm md)) )
     88
    8489) ;module message-digest-support
  • release/4/message-digest/trunk/message-digest-type.scm

    r27988 r34300  
    33;;;; Kon Lovett, May '10 (message-digest.scm)
    44;;;; Kon Lovett, Apr '12
     5;;;; Kon Lovett, Aug '17
    56
    67;; Issues
     
    1112(module message-digest-type
    1213
    13   (;export
    14     ; MD API
    15     message-digest? check-message-digest error-message-digest
    16     message-digest-algorithm message-digest-context
    17     initialize-message-digest
    18     finalize-message-digest
    19     setup-message-digest-buffer!)
     14(;export
     15  ; MD API
     16  message-digest-default-result-type
     17  message-digest? check-message-digest error-message-digest
     18  message-digest-algorithm message-digest-context
     19  initialize-message-digest
     20  finalize-message-digest
     21  setup-message-digest-buffer!)
    2022
    21   (import
    22     scheme
    23     chicken
    24     (only lolevel allocate free number-of-bytes)
    25     (only srfi-4 blob->u8vector/shared)
    26     message-digest-primitive
    27     (only blob-hexadecimal blob->hex)
    28     (only string-hexadecimal string->hex)
    29     (only type-checks
    30       define-check+error-type)
    31     (only type-errors
    32       error-argument-type))
     23(import scheme)
    3324
    34   (require-library
    35     lolevel
    36     srfi-4
    37     message-digest-primitive
    38     blob-hexadecimal
    39     string-hexadecimal
    40     type-checks
    41     type-errors)
     25(import
     26  chicken
     27  (only lolevel allocate free number-of-bytes)
     28  (only srfi-4 blob->u8vector/shared))
     29(require-library
     30  lolevel
     31  srfi-4)
     32
     33(import
     34  (only blob-hexadecimal blob->hex)
     35  (only string-hexadecimal string->hex)
     36  (only type-checks
     37    define-check+error-type)
     38  (only type-errors
     39    error-argument-type))
     40(require-library
     41  blob-hexadecimal
     42  string-hexadecimal
     43  type-checks
     44  type-errors)
     45
     46(require-extension
     47  message-digest-primitive)
    4248
    4349;;; Support
    4450
    4551(define-constant MINIMUM-BUFFER-SIZE 8)
     52
     53(define-constant DEFAULT-RESULT-TYPE 'hex-string)
    4654
    4755(define (error-result-form loc obj)
     
    5664      (if (fx= len (blob-size res)) res
    5765        (string->blob (substring (blob->string res) 0 len)) ) )
    58     ((string byte-string)
     66    ((byte-string string)
    5967      (let ((str (blob->string res)))
    6068        (if (fx= len (string-length str)) str
    6169          (substring str 0 len) ) ) )
    62     ((hexstring hex)
     70    ((hex-string hex hexstring)
    6371      (blob->hex res 0 len) )
    6472    ((u8vector)
     
    7280;assumes blob 'res' is of result size
    7381(define (get-result-form loc res rt)
    74   (case rt
    75     ((blob)                                                                             res )
    76     ((string byte-string)                       (blob->string res) )
    77     ((hexstring hex)            (blob->hex res) )
    78     ((u8vector)                 (blob->u8vector/shared res) )
     82  (case (canonical-result-name rt)
     83    ((blob)           res )
     84    ((byte-string)    (blob->string res) )
     85    ((hex-string)     (blob->hex res) )
     86    ((u8vector)       (blob->u8vector/shared res) )
    7987    (else
    8088      (error-result-form loc rt) ) ) )
    8189
     90(define (canonical-result-name x)
     91  (case x
     92    ((blob)                       'blob )
     93    ((byte-string string)         'byte-string )
     94    ((hex-string hex hexstring)   'hex-string )
     95    ((u8vector)                   'u8vector )
     96    (else
     97      #f ) ) )
    8298
    8399;;; Message Digest API
     100
     101;;
     102
     103(define message-digest-default-result-type (make-parameter DEFAULT-RESULT-TYPE
     104  (lambda (x)
     105    (or
     106      (if x (canonical-result-name x) DEFAULT-RESULT-TYPE)
     107      (begin
     108        (warning 'message-digest-default-result-type "invalid result-form" x)
     109        (message-digest-default-result-type) ) ) ) ) )
    84110
    85111;;
     
    98124(define (get-message-digest-primitive-context mdp)
    99125  (let ((ctx-info (message-digest-primitive-context-info mdp)))
    100     (if (procedure? ctx-info) (ctx-info)
     126    (if (procedure? ctx-info)
     127      (ctx-info)
    101128      (set-finalizer! (allocate ctx-info) free) ) ) )
    102129
     
    104131
    105132(define (initialize-message-digest mdp)
    106   (check-message-digest-primitive 'initialize-message-digest mdp)
    107   (let ((ctx (get-message-digest-primitive-context mdp)))
     133  (let ((ctx
     134          (get-message-digest-primitive-context
     135            (check-message-digest-primitive 'initialize-message-digest mdp))))
    108136    ((message-digest-primitive-init mdp) ctx)
    109137    (*make-message-digest mdp ctx #f) ) )
     
    111139;;
    112140
    113 (define (finalize-message-digest md #!optional (result-type 'hex))
    114   (check-message-digest 'finalize-message-digest md)
    115   (let ((mdp (message-digest-algorithm md))
    116         (ctx (message-digest-context md)) )
    117     (let ((res (make-blob (message-digest-primitive-digest-length mdp))))
    118       ((message-digest-primitive-final mdp) ctx res)
    119       (get-result-form 'finalize-message-digest res result-type) ) ) )
     141(define (finalize-message-digest md #!optional (result-type (message-digest-default-result-type)))
     142  (let* ((mdp
     143          (message-digest-algorithm
     144            (check-message-digest 'finalize-message-digest md)))
     145         (res
     146          (make-blob (message-digest-primitive-digest-length mdp))) )
     147      ((message-digest-primitive-final mdp) (message-digest-context md) res)  ;side-effects res
     148      (get-result-form 'finalize-message-digest res result-type) ) )
    120149
    121150;;
     
    124153  (let ((buf (message-digest-buffer md))
    125154        (sz (fxmax sz MINIMUM-BUFFER-SIZE)) )
    126     (if (and buf (fx<= sz (number-of-bytes buf))) buf
    127       (let ((buf (make-blob sz)))
    128         (message-digest-buffer-set! md buf)
    129         buf ) ) ) )
     155    ;enough space? then reuse, otherwise new buffer
     156    (if (and buf (fx<= sz (number-of-bytes buf)))
     157      buf
     158      (new-message-digest-buffer! md sz) ) ) )
     159
     160(define (new-message-digest-buffer! md sz)
     161  (let ((buf (make-blob sz)))
     162    (message-digest-buffer-set! md buf)
     163    buf ) )
    130164
    131165) ;module message-digest-type
  • release/4/message-digest/trunk/message-digest-update-item.scm

    r26402 r34300  
    33;;;; Kon Lovett, May '10 (message-digest.scm)
    44;;;; Kon Lovett, Apr '12
     5;;;; Kon Lovett, Aug '17
    56
    67;; Issues
     
    89(module message-digest-update-item
    910
    10   (;export
    11     message-digest-update-object
    12     message-digest-update-procedure
    13     message-digest-update-port
    14     message-digest-update-file)
     11(;export
     12  message-digest-update-object
     13  message-digest-update-procedure
     14  message-digest-update-port
     15  message-digest-update-file)
    1516
    16   (import
    17     scheme
    18     chicken
    19     (only lolevel number-of-bytes)
    20     (only miscmacros while*)
    21     message-digest-primitive
    22     message-digest-type
    23     message-digest-parameters
    24     message-digest-support
    25     type-checks
    26     type-errors)
     17(import scheme)
    2718
    28   (require-library
    29         lolevel
    30     miscmacros
    31     message-digest-primitive
    32     message-digest-type
    33     message-digest-parameters
    34     message-digest-support
    35         type-checks)
     19(import
     20  chicken
     21  (only lolevel number-of-bytes))
     22(require-library
     23  lolevel)
     24
     25(import
     26  (only miscmacros while*))
     27(require-library
     28  miscmacros)
     29
     30(require-extension
     31  message-digest-primitive
     32  message-digest-type
     33  message-digest-parameters
     34  message-digest-support
     35  type-checks
     36  type-errors)
    3637
    3738;;; Support
     
    4041
    4142(define (chunk-convert obj)
    42   (and-let* ((cnv (message-digest-chunk-converter))) (cnv obj)) )
     43  (and-let* ((cnv (message-digest-chunk-converter)))
     44    (cnv obj) ) )
    4345
    4446(define (get-chunk-reader in)
     
    5052;;
    5153
    52 (define (object->bytevector-like obj)
    53   (or (packed-vector->blob/shared obj)
    54       (chunk-convert obj)) )
     54(define (do-object-update loc md src)
     55  (cond
     56    ((input-port? src)    (do-port-update loc md src) )
     57    ((procedure? src)     (do-procedure-update loc md src) )
     58    (else                 (do-bytes-update loc md src) ) ) )
     59
     60(define (do-port-update loc md in)
     61  (do-procedure-update loc md (get-chunk-reader in)) )
     62
     63(define (do-bytes-update loc md src)
     64  (do-byte-source-update
     65    loc
     66    (message-digest-context md)
     67    src
     68    (get-update md)) )
    5569
    5670(define (do-byte-source-update loc ctx src updt)
     
    7387    (while* (proc) (do-byte-source-update loc ctx it updt) ) ) )
    7488
    75 (define (do-port-update loc md in)
    76   (do-procedure-update loc md (get-chunk-reader in)) )
    77 
    78 (define (do-bytes-update loc md src)
    79   (let ((updt (get-update md))
    80         (ctx (message-digest-context md)) )
    81     (do-byte-source-update loc ctx src updt) ) )
    82 
    83 (define (do-object-update loc md src)
    84   (cond
    85     ((input-port? src)    (do-port-update loc md src) )
    86     ((procedure? src)     (do-procedure-update loc md src) )
    87     (else                 (do-bytes-update loc md src) ) ) )
     89(define (object->bytevector-like obj)
     90  (or
     91    (packed-vector->blob/shared obj)
     92    (chunk-convert obj)) )
    8893
    8994;;; Update Operation
     
    9297
    9398(define (message-digest-update-object md obj)
    94   (check-message-digest 'message-digest-update-object md)
    95   (do-object-update 'message-digest-update-object md obj) )
     99  (do-object-update
     100    'message-digest-update-object
     101    (check-message-digest 'message-digest-update-object md)
     102    obj) )
    96103
    97104;;
    98105
    99106(define (message-digest-update-procedure md proc)
    100   (check-message-digest 'message-digest-update-procedure md)
    101   (check-procedure 'message-digest-update-procedure proc)
    102   (do-procedure-update 'message-digest-update-procedure md proc) )
     107  (do-procedure-update
     108    'message-digest-update-procedure
     109    (check-message-digest 'message-digest-update-procedure md)
     110    (check-procedure 'message-digest-update-procedure proc)) )
    103111
    104112;;
    105113
    106114(define (message-digest-update-port md in)
    107   (check-message-digest 'message-digest-update-port md)
    108   (check-input-port 'message-digest-update-port in)
    109   (do-port-update 'message-digest-update-port md in) )
     115  (do-port-update
     116    'message-digest-update-port
     117    (check-message-digest 'message-digest-update-port md)
     118    (check-input-port 'message-digest-update-port in)) )
    110119
    111120;;
    112121
    113122(define (message-digest-update-file md flnm)
    114   (check-message-digest 'message-digest-update-file md)
    115   (check-string 'message-digest-update-file flnm)
    116   (let ((in (open-input-file flnm)))
    117     (handle-exceptions exn
    118         (begin (close-input-port in) (abort exn))
    119       (do-port-update 'message-digest-update-file md in) )
     123  (let ((in (open-input-file (check-string 'message-digest-update-file flnm))))
     124    (handle-exceptions
     125      ;as
     126      exn
     127      ;with
     128      (begin
     129        (close-input-port in)
     130        (abort exn) )
     131      ;in
     132      (do-port-update 'message-digest-update-file (check-message-digest 'message-digest-update-file md) in) )
    120133    (close-input-port in) ) )
    121134
  • release/4/message-digest/trunk/message-digest.meta

    r33166 r34300  
    1111        (miscmacros "2.91")
    1212        (check-errors "1.13.0")
    13         (variable-item "1.3.0")
    1413        (blob-utils "1.0.0")
    1514        (string-utils "1.2.1"))
  • release/4/message-digest/trunk/message-digest.scm

    r26592 r34300  
    33;;;; Kon Lovett, May '10 (message-digest.scm)
    44;;;; Kon Lovett, Apr '12
     5;;;; Kon Lovett, Aug '17
    56
    67(module message-digest ()
    78
    8   (import scheme chicken)
     9(import scheme chicken)
    910
    10   (reexport
    11     message-digest-primitive
    12     message-digest-type
    13     message-digest-parameters
    14     message-digest-bv
    15     message-digest-int
    16     message-digest-srfi-4
    17     message-digest-update-item
    18     message-digest-item)
    19 
    20   (require-library
    21     message-digest-primitive
    22     message-digest-type
    23     message-digest-parameters
    24     message-digest-bv
    25     message-digest-int
    26     message-digest-srfi-4
    27     message-digest-update-item
    28     message-digest-item)
     11(reexport
     12  message-digest-primitive
     13  message-digest-type
     14  message-digest-parameters
     15  message-digest-bv
     16  message-digest-int
     17  message-digest-srfi-4
     18  message-digest-update-item
     19  message-digest-item)
     20(require-library
     21  message-digest-primitive
     22  message-digest-type
     23  message-digest-parameters
     24  message-digest-bv
     25  message-digest-int
     26  message-digest-srfi-4
     27  message-digest-update-item
     28  message-digest-item)
    2929
    3030) ;module message-digest
  • release/4/message-digest/trunk/message-digest.setup

    r33166 r34300  
    55(verify-extension-name "message-digest")
    66
    7 (setup-shared+static-extension-module 'message-digest-primitive (extension-version "3.1.1")
     7(setup-shared+static-extension-module 'message-digest-primitive (extension-version "3.2.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.1.1")
     14(setup-shared+static-extension-module 'message-digest-type (extension-version "3.2.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.1.1")
     21(setup-shared+static-extension-module 'message-digest-parameters (extension-version "3.2.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.1.1")
     28(setup-shared+static-extension-module 'message-digest-support (extension-version "3.2.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.1.1")
     35(setup-shared+static-extension-module 'message-digest-bv (extension-version "3.2.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.1.1")
     42(setup-shared+static-extension-module 'message-digest-int (extension-version "3.2.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.1.1")
     49(setup-shared+static-extension-module 'message-digest-srfi-4 (extension-version "3.2.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.1.1")
     56(setup-shared+static-extension-module 'message-digest-update-item (extension-version "3.2.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.1.1")
     63(setup-shared+static-extension-module 'message-digest-item (extension-version "3.2.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.1.1")
     70(setup-shared+static-extension-module 'message-digest-port (extension-version "3.2.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.1.1")
     77(setup-shared+static-extension-module 'message-digest-basic (extension-version "3.2.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.1.1")
     84(setup-shared+static-extension-module 'message-digest (extension-version "3.2.0")
    8585  #:inline? #t
    8686        #:types? #t
Note: See TracChangeset for help on using the changeset viewer.