Changeset 18790 in project


Ignore:
Timestamp:
07/10/10 23:51:45 (10 years ago)
Author:
Kon Lovett
Message:

Rewrote string to hex in terms of sys namespace routines. Fixes for syntax errors.

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

Legend:

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

    r18775 r18790  
    22;;;; Kon Lovett, May '10
    33
    4 ;; Issues
    5 ;;
    6 ;; - No endian support
    7 ;;
    8 ;; - No extensible result conversion
     4(module message-digest-port
    95
    10 (module message-digest-port
    116        (;export
    127    open-output-digest
    138    close-output-digest
    14     get-output-digest-byte-string
     9    get-output-digest-string
    1510    get-output-digest-hexstring
    1611    get-output-digest-blob
     
    1914    with-output-to-digest)
    2015
    21   (import (rename scheme
    22             (string? byte-string?)
    23             (string-length byte-string-length)
    24             (list->string list->byte-string)
    25             (make-string make-byte-string))
    26           (except scheme string->list string-copy)
    27           (rename chicken (string->blob byte-string->blob))
    28           (only data-structures ->string)
    29           (only lolevel allocate free)
    30           (only srfi-1 map! reverse!)
    31           srfi-4
    32           (only srfi-13
    33             string-suffix-length-ci?
    34             substring/shared string-for-each
    35             string->list string-copy string-concatenate)
    36           (rename srfi-13
    37             (substring/shared byte-substring/shared)
    38             (string-for-each byte-string-for-each)
    39             (string->list byte-string->list)
    40             (string-copy byte-string-copy))
    41           (only srfi-69 hash)
    42           (only miscmacros while* define-parameter)
    43           (only type-checks
    44             define-check+error-type
    45             check-positive-integer check-procedure)
    46           (only type-errors
    47             make-error-type-message
    48             warning-argument-type signal-type-error))
     16  (import
     17    scheme
     18    chicken
     19    (only data-structures ->string)
     20    (only ports make-output-port)
     21    (only srfi-13 string-suffix-length-ci)
     22    (only type-errors make-error-type-message signal-type-error)
     23    (only message-digest
     24      begin-message-digest end-message-digest
     25      message-digest-update-string message-digest-primitive-name))
    4926
    50   (require-library
    51     data-structures lolevel srfi-1 srfi-4 srfi-13 srfi-69
    52     miscmacros
    53     type-checks type-errors)
    54 
    55 ;;;
    56 
    57 (define blob->byte-string blob->string)
    58 
    59 (define byte-string->blob string->blob)
    60 
    61 (define (byte-string->u8vector bs) (blob->u8vector/shared (byte-string->blob bs)))
     27  (require-library data-structures ports srfi-13 type-errors message-digest)
    6228
    6329;;; Message Digest Output Port API
    64 
    65 ;NOTE
    66 ; - Use of port data field is problematic!
    67 ; - Use of close is problematic!
    68 ; - The deallocation requirement for "own" context is a pain
    6930
    7031;
     
    7637    (signal-type-error loc (make-error-type-message 'digest-output-port) obj) ) )
    7738
    78 ;
     39; Synthesize a port-name from a primitive-name
    7940
    8041(define (make-digest-port-name mdp)
    8142  (let ((nam (->string (or (message-digest-primitive-name mdp) 'digest))))
    82     (let ((remlen (string-suffix-length-ci? nam "-primitive")))
     43    (let ((remlen (string-suffix-length-ci nam "-primitive")))
    8344      (string-append
    8445        "("
     
    9253(define (open-output-digest mdp)
    9354  (let* ((md (begin-message-digest mdp))
    94          (writer (lambda (str) (message-digest-update-string md str)))
     55         (writer (cut message-digest-update-string md <>))
    9556         (port (make-output-port writer void #f)) )
    9657    (##sys#set-port-data! port md)
     
    10162;; Finalizes the digest-output-port and returns the result in the form requested
    10263
    103 (define (close-output-digest digest-port #optional (result-type 'hex) (loc 'close-output-digest))
     64(define (close-output-digest digest-port #!optional (result-type 'hex) (loc 'close-output-digest))
    10465  (check-digest-output-port loc digest-port)
    105   (end-message-digest (##sys#port-data port) result-type) )
     66  (end-message-digest (##sys#port-data digest-port) result-type) )
    10667
    10768;; Finalizes the digest-output-port and returns the result as a byte-string
    10869
    109 (define (get-output-digest-byte-string digest-port)
    110   (close-output-digest digest-port 'string 'get-output-digest-byte-string) )
     70(define (get-output-digest-string digest-port)
     71  (close-output-digest digest-port 'string 'get-output-digest-string) )
    11172
    112 (define get-output-digest-string get-output-digest-byte-string)
     73(define get-output-digest-byte-string get-output-digest-string)
    11374
    11475;; Finalizes the digest-output-port and returns the result as a hexstring
     
    13293;; Returns the accumulated output string | blob | u8vector | hexstring
    13394
    134 (define (call-with-output-digest mdp proc #optional (result-type 'hex))
     95(define (call-with-output-digest mdp proc #!optional (result-type 'hex))
    13596  (let ((port (open-output-digest mdp)))
    136     (handle-exceptions exn
    137         (begin (close port) (signal exn))
    138       (proc port) )
     97    (proc port)
    13998    (close-output-digest port result-type) ) )
    14099
     
    143102;; Returns the accumulated output string | blob | u8vector | hexstring
    144103
    145 (define (with-output-to-digest mdp thunk #optional (result-type 'hex))
     104(define (with-output-to-digest mdp thunk #!optional (result-type 'hex))
    146105  (fluid-let ((##sys#standard-output (open-output-digest mdp)))
    147     (handle-exceptions exn
    148         (begin (close port) (signal exn))
    149       (thunk) )
    150     (close-output-digest port result-type) ) )
     106    (thunk)
     107    (close-output-digest ##sys#standard-output result-type) ) )
    151108
    152109) ;module message-digest
  • release/4/message-digest/trunk/message-digest.scm

    r18776 r18790  
    66;; - Renames the bindings of some string procedures to emphasize byte orientation.
    77;; This is a real kludge & NOT future-proof.
     8;;
     9;; - Use of 'sys namespace procedures.
    810;;
    911;; - Uses 'context-info' to determine whether active context is "own" allocation or
     
    5557
    5658  (import
    57     (rename (except scheme string->list)
    58       (string? byte-string?)
    59       (string-length byte-string-length)
    60       (make-string make-byte-string))
    61     (rename chicken
    62       (string->blob byte-string->blob)
    63       (blob->string blob->byte-string))
     59    scheme
     60    (rename chicken (string->blob byte-string->blob))
     61    foreign
    6462    (only lolevel allocate free)
    65     (only srfi-1 map! reverse!)
    6663    srfi-4
    67     (rename (only srfi-13 string->list string-concatenate)
    68       string->list byte-string->list)
    6964    (only miscmacros while* define-parameter)
    7065    (only type-checks
    7166      define-check+error-type
    72       check-positive-integer check-procedure)
    73     (only srfi-4-checks
    74       check-u8vector)
     67      check-integer check-positive-integer
     68      check-blob check-string
     69      check-input-port check-procedure)
     70    (only srfi-4-checks check-u8vector)
    7571    (only type-errors
    7672      make-error-type-message
     
    7874
    7975  (require-library
    80     lolevel
    81     srfi-1 srfi-4 srfi-13
     76    lolevel srfi-4
    8277    miscmacros
    8378    srfi-4-checks type-checks type-errors)
     
    8580;;; Byte string utilities
    8681
    87 (define (byte-string->hexadecimal str #!optional (start 0) (end (byte-string-length str)))
    88   (define (byte-char->hex ch)
    89     (let* ((int (char->integer ch))
    90            (str (number->string int 16)))
    91       (if (< int 16) (string-append "0" str) str) ) )
    92   (string-concatenate (map! byte-char->hex (byte-string->list str start end))) )
     82(define (##sys#string? x) (##core#inline "C_i_stringp" x))
     83(define (##sys#setchar s i c) (##core#inline "C_setsubchar" s i c))
     84
     85(define make-byte-string ##sys#make-string)
     86(define byte-string-length ##sys#size)
     87(define byte-string? ##sys#string?)
     88
     89(define string->hex
     90  (let ((digits '#(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\A #\B #\C #\D #\E #\F)))
     91    (lambda (str #!optional (start 0) (end #f))
     92      (##sys#check-string str 'string->hex)
     93      (let ((end (or end (##sys#size str))))
     94        (unless (fx<= start end)
     95          (##sys#signal-hook #:bounds-error 'string->hex
     96                             ;"out of range"
     97                             "illegal substring specification" start end))
     98        (let ((res (##sys#make-string (fx* (fx- end start) 2))))
     99          (do ((i start (fx+ i 1))
     100               (j 0 (fx+ j 2)) )
     101              ((fx>= i end) res)
     102            (let ((byte (##sys#byte str i)))
     103              (##sys#setchar res j (vector-ref digits (fxand (fxshr byte 4) #xf)))
     104              (##sys#setchar res (fx+ j 1) (vector-ref digits (fxand byte #xf))) ) ) ) ) ) ) )
     105
     106(define byte-string->hexadecimal string->hex)
    93107
    94108;;; Message DIgest Parameters
     
    127141;;; Helpers
    128142
    129 (define (check-message-digest-parameters loc ctx-info digest-len init update final)
     143(define-inline (check-message-digest-arguments loc ctx-info digest-len init update final)
    130144  (unless (or (procedure? ctx-info)
    131145              (and (integer? ctx-info) (positive? ctx-info)))
     
    136150  (check-procedure loc final 'digest-finalizer) )
    137151
    138 (define-inline (allocate-message-digest-context ctx-info)
     152(define-inline (get-message-digest-context ctx-info)
    139153  (if (procedure? ctx-info) (ctx-info)
    140154      (let ((mem (allocate ctx-info)))
     
    211225(define (make-message-digest-primitive ctx-info digest-len init update final
    212226                                       #!optional (name (gensym "mdp")))
    213   (check-message-digest-parameters 'make-message-digest-primitive
     227  (check-message-digest-arguments 'make-message-digest-primitive
    214228    ctx-info digest-len init update final)
    215229  (*make-message-digest-primitive
     
    233247(define (begin-message-digest mdp)
    234248  (check-message-digest-primitive 'begin-message-digest mdp)
    235   (let ((ctx (allocate-message-digest-context (message-digest-primitive-context-info mdp))))
     249  (let ((ctx (get-message-digest-context (message-digest-primitive-context-info mdp))))
    236250    ((message-digest-primitive-init mdp) ctx)
    237251    (*make-message-digest mdp ctx) ) )
    238252
    239 (define (end-message-digest md #optional (result-type 'hex))
     253(define (end-message-digest md #!optional (result-type 'hex))
    240254  (check-message-digest 'end-message-digest md)
    241255  (let ((mdp (message-digest-primitive md))
     
    243257    (let ((res (make-byte-string (message-digest-primitive-digest-length mdp))))
    244258      ((message-digest-primitive-final mdp) ctx res)
    245       (get-result-as-type loc res result-type) ) ) )
     259      (get-result-as-type 'end-message-digest res result-type) ) ) )
    246260
    247261(define (message-digest-update-object md src)
     
    455469;;; Till completion API
    456470
    457 (define (message-digest-object mdp src #optional (result-type 'hex))
     471(define (message-digest-object mdp src #!optional (result-type 'hex))
    458472  (let ((md (begin-message-digest mdp)))
    459473    (message-digest-update-object md src)
    460474    (end-message-digest md result-type) ) )
    461475
    462 (define (message-digest-string mdp src #optional (result-type 'hex))
     476(define (message-digest-string mdp src #!optional (result-type 'hex))
    463477  (let ((md (begin-message-digest mdp)))
    464478    (message-digest-update-string md src)
    465479    (end-message-digest md result-type) ) )
    466480
    467 (define (message-digest-blob mdp src #optional (result-type 'hex))
     481(define (message-digest-blob mdp src #!optional (result-type 'hex))
    468482  (let ((md (begin-message-digest mdp)))
    469483    (message-digest-update-blob md src)
    470484    (end-message-digest md result-type) ) )
    471485
    472 (define (message-digest-u8vector mdp src #optional (result-type 'hex))
     486(define (message-digest-u8vector mdp src #!optional (result-type 'hex))
    473487  (let ((md (begin-message-digest mdp)))
    474488    (message-digest-update-u8vector md src)
    475489    (end-message-digest md result-type) ) )
    476490
    477 (define (message-digest-file mdp src #optional (result-type 'hex))
     491(define (message-digest-file mdp src #!optional (result-type 'hex))
    478492  (let ((md (begin-message-digest mdp)))
    479493    (message-digest-update-file md src)
  • release/4/message-digest/trunk/tests/run.scm

    r15593 r18790  
    1414(test-group "Message Digest Aux"
    1515
    16         (test '("foo" "bar" "baz") (byte-string->substring-list "foobarbaz" 3))
    17         (test '("oob" "arb" "az") (byte-string->substring-list "foobarbaz" 3 1))
    1816        (test "6162206364" (byte-string->hexadecimal "ab cd"))
    1917)
Note: See TracChangeset for help on using the changeset viewer.