Changeset 18685 in project


Ignore:
Timestamp:
07/03/10 07:10:50 (10 years ago)
Author:
Kon Lovett
Message:

Use finalizer instead of wrapping all ops in a try/catch to ensure ctx free.

File:
1 edited

Legend:

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

    r18681 r18685  
    99;; - Uses 'context-info' to determine whether active context is "own" allocation or
    1010;; callers. Again, a kludge.
    11 ;;
    12 ;; - Should use u8vector instead of string.
    1311
    1412(module message-digest
     
    2119                message-digest-chunk-read-maker
    2220                message-digest-chunk-converter
    23                 ; Direct API
    24                 make-binary-message-digest
    25                 make-message-digest
    26                 ; OO API
     21                ; Algorithm API
    2722                make-message-digest-primitive
    2823                message-digest-primitive?
     24                check-message-digest-primitive
    2925                message-digest-primitive-name
    3026                message-digest-primitive-context-info
     
    3329                message-digest-primitive-update
    3430                message-digest-primitive-final
     31                ;
     32                open-message-digest
     33                message-digest?
     34                check-message-digest
     35                close-message-digest
     36                message-digest-update
     37                message-digest-update-string
     38                message-digest-update-blob
     39                message-digest-update-u8vector
     40                message-digest-update-u8
     41                message-digest-update-u16
     42                message-digest-update-u32
     43                message-digest-update-u64
     44                message-digest-update-procedure
     45                message-digest-update-port
     46                message-digest-update-file
     47                ;
     48                message-digest
     49                message-digest-string
     50                message-digest-blob
     51                message-digest-u8vector
     52                message-digest-file
     53                ; Old API
     54                make-binary-message-digest
     55                make-message-digest
    3556                message-digest-primitive-apply
    36                 ; Internals
    37                 check-message-digest-primitive
    38                 allocate-message-digest-context
    39                 free-message-digest-context)
     57                )
    4058
    4159  (import
     
    4563      (make-string make-byte-string))
    4664    (rename chicken
    47       (string->blob byte-string->blob) (blob->string blob->byte-string))
     65      (string->blob byte-string->blob)
     66      (blob->string blob->byte-string))
    4867    (only lolevel allocate free)
    4968    (only srfi-1 map! reverse!)
     
    6483    lolevel
    6584    srfi-1 srfi-4 srfi-13
    66     miscmacros type-checks type-errors)
     85    miscmacros
     86    srfi-4-checks type-checks type-errors)
    6787
    6888;;; Byte string utilities
     
    119139  (check-procedure loc final 'digest-finalizer) )
    120140
     141#| ;UNUSED
     142
    121143(define (allocate-message-digest-context ctx-info)
    122144  (if (procedure? ctx-info) (ctx-info)
     
    126148  (when (and ctx (number? ctx-info))
    127149    (free ctx) ) )
    128 
    129 (define (XXXvector->blob obj)
    130   (cond ((u8vector? obj)        (u8vector->blob/shared obj))
    131         ((s8vector? obj)        (s8vector->blob/shared obj))
    132         ((u16vector? obj)       (u16vector->blob/shared obj))
    133         ((s16vector? obj)       (s16vector->blob/shared obj))
    134         ((u32vector? obj)       (u32vector->blob/shared obj))
    135         ((s32vector? obj)       (s32vector->blob/shared obj))
    136         ((f32vector? obj)       (f32vector->blob/shared obj))
    137         ((f64vector? obj)       (f64vector->blob/shared obj))
    138         (else                   #f ) ) )
    139 
    140 (define-inline (chunk-convert src)
    141   (and-let* ((cnv (message-digest-chunk-converter))) (cnv src)) )
    142 
    143 (define (update/byte-source loc ctx src updt)
    144   (cond ((byte-string? src)   (updt ctx src (byte-string-length src)) )
    145         ((blob? src)          (updt ctx src (blob-size src)) )
    146         ((or (XXXvector->blob src)
    147              (chunk-convert src))
    148                               => (cut update/byte-source loc ctx <> updt) )
    149         (else
    150           (signal-type-error loc "indigestible object" src) ) ) )
    151 
    152 (define-inline (update-while/procedure loc ctx proc updt)
    153   (while* (proc) (update/byte-source loc ctx it updt) ) )
    154 
    155 (define-inline (chunk-reader-for-source src) ((message-digest-chunk-read-maker) src))
    156 
    157 (define-inline (update/any-source loc ctx src updt)
    158   (cond ((input-port? src)    (update-while/procedure loc ctx (chunk-reader-for-source src) updt) )
    159         ((procedure? src)     (update-while/procedure loc ctx src updt) )
    160         (else                 (update/byte-source loc ctx src updt) ) ) )
    161 
    162 ;;; Message Digest Algorithm API
    163 
    164 (define-record-type message-digest-primitive
    165         (*make-message-digest-primitive ctxi digest-len init update final name)
    166         message-digest-primitive?
    167         (ctxi message-digest-primitive-context-info)
    168         (digest-len message-digest-primitive-digest-length)
    169         (init message-digest-primitive-init)
    170         (update message-digest-primitive-update)
    171         (final message-digest-primitive-final)
    172         (name message-digest-primitive-name) )
    173 
    174 (define-check+error-type message-digest-primitive)
    175 
    176 (define (make-message-digest-primitive ctx-info digest-len init update final
    177                                        #!optional (name (gensym "mdp")))
    178   (check-message-digest-parameters 'make-message-digest-primitive
    179     ctx-info digest-len init update final)
    180   (*make-message-digest-primitive
    181     ctx-info
    182     digest-len
    183     init update final
    184     name) )
    185 
    186 ;;; Message Digest API
    187 
    188 (define-record-type message-digest
    189         (*make-message-digest mdp ctx)
    190         message-digest?
    191         (mdp message-digest-primitive)
    192         (ctx message-digest-context) )
    193 
    194 (define-check+error-type message-digest)
    195 
    196 (define (byte-string->u8vector bs) (blob->u8vector/shared (byte-string->blob bs)))
    197 
    198 (define (get-result-as-type loc res rt)
    199   (case rt
    200     ((string byte-string) res )
    201     ((hexstring hex)      (byte-string->hexadecimal res) )
    202     ((blob)               (byte-string->blob res) )
    203     ((u8vector)           (byte-string->u8vector res) )
    204     (else
    205       (signal-type-error loc (make-error-type-message 'result-type) rt) ) ) )
    206 
    207 (define-inline (free-md-ctx ctx mdp)
    208   (free-message-digest-context ctx (message-digest-primitive-context-info mdp)) )
    209150
    210151(define-syntax with-mpd-n-ctx
     
    231172              (,_lambda ()
    232173                ,@body))))) ) ) ) )
     174|#
     175
     176(define (allocate-message-digest-context ctx-info)
     177  (if (procedure? ctx-info) (ctx-info)
     178      (let ((mem (allocate ctx-info)))
     179        (set-finalizer! mem free)
     180        mem ) ) )
     181
     182(define-syntax with-mpd-n-ctx
     183  (er-macro-transformer
     184    (lambda (frm rnm cmp)
     185      (let ((_let* (rnm 'let*))
     186            (mdp-exp (cadr frm))
     187            (ctx-exp (caddr frm))
     188            (body (cdddr frm)) )
     189      `(,_let* ((mdp ,mdp-exp)
     190                (ctx ,ctx-exp) )
     191          ,@body ) ) ) ) )
     192
     193(define (XXXvector->blob obj)
     194  (cond ((u8vector? obj)        (u8vector->blob/shared obj))
     195        ((s8vector? obj)        (s8vector->blob/shared obj))
     196        ((u16vector? obj)       (u16vector->blob/shared obj))
     197        ((s16vector? obj)       (s16vector->blob/shared obj))
     198        ((u32vector? obj)       (u32vector->blob/shared obj))
     199        ((s32vector? obj)       (s32vector->blob/shared obj))
     200        ((f32vector? obj)       (f32vector->blob/shared obj))
     201        ((f64vector? obj)       (f64vector->blob/shared obj))
     202        (else                   #f ) ) )
     203
     204(define-inline (chunk-convert src)
     205  (and-let* ((cnv (message-digest-chunk-converter))) (cnv src)) )
     206
     207(define (update/byte-source loc ctx src updt)
     208  (cond ((byte-string? src)   (updt ctx src (byte-string-length src)) )
     209        ((blob? src)          (updt ctx src (blob-size src)) )
     210        ((or (XXXvector->blob src)
     211             (chunk-convert src))
     212                              => (cut update/byte-source loc ctx <> updt) )
     213        (else
     214          (signal-type-error loc "indigestible object" src) ) ) )
     215
     216(define-inline (update-while/procedure loc ctx proc updt)
     217  (while* (proc) (update/byte-source loc ctx it updt) ) )
     218
     219(define-inline (chunk-reader-for-source src) ((message-digest-chunk-read-maker) src))
     220
     221(define-inline (update/any-source loc ctx src updt)
     222  (cond ((input-port? src)    (update-while/procedure loc ctx (chunk-reader-for-source src) updt) )
     223        ((procedure? src)     (update-while/procedure loc ctx src updt) )
     224        (else                 (update/byte-source loc ctx src updt) ) ) )
     225
     226(define (byte-string->u8vector bs) (blob->u8vector/shared (byte-string->blob bs)))
     227
     228(define (get-result-as-type loc res rt)
     229  (case rt
     230    ((string byte-string) res )
     231    ((hexstring hex)      (byte-string->hexadecimal res) )
     232    ((blob)               (byte-string->blob res) )
     233    ((u8vector)           (byte-string->u8vector res) )
     234    (else
     235      (signal-type-error loc (make-error-type-message 'result-type) rt) ) ) )
     236
     237;;; Message Digest Algorithm API
     238
     239(define-record-type message-digest-primitive
     240        (*make-message-digest-primitive ctxi digest-len init update final name)
     241        message-digest-primitive?
     242        (ctxi message-digest-primitive-context-info)
     243        (digest-len message-digest-primitive-digest-length)
     244        (init message-digest-primitive-init)
     245        (update message-digest-primitive-update)
     246        (final message-digest-primitive-final)
     247        (name message-digest-primitive-name) )
     248
     249(define-check+error-type message-digest-primitive)
     250
     251(define (make-message-digest-primitive ctx-info digest-len init update final
     252                                       #!optional (name (gensym "mdp")))
     253  (check-message-digest-parameters 'make-message-digest-primitive
     254    ctx-info digest-len init update final)
     255  (*make-message-digest-primitive
     256    ctx-info
     257    digest-len
     258    init update final
     259    name) )
     260
     261;;; Message Digest API
     262
     263;;
     264
     265(define-record-type message-digest
     266        (*make-message-digest mdp ctx)
     267        message-digest?
     268        (mdp message-digest-primitive)
     269        (ctx message-digest-context) )
     270
     271(define-check+error-type message-digest)
    233272
    234273(define (open-message-digest mdp)
     
    245284    (let ((res (make-byte-string (message-digest-primitive-digest-length mdp))))
    246285      ((message-digest-primitive-final mdp) ctx res)
     286      (get-result-as-type loc res result-type)
     287      #; ;UNUSED
    247288      (let ((ret (get-result-as-type loc res result-type)))
    248         (free-md-ctx ctx mdp)
     289        (free-message-digest-context ctx (message-digest-primitive-context-info mdp))
    249290        ret ) ) ) )
    250291
     
    407448  (check-string 'message-digest-update-file src)
    408449  (let ((in (open-input-file src)))
    409     (with-mpd-n-ctx
    410         (message-digest-primitive md) (message-digest-context md)
    411       (update-while/procedure
    412         'message-digest-update-port
    413         ctx (default-chunk-read-maker in) (message-digest-primitive-update mdp)) ) ) )
     450    (handle-exceptions exn
     451        (begin (close-input-port in) (abort exn))
     452      (with-mpd-n-ctx
     453          (message-digest-primitive md) (message-digest-context md)
     454        (update-while/procedure
     455          'message-digest-update-port
     456          ctx (default-chunk-read-maker in) (message-digest-primitive-update mdp)) ) ) ) )
    414457
    415458;;; Till completion API
Note: See TracChangeset for help on using the changeset viewer.