Changeset 35341 in project
- Timestamp:
- 03/25/18 19:50:42 (3 years ago)
- Location:
- release/4/message-digest/trunk
- Files:
-
- 7 edited
Legend:
- Unmodified
- Added
- Removed
-
release/4/message-digest/trunk/message-digest-bv.scm
r35340 r35341 37 37 38 38 ;; 39 40 ;FIXME do not 'type' check-/error- procs 39 41 40 42 (define (check-blob/slice loc blb start end) … … 82 84 ;; Single Source API 83 85 84 (define: (message-digest-blob (mdp message-digest-primitive) (blb blob) . (opts list)) -> message-digest-result- form86 (define: (message-digest-blob (mdp message-digest-primitive) (blb blob) . (opts list)) -> message-digest-result-type 85 87 (let-optionals* opts ( 86 (res ult-type(message-digest-result-form))88 (restyp (message-digest-result-form)) 87 89 (start 0) 88 90 (end (blob-size blb)) ) … … 90 92 (md (initialize-message-digest mdp)) ) 91 93 (message-digest-update-blob md blb start end) 92 (finalize-message-digest md res ult-type) ) ) )94 (finalize-message-digest md restyp) ) ) ) 93 95 94 (define: (message-digest-string (mdp message-digest-primitive) (str string) . (opts list)) -> message-digest-result- form96 (define: (message-digest-string (mdp message-digest-primitive) (str string) . (opts list)) -> message-digest-result-type 95 97 (let-optionals* opts ( 96 (res ult-type(message-digest-result-form))98 (restyp (message-digest-result-form)) 97 99 (start 0) 98 100 (end (string-length str)) ) … … 100 102 (md (initialize-message-digest mdp)) ) 101 103 (message-digest-update-string md str start end) 102 (finalize-message-digest md res ult-type) ) ) )104 (finalize-message-digest md restyp) ) ) ) 103 105 104 (define: (message-digest-blob! (mdp message-digest-primitive) (blb blob) (buf message-digest-buffer) . (opts list)) -> message-digest-result- form106 (define: (message-digest-blob! (mdp message-digest-primitive) (blb blob) (buf message-digest-buffer) . (opts list)) -> message-digest-result-type 105 107 (let-optionals* opts ( 106 108 (start 0) … … 111 113 (finalize-message-digest! md buf) ) ) ) 112 114 113 (define: (message-digest-string! (mdp message-digest-primitive) (str string) (buf message-digest-buffer) . (opts list)) -> message-digest-result- form115 (define: (message-digest-string! (mdp message-digest-primitive) (str string) (buf message-digest-buffer) . (opts list)) -> message-digest-result-type 114 116 (let-optionals* opts ( 115 117 (start 0) -
release/4/message-digest/trunk/message-digest-int.scm
r35339 r35341 44 44 ;; 45 45 46 (define: (get-byte-order (loc symbol) (obj *)) --> symbol46 (define: (get-byte-order (loc symbol) (obj *)) --> message-digest-byte-order 47 47 (case obj 48 48 ((big-endian be big msb) 'big-endian ) … … 109 109 ;; Machine Byte Order w/ Char & Unsigned Integer 110 110 111 (define: (message-digest-update-char (md message-digest) (ch char) . (opts (list -of symbol))) -> void111 (define: (message-digest-update-char (md message-digest) (ch char) . (opts (list message-digest-byte-order))) -> void 112 112 (let ( 113 113 (order (optional opts (machine-byte-order))) ) … … 116 116 ((big-endian) (message-digest-update-char-be md ch) ) ) ) ) 117 117 118 (define: (message-digest-update-u16 (md message-digest) (n number) . (opts (list -of symbol))) -> void118 (define: (message-digest-update-u16 (md message-digest) (n number) . (opts (list message-digest-byte-order))) -> void 119 119 (let ( 120 120 (order (optional opts (machine-byte-order))) ) … … 123 123 ((big-endian) (message-digest-update-u16-be md n) ) ) ) ) 124 124 125 (define: (message-digest-update-u32 (md message-digest) (n number) . (opts (list -of symbol))) -> void125 (define: (message-digest-update-u32 (md message-digest) (n number) . (opts (list message-digest-byte-order))) -> void 126 126 (let ( 127 127 (order (optional opts (machine-byte-order))) ) … … 130 130 ((big-endian) (message-digest-update-u32-be md n) ) ) ) ) 131 131 132 (define: (message-digest-update-u64 (md message-digest) (n number) . (opts (list -of symbol))) -> void132 (define: (message-digest-update-u64 (md message-digest) (n number) . (opts (list message-digest-byte-order))) -> void 133 133 (let ( 134 134 (order (optional opts (machine-byte-order))) ) -
release/4/message-digest/trunk/message-digest-item.scm
r35339 r35341 35 35 ;; 36 36 37 (define: (message-digest-object (mdp message-digest-primitive) (obj *) . (opts list)) -> message-digest-result- form37 (define: (message-digest-object (mdp message-digest-primitive) (obj *) . (opts list)) -> message-digest-result-type 38 38 (let-optionals* opts ( 39 (res ult-type(message-digest-result-form))39 (restyp (message-digest-result-form)) 40 40 (start 0) 41 41 (end #f) ) 42 42 (let ((md (initialize-message-digest mdp))) 43 43 (message-digest-update-object md obj start end) 44 (finalize-message-digest md res ult-type) ) ) )44 (finalize-message-digest md restyp) ) ) ) 45 45 46 (define: (message-digest-file (mdp message-digest-primitive) (flnm pathname) . (opts list)) -> message-digest-result- form47 (let *(48 (res ult-type(message-digest-result-form))46 (define: (message-digest-file (mdp message-digest-primitive) (flnm pathname) . (opts list)) -> message-digest-result-type 47 (let ( 48 (restyp (message-digest-result-form)) 49 49 (md (initialize-message-digest mdp)) ) 50 50 (message-digest-update-file md flnm) 51 (finalize-message-digest md res ult-type) ) )51 (finalize-message-digest md restyp) ) ) 52 52 53 (define: (message-digest-port (mdp message-digest-primitive) (port output-port) . (opts list)) -> message-digest-result- form54 (let *(55 (res ult-type(message-digest-result-form))53 (define: (message-digest-port (mdp message-digest-primitive) (port output-port) . (opts list)) -> message-digest-result-type 54 (let ( 55 (restyp (message-digest-result-form)) 56 56 (md (initialize-message-digest mdp)) ) 57 57 (message-digest-update-port md port) 58 (finalize-message-digest md res ult-type) ) )58 (finalize-message-digest md restyp) ) ) 59 59 60 60 ;; 61 61 62 (define: (message-digest-object! (mdp message-digest-primitive) (obj *) (buf message-digest-buffer) . (opts list)) -> message-digest-result- form62 (define: (message-digest-object! (mdp message-digest-primitive) (obj *) (buf message-digest-buffer) . (opts list)) -> message-digest-result-type 63 63 (let-optionals* opts ( 64 64 (start 0) … … 69 69 (finalize-message-digest! md buf) ) ) ) 70 70 71 (define: (message-digest-file! (mdp message-digest-primitive) (flnm pathname) (buf message-digest-buffer)) -> message-digest-result- form71 (define: (message-digest-file! (mdp message-digest-primitive) (flnm pathname) (buf message-digest-buffer)) -> message-digest-result-type 72 72 (let ( 73 73 (md (initialize-message-digest mdp)) ) … … 75 75 (finalize-message-digest! md buf) ) ) 76 76 77 (define: (message-digest-port! (mdp message-digest-primitive) (port output-port) (buf message-digest-buffer)) -> message-digest-result-form 78 (let ((md (initialize-message-digest mdp))) 77 (define: (message-digest-port! (mdp message-digest-primitive) (port output-port) (buf message-digest-buffer)) -> message-digest-result-type 78 (let ( 79 (md (initialize-message-digest mdp)) ) 79 80 (message-digest-update-port md port) 80 81 (finalize-message-digest! md buf) ) ) -
release/4/message-digest/trunk/message-digest-port.scm
r35340 r35341 31 31 32 32 (declare 33 (bound-to-procedure ##sys#slot ##sys#setslot)) 33 (bound-to-procedure 34 ##sys#slot ##sys#setslot)) 34 35 35 36 ;;; Support … … 38 39 39 40 (include "message-digest-types") 41 42 ;; 43 44 (define PORT-TAG 'digest) 45 46 (define PRIMITIVE-NAME-SUFFIXES '("p" "-primitive")) 40 47 41 48 ;; … … 53 60 (##sys#setslot p 3 s) ) 54 61 62 ;; 63 55 64 (define (check-open-port loc obj #!optional argnam) 56 65 (if (port-closed? obj) … … 61 70 (let ( 62 71 (pt (%port-type (check-open-port loc (check-output-port loc obj argnam) argnam))) ) 63 (unless (eq? 'digestpt)72 (unless (eq? PORT-TAG pt) 64 73 (signal-type-error loc (make-error-type-message 'digest-output-port) obj argnam) ) ) 65 74 obj ) 66 75 67 76 ;Synthesize a port-name from a primitive-name 68 (define (make-digest-port-name mdp)77 (define: (make-digest-port-name (mdp message-digest-primitive)) --> string 69 78 (let* ( 70 (nam (->string (or (message-digest-primitive-name mdp) 'md))) 79 (nam 80 (->string (or (message-digest-primitive-name mdp) 'md))) 71 81 ;strip trailing (why ?) 72 (remlen (string-suffix-length-ci nam "-primitive")) 73 (remlen (if (fxpositive? remlen) remlen (string-suffix-length-ci nam "p"))) ) 74 (string-append 75 "(" 76 (if (fxpositive? remlen) 77 (substring nam 0 (fx- (string-length nam) remlen)) 78 nam ) 79 ")") ) ) 82 (remlen 83 ;longest suffix length or negative 84 (foldl 85 (lambda (remlen suf) 86 (fxmax remlen (string-suffix-length-ci nam suf)) ) 87 -1 88 PRIMITIVE-NAME-SUFFIXES)) 89 (nam 90 (if (fxpositive? remlen) 91 (substring nam 0 (fx- (string-length nam) remlen)) 92 nam)) ) 93 (string-append "(" nam ")") ) ) 80 94 81 95 ;;; Message Digest Output Port API 82 96 83 ;; Returns a digest-output-port for the MDP 84 85 (define (open-output-digest mdp) 97 (define: (open-output-digest (mdp message-digest-primitive)) -> digest-output-port 86 98 (let* ( 87 99 (md … … 89 101 (writer 90 102 (lambda (obj) 91 ; it will only ever be a string for now103 ;for now only a string 92 104 (if (string? obj) 93 105 (message-digest-update-string md obj) … … 97 109 (make-output-port writer void)) ) 98 110 (##sys#set-port-data! port md) 99 (%port-type-set! port 'digest)111 (%port-type-set! port PORT-TAG) 100 112 (%port-name-set! port (make-digest-port-name mdp)) 101 113 port ) ) 102 114 115 (: digest-output-port? (* -> boolean : digest-output-port)) 116 ; 103 117 (define (digest-output-port? obj) 104 118 (and 105 119 (output-port? obj) 106 (eq? 'digest(%port-type obj)) ) )120 (eq? PORT-TAG (%port-type obj)) ) ) 107 121 108 122 (define-check+error-type digest-output-port) 109 123 110 (define (digest-output-port-name p) 111 (%port-name (check-digest-output-port 'digest-output-port-name p)) ) 124 (define: (digest-output-port-name (port digest-output-port)) -> string 125 (%port-name 126 (check-digest-output-port 'digest-output-port-name port)) ) 112 127 113 ;; Finalizes the digest-output-port and returns the result in the form requested 114 115 (define (*close-output-digest loc digest-port result-type) 128 (define: (*close-output-digest (loc symbol) (port digest-output-port) (restyp message-digest-result-form)) -> message-digest-result-type 116 129 (let ( 117 130 (res 118 131 (finalize-message-digest 119 (##sys#port-data (check-open-digest-output-port loc digest-port 'digest-port)) 120 result-type)) ) 121 (close-output-port digest-port) 132 (##sys#port-data 133 (check-open-digest-output-port loc port 'digest-port)) 134 restyp)) ) 135 (close-output-port port) 122 136 res ) ) 123 137 124 (define (get-output-digest digest-port #!optional (result-type (message-digest-result-form))) 125 (*close-output-digest 'get-output-digest digest-port result-type) ) 138 (define: (get-output-digest (port digest-output-port) . (opts (list message-digest-result-type))) -> message-digest-result-type 139 (let ( 140 (restyp (optional opts (message-digest-result-form))) ) 141 (*close-output-digest 'get-output-digest port restyp) ) ) 126 142 127 143 ;;; 128 144 129 ;; Calls the procedure PROC with a single argument that is a digest-output-port for the MDP. 130 ;; Returns the accumulated output string | blob | u8vector | hexstring 131 132 (define (call-with-output-digest mdp proc #!optional (result-type (message-digest-result-form))) 145 (define: (call-with-output-digest (mdp message-digest-primitive) (proc procedure) . (opts (list message-digest-result-type))) -> message-digest-result-type 133 146 (let ( 147 (restyp (optional opts (message-digest-result-form))) 134 148 (port (open-output-digest mdp)) ) 135 149 (proc port) 136 (*close-output-digest 'call-with-output-digest port res ult-type) ) )150 (*close-output-digest 'call-with-output-digest port restyp) ) ) 137 151 138 ;; Calls the procedure THUNK with the current-input-port temporarily bound to a 139 ;; digest-output-port for the MDP. 140 ;; Returns the accumulated output string | blob | u8vector | hexstring 141 142 (define (with-output-to-digest mdp thunk #!optional (result-type (message-digest-result-form))) 143 (call-with-output-digest mdp (cut with-input-from-port <> thunk) result-type) ) 152 (define: (with-output-to-digest (mdp message-digest-primitive) (thunk procedure) . (opts (list message-digest-result-type))) -> message-digest-result-type 153 (let ( 154 (restyp (optional opts (message-digest-result-form))) ) 155 (call-with-output-digest mdp (cut with-input-from-port <> thunk) restyp) ) ) 144 156 145 157 ) ;module message-digest -
release/4/message-digest/trunk/message-digest-srfi-4.scm
r35339 r35341 64 64 ;;; Single Source API 65 65 66 (define: (message-digest-u8vector (mdp message-digest-primitive) (u8vec u8vector) . (opts list)) -> message-digest-result- form66 (define: (message-digest-u8vector (mdp message-digest-primitive) (u8vec u8vector) . (opts list)) -> message-digest-result-type 67 67 (let-optionals* opts ( 68 (res ult-type(message-digest-result-form))68 (restyp (message-digest-result-form)) 69 69 (start 0) 70 70 (end (u8vector-length u8vec)) ) 71 71 (let ((md (initialize-message-digest mdp))) 72 72 (message-digest-update-u8vector md u8vec start end) 73 (finalize-message-digest md res ult-type) ) ) )73 (finalize-message-digest md restyp) ) ) ) 74 74 75 (define: (message-digest-u8vector! (mdp message-digest-primitive) (u8vec u8vector) (buffer message-digest-buffer) . (opts list)) -> message-digest-result- form75 (define: (message-digest-u8vector! (mdp message-digest-primitive) (u8vec u8vector) (buffer message-digest-buffer) . (opts list)) -> message-digest-result-type 76 76 (let-optionals* opts ( 77 77 (start 0) … … 89 89 (: message-digest-update-packed-vector deprecated) 90 90 (define (message-digest-update-packed-vector md pkdvec) 91 (let ((blb (packed-vector->blob/shared pkdvec))) 91 (let ( 92 (blb (packed-vector->blob/shared pkdvec)) ) 92 93 (if blb 93 94 (message-digest-update-blob md blb) … … 97 98 (define (message-digest-update-bytevector md bv #!optional (len (number-of-bytes bv))) 98 99 (check-message-digest 'message-digest-update-bytevector md) 99 (let ((mdp (message-digest-algorithm md)) 100 (ctx (message-digest-context md)) ) 100 (let ( 101 (mdp (message-digest-algorithm md)) 102 (ctx (message-digest-context md)) ) 101 103 ((message-digest-primitive-update mdp) 102 104 ctx -
release/4/message-digest/trunk/message-digest-type.scm
r35339 r35341 60 60 ;assumes blob 'res' may not be of result size 61 61 62 (define: (get-result-form (loc symbol) (res blob) (r t symbol)) -> message-digest-result-form63 (case (canonical-result-name r t)62 (define: (get-result-form (loc symbol) (res blob) (restyp message-digest-result-form)) -> message-digest-result-type 63 (case (canonical-result-name restyp) 64 64 ((blob) res ) 65 65 ((byte-string) (blob->string res) ) … … 67 67 ((u8vector) (blob->u8vector/shared res) ) 68 68 (else 69 (error-result-form loc r t) ) ) )69 (error-result-form loc restyp) ) ) ) 70 70 71 71 #; 72 (define: (get-result-form (loc symbol) (res blob) (r t symbol)) -> message-digest-result-form73 (case r t72 (define: (get-result-form (loc symbol) (res blob) (restyp message-digest-result-form)) -> message-digest-result-type 73 (case restyp 74 74 ((blob) 75 75 (if (fx= len (blob-size res)) res … … 86 86 (subu8vector vec 0 len) ) ) ) 87 87 (else 88 (error-result-form loc r t) ) ) )89 90 (define: (canonical-result-name (x symbol)) -> (or boolean symbol)88 (error-result-form loc restyp) ) ) ) 89 90 (define: (canonical-result-name (x message-digest-result-form)) -> (or boolean message-digest-result-form) 91 91 (case x 92 92 ((blob) 'blob ) … … 97 97 #f ) ) ) 98 98 99 (define: (check-result-type (loc symbol) (mdp message-digest-primitive) (obj message-digest-result- form)) -> message-digest-result-form99 (define: (check-result-type (loc symbol) (mdp message-digest-primitive) (obj message-digest-result-type)) -> message-digest-result-type 100 100 (let ( 101 101 (siz … … 119 119 ;; 120 120 121 (: message-digest-result-form (#!optional symbol -> symbol))121 (: message-digest-result-form (#!optional message-digest-result-form -> message-digest-result-form)) 122 122 ; 123 123 (define-parameter message-digest-result-form #;DEFAULT-RESULT-TYPE 'hex-string … … 162 162 ;; 163 163 164 (define: (finalize-message-digest (md message-digest) . (opts (list -of message-digest-result-form))) -> message-digest-result-form164 (define: (finalize-message-digest (md message-digest) . (opts (list message-digest-result-type))) -> message-digest-result-type 165 165 (let* ( 166 (result-type 167 (optional opts (message-digest-result-form))) 168 (mdp 169 (message-digest-algorithm (check-message-digest 'finalize-message-digest md))) 170 (res 171 (make-blob (message-digest-primitive-digest-length mdp))) ) 166 (restyp (optional opts (message-digest-result-form))) 167 (mdp (message-digest-algorithm (check-message-digest 'finalize-message-digest md))) 168 (res (make-blob (message-digest-primitive-digest-length mdp))) ) 172 169 ;side-effects res 173 170 ((message-digest-primitive-final mdp) (message-digest-context md) res) 174 (get-result-form 'finalize-message-digest res res ult-type) ) )175 176 (define: (finalize-message-digest! (md message-digest) (result-buffer message-digest-buffer)) -> message-digest-result- form171 (get-result-form 'finalize-message-digest res restyp) ) ) 172 173 (define: (finalize-message-digest! (md message-digest) (result-buffer message-digest-buffer)) -> message-digest-result-type 177 174 (let* ( 178 175 (mdp … … 192 189 (sz (fxmax sz MINIMUM-BUFFER-SIZE)) ) 193 190 ;enough space? then reuse, otherwise new buffer 194 (if buf (print "buf " buf))195 191 (if (and buf (fx<= sz (number-of-bytes buf))) 196 192 buf -
release/4/message-digest/trunk/message-digest-types.scm
r35339 r35341 9 9 (define-type pathname string) 10 10 11 (define-type srfi4vector (or u8vector s8vector u16vector s16vector u32vector s32vector f32vector f64vector)) 11 (define-type srfi4vector 12 (or u8vector s8vector u16vector s16vector u32vector s32vector f32vector f64vector)) 12 13 13 ;(define-type message-digest-buffer (or string blob srfi4vector procedure input-port pointer)) 14 #; ;desired, bufpointer is (pointer + length) 15 (define-type message-digest-buffer 16 (or string blob srfi4vector procedure input-port bufpointer)) 14 17 (define-type message-digest-buffer (or string blob u8vector)) 15 18 16 (define-type message-digest-result-form (or string blob u8vector)) 19 (define-type message-digest-byte-order symbol) 20 21 (define-type message-digest-result-form symbol) 22 23 (define-type message-digest-result-type (or string blob u8vector)) 17 24 18 25 (define-type message-digest-buffer (or string blob u8vector)) … … 23 30 24 31 (define-type message-digest (struct message-digest)) 32 33 (define-type digest-output-port output-port)
Note: See TracChangeset
for help on using the changeset viewer.