1 ;;;; This file implements The MD5 Message-Digest Algorithm, as defined in
2 ;;;; RFC 1321 by R. Rivest, published April 1992.
4 ;;;; It was originally written by Pierre R. Mai, with copious input
5 ;;;; from the cmucl-help mailing-list hosted at cons.org, in November
6 ;;;; 2001 and has been placed into the public domain. In the meantime
7 ;;;; various fixes and improvements for other implementations as well
8 ;;;; as maintenance have been provided by Christophe Rhodes, Alexey
9 ;;;; Dejneka, Nathan Froyd, Andreas Fuchs, John Desoi, Dmitriy Ivanov,
10 ;;;; and Kevin M. Rosenberg, and have been reintegrated into this
11 ;;;; consolidated version by Pierre R. Mai.
13 ;;;; WARNING: The MD5 Message-Digest Algorithm has been compromised as
14 ;;;; a cryptographically secure hash for some time, with known
15 ;;;; theoretical and practical attacks. Therefore use of this
16 ;;;; implemenation is only recommended for legacy uses or uses which
17 ;;;; do not require a cryptographically secure hash. Use one of the
18 ;;;; newer SHA-2 and SHA-3 secure hash standards, or whatever is
19 ;;;; currently deemed cryptographically secure for all other uses.
21 ;;;; $Id: 05ed5d97f2c1822c4fcb0b041f8c3a0746a962ad $
23 ;;;; While the implementation should work on all conforming Common
24 ;;;; Lisp implementations, it has originally been optimized for CMU
25 ;;;; CL, where it achieved comparable performance to the standard
26 ;;;; md5sum utility (within a factor of 1.5 or less on iA32 and
27 ;;;; UltraSparc hardware).
29 ;;;; Currently, this implementation has also been optimized for SBCL
32 ;;;; Since the implementation makes heavy use of arithmetic on
33 ;;;; (unsigned-byte 32) numbers, acceptable performance is likely only
34 ;;;; on CL implementations that support unboxed arithmetic on such
35 ;;;; numbers in some form. This should include most 64bit CL
36 ;;;; implementations. For other CL implementations a 16bit
37 ;;;; implementation of MD5 is probably more suitable.
39 ;;;; The code implements correct operation for files/sequences of
40 ;;;; unbounded size as is, at the cost of having to do a single
41 ;;;; generic integer addition for each call to update-md5-state. If
42 ;;;; you call update-md5-state frequently with little data, this can
43 ;;;; pose a performance problem. If you can live with a size
44 ;;;; restriction of 512 MB, then you can enable fast fixnum arithmetic
45 ;;;; by putting :md5-small-length onto *features* prior to compiling
48 ;;;; Testing code can be compiled by including :md5-testing on
49 ;;;; *features* prior to compilation. In that case evaluating
50 ;;;; (md5::test-rfc1321) will run all the test-cases present in
51 ;;;; Appendix A.5 of RFC 1321 and report on the results.
52 ;;;; Evaluating (md5::test-other) will run further test-cases
53 ;;;; gathered by the author to cover regressions, etc.
55 ;;;; This software is "as is", and has no warranty of any kind. The
56 ;;;; authors assume no responsibility for the consequences of any use
57 ;;;; of this software.
59 (defpackage :SB-MD5
(:use
:CL
)
61 ;; Low-Level types and functions
62 #:md5-regs
#:initial-md5-regs
#:md5regs-digest
63 #:update-md5-block
#:fill-block
#:fill-block-ub8
#:fill-block-char
64 ;; Mid-Level types and functions
65 #:md5-state
#:md5-state-p
#:make-md5-state
66 #:update-md5-state
#:finalize-md5-state
67 ;; High-Level functions on sequences, streams and files
68 #:md5sum-sequence
#:md5sum-string
#:md5sum-stream
#:md5sum-file
))
73 (eval-when (:compile-toplevel
)
74 (defparameter *old-expansion-limit
* ext
:*inline-expansion-limit
*)
75 (setq ext
:*inline-expansion-limit
* (max ext
:*inline-expansion-limit
* 1000)))
78 (eval-when (:compile-toplevel
:execute
)
79 (defparameter *old-features
* *features
*)
80 (pushnew (c:backend-byte-order c
:*target-backend
*) *features
*))
83 (eval-when (:compile-toplevel
:execute
)
84 (defparameter *old-features
* *features
*)
85 (pushnew sb-c
:*backend-byte-order
* *features
*))
87 #+(and :lispworks
(or (not :lispworks4
) :lispworks4.4
))
88 (eval-when (:compile-toplevel
:execute
)
89 (defparameter *old-features
* *features
*)
90 (pushnew :lw-int32
*features
*)
91 (defmacro lw-int32-no-overflow
(value)
92 ;; Prevent overflow in 64-bit prior to LispWorks 7.0.
93 #+(and :lispworks-64bit
(or :lispworks5
:lispworks6
))
94 `(sys:int32
>> (sys:int32
<< ,value
#.
(sys:integer-to-int32
32))
95 #.
(sys:integer-to-int32
32))
96 #-
(and :lispworks-64bit
(or :lispworks5
:lispworks6
))
99 ;;; Section 2: Basic Datatypes
102 "Corresponds to the 32bit quantity word of the MD5 Spec"
103 #+lw-int32
'sys
:int32
104 #-lw-int32
'(unsigned-byte 32))
106 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
107 (defmacro assemble-ub32
(a b c d
)
108 "Assemble an ub32 value from the given (unsigned-byte 8) values,
109 where a is the intended low-order byte and d the high-order byte."
111 `(lw-int32-no-overflow
112 (sys:int32-logior
(sys:int32
<< ,d
24)
113 (sys:int32-logior
(sys:int32
<< ,c
16)
114 (sys:int32-logior
(sys:int32
<< ,b
8) ,a
))))
116 `(the ub32
(logior (ash ,d
24) (ash ,c
16) (ash ,b
8) ,a
))))
118 (deftype ub32-vector
(length)
119 #+lw-int32
(declare (ignore length
))
120 #+lw-int32
'sys
:simple-int32-vector
121 #-lw-int32
`(simple-array (unsigned-byte 32) (,length
)))
123 (defmacro make-ub32-vector
(length &rest args
)
124 #+lw-int32
`(sys:make-simple-int32-vector
,length
,@args
)
125 #-lw-int32
`(make-array ,length
:element-type
'ub32
,@args
))
127 (defmacro ub32-aref
(vector index
)
129 `(sys:int32-aref
,vector
,index
)
131 `(aref ,vector
,index
))
133 ;;; Section 3.4: Auxilliary functions
135 (declaim (inline f g h i
)
136 (ftype (function (ub32 ub32 ub32
) ub32
) f g h i
))
139 (declare (type ub32 x y z
)
140 (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32
(float 0)))
142 (kernel:32bit-logical-or
(kernel:32bit-logical-and x y
)
143 (kernel:32bit-logical-andc1 x z
))
145 (sys:int32-logior
(sys:int32-logand x y
) (sys:int32-logandc1 x z
))
146 #-
(or :cmu
:lw-int32
)
147 (logior (logand x y
) (logandc1 x z
)))
150 (declare (type ub32 x y z
)
151 (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32
(float 0)))
153 (kernel:32bit-logical-or
(kernel:32bit-logical-and x z
)
154 (kernel:32bit-logical-andc2 y z
))
156 (sys:int32-logior
(sys:int32-logand x z
) (sys:int32-logandc2 y z
))
157 #-
(or :cmu
:lw-int32
)
158 (logior (logand x z
) (logandc2 y z
)))
161 (declare (type ub32 x y z
)
162 (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32
(float 0)))
164 (kernel:32bit-logical-xor x
(kernel:32bit-logical-xor y z
))
166 (sys:int32-logxor x
(sys:int32-logxor y z
))
167 #-
(or :cmu
:lw-int32
)
171 (declare (type ub32 x y z
)
172 (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32
(float 0)))
174 (kernel:32bit-logical-xor y
(kernel:32bit-logical-orc2 x z
))
176 (lw-int32-no-overflow (sys:int32-logxor y
(sys:int32-logorc2 x z
)))
177 #-
(or :cmu
:lw-int32
)
178 (ldb (byte 32 0) (logxor y
(logorc2 x z
))))
180 (declaim (inline mod32
+)
181 (ftype (function (ub32 ub32
) ub32
) mod32
+))
183 (declare (type ub32 a b
)
184 (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32
(float 0)))
186 (lw-int32-no-overflow (sys:int32
+ a b
))
188 (ldb (byte 32 0) (+ a b
)))
191 (define-compiler-macro mod32
+ (a b
)
192 `(ext:truly-the ub32
(+ ,a
,b
)))
194 ;;; Dunno why we need this, but without it MOD32+ wasn't being
195 ;;; inlined. Oh well. -- CSR, 2003-09-14
197 (define-compiler-macro mod32
+ (a b
)
198 `(ldb (byte 32 0) (+ ,a
,b
)))
201 (declaim (inline int32
>>logical
)
202 (ftype (function (sys:int32
(unsigned-byte 5)) sys
:int32
) int32
>>logical
))
204 (defun int32>>logical
(a s
)
205 (declare (type ub32 a
) (type (unsigned-byte 5) s
)
206 (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32
(float 0)))
207 (if (sys:int32-minusp a
)
208 (sys:int32-logandc2
(sys:int32
>> a s
) (sys:int32
<< -
1 (- 32 s
)))
211 (declaim (inline rol32
)
212 (ftype (function (ub32 (unsigned-byte 5)) ub32
) rol32
))
214 (declare (type ub32 a
) (type (unsigned-byte 5) s
)
215 (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32
(float 0)))
217 (kernel:32bit-logical-or
#+little-endian
(kernel:shift-towards-end a s
)
218 #+big-endian
(kernel:shift-towards-start a s
)
221 (sb-rotate-byte:rotate-byte s
(byte 32 0) a
)
223 (sys:int32-logior
(lw-int32-no-overflow (sys:int32
<< a s
))
224 (int32>>logical a
(- 32 s
)))
225 #-
(or :cmu
:sbcl
:lw-int32
)
226 (logior (ldb (byte 32 0) (ash a s
)) (ash a
(- s
32))))
228 ;;; Section 3.4: Table T
230 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
231 (defparameter *t
* (make-array 64 :element-type
'ub32
233 (loop for i from
1 to
64
237 (abs (sin (float i
0.0d0
)))))))))
239 ;;; Section 3.4: Helper Macro for single round definitions
242 (defmacro with-md5-round
((op block
) &rest clauses
)
243 (loop for
(a b c d k s i
) in clauses
245 `(setq ,a
(mod32+ ,b
(rol32 (mod32+ (mod32+ ,a
(,op
,b
,c
,d
))
246 (mod32+ (ub32-aref ,block
,k
)
251 (return `(progn ,@result
))))
254 (defmacro with-md5-round
((op block
) &rest clauses
)
255 (loop for
(a b c d k s i
) in clauses
257 `(setq ,a
(mod32+ ,b
(rol32 (mod32+ (mod32+ ,a
(,op
,b
,c
,d
))
258 (mod32+ (ub32-aref ,block
,k
)
259 (sys:integer-to-int32
260 ,(let ((t-val (aref *t
* (1- i
))))
261 (dpb (ldb (byte 32 0) t-val
)
263 (if (logbitp 31 t-val
)
269 (return `(progn ,@result
))))
271 ;;; Section 3.3: (Initial) MD5 Working Set
274 "The working state of the MD5 algorithm, which contains the 4 32-bit
275 registers A, B, C and D."
278 (defmacro md5-regs-a
(regs)
279 `(ub32-aref ,regs
0))
281 (defmacro md5-regs-b
(regs)
282 `(ub32-aref ,regs
1))
284 (defmacro md5-regs-c
(regs)
285 `(ub32-aref ,regs
2))
287 (defmacro md5-regs-d
(regs)
288 `(ub32-aref ,regs
3))
290 (defconstant +md5-magic-a
+ (assemble-ub32 #x01
#x23
#x45
#x67
)
291 "Initial value of Register A of the MD5 working state.")
292 (defconstant +md5-magic-b
+ (assemble-ub32 #x89
#xab
#xcd
#xef
)
293 "Initial value of Register B of the MD5 working state.")
294 (defconstant +md5-magic-c
+ (assemble-ub32 #xfe
#xdc
#xba
#x98
)
295 "Initial value of Register C of the MD5 working state.")
296 (defconstant +md5-magic-d
+ (assemble-ub32 #x76
#x54
#x32
#x10
)
297 "Initial value of Register D of the MD5 working state.")
299 (declaim (inline initial-md5-regs
))
300 (defun initial-md5-regs ()
301 "Create the initial working state of an MD5 run."
302 (declare (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32
(float 0)))
303 (let ((regs (make-ub32-vector 4)))
304 (declare (type md5-regs regs
))
305 (setf (md5-regs-a regs
) +md5-magic-a
+
306 (md5-regs-b regs
) +md5-magic-b
+
307 (md5-regs-c regs
) +md5-magic-c
+
308 (md5-regs-d regs
) +md5-magic-d
+)
311 ;;; Section 3.4: Operation on 16-Word Blocks
313 (deftype md5-block
()
314 "The basic 16x32-bit word blocks that MD5 operates on."
317 (defun update-md5-block (regs block
)
318 "This is the core part of the MD5 algorithm. It takes a complete 16
319 word block of input, and updates the working state in A, B, C, and D
321 (declare (type md5-regs regs
)
322 (type md5-block block
)
323 (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32
(float 0)))
324 (let ((A (md5-regs-a regs
)) (B (md5-regs-b regs
))
325 (C (md5-regs-c regs
)) (D (md5-regs-d regs
)))
326 (declare (type ub32 A B C D
))
328 (with-md5-round (f block
)
329 (A B C D
0 7 1)(D A B C
1 12 2)(C D A B
2 17 3)(B C D A
3 22 4)
330 (A B C D
4 7 5)(D A B C
5 12 6)(C D A B
6 17 7)(B C D A
7 22 8)
331 (A B C D
8 7 9)(D A B C
9 12 10)(C D A B
10 17 11)(B C D A
11 22 12)
332 (A B C D
12 7 13)(D A B C
13 12 14)(C D A B
14 17 15)(B C D A
15 22 16))
334 (with-md5-round (g block
)
335 (A B C D
1 5 17)(D A B C
6 9 18)(C D A B
11 14 19)(B C D A
0 20 20)
336 (A B C D
5 5 21)(D A B C
10 9 22)(C D A B
15 14 23)(B C D A
4 20 24)
337 (A B C D
9 5 25)(D A B C
14 9 26)(C D A B
3 14 27)(B C D A
8 20 28)
338 (A B C D
13 5 29)(D A B C
2 9 30)(C D A B
7 14 31)(B C D A
12 20 32))
340 (with-md5-round (h block
)
341 (A B C D
5 4 33)(D A B C
8 11 34)(C D A B
11 16 35)(B C D A
14 23 36)
342 (A B C D
1 4 37)(D A B C
4 11 38)(C D A B
7 16 39)(B C D A
10 23 40)
343 (A B C D
13 4 41)(D A B C
0 11 42)(C D A B
3 16 43)(B C D A
6 23 44)
344 (A B C D
9 4 45)(D A B C
12 11 46)(C D A B
15 16 47)(B C D A
2 23 48))
346 (with-md5-round (i block
)
347 (A B C D
0 6 49)(D A B C
7 10 50)(C D A B
14 15 51)(B C D A
5 21 52)
348 (A B C D
12 6 53)(D A B C
3 10 54)(C D A B
10 15 55)(B C D A
1 21 56)
349 (A B C D
8 6 57)(D A B C
15 10 58)(C D A B
6 15 59)(B C D A
13 21 60)
350 (A B C D
4 6 61)(D A B C
11 10 62)(C D A B
2 15 63)(B C D A
9 21 64))
352 (setf (md5-regs-a regs
) (mod32+ (md5-regs-a regs
) A
)
353 (md5-regs-b regs
) (mod32+ (md5-regs-b regs
) B
)
354 (md5-regs-c regs
) (mod32+ (md5-regs-c regs
) C
)
355 (md5-regs-d regs
) (mod32+ (md5-regs-d regs
) D
))
358 ;;; Section 3.4: Converting 8bit-vectors into 16-Word Blocks
360 (declaim (inline fill-block fill-block-ub8 fill-block-char
))
361 (defun fill-block-ub8 (block buffer offset
)
362 "Convert a complete 64 (unsigned-byte 8) input vector segment
363 starting from `offset' into the given 16 word MD5 block."
364 (declare (type (integer 0 #.
(- most-positive-fixnum
64)) offset
)
365 (type md5-block block
)
366 (type (simple-array (unsigned-byte 8) (*)) buffer
)
367 (optimize (speed 3) (safety 0) (space 0) (debug 0)
368 #+lw-int32
(float 0) #+lw-int32
(hcl:fixnum-safety
0)))
369 #+(and :cmu
:little-endian
)
370 (kernel:bit-bash-copy
371 buffer
(+ (* vm
:vector-data-offset vm
:word-bits
) (* offset vm
:byte-bits
))
372 block
(* vm
:vector-data-offset vm
:word-bits
)
374 #+(and :sbcl
:little-endian
)
375 (sb-kernel:ub8-bash-copy buffer offset block
0 64)
376 #-
(or (and :sbcl
:little-endian
) (and :cmu
:little-endian
))
377 (loop for i of-type
(integer 0 16) from
0
378 for j of-type
(integer 0 #.most-positive-fixnum
)
379 from offset to
(+ offset
63) by
4
381 (setf (ub32-aref block i
)
382 (assemble-ub32 (aref buffer j
)
383 (aref buffer
(+ j
1))
384 (aref buffer
(+ j
2))
385 (aref buffer
(+ j
3))))))
387 (defun fill-block-char (block buffer offset
)
388 "DEPRECATED: Convert a complete 64 character input string segment
389 starting from `offset' into the given 16 word MD5 block."
390 (declare (type (integer 0 #.
(- most-positive-fixnum
64)) offset
)
391 (type md5-block block
)
392 (type simple-string buffer
)
393 (optimize (speed 3) (safety 0) (space 0) (debug 0)
394 #+lw-int32
(float 0) #+lw-int32
(hcl:fixnum-safety
0)))
395 #+(and :cmu
:little-endian
)
396 (kernel:bit-bash-copy
397 buffer
(+ (* vm
:vector-data-offset vm
:word-bits
) (* offset vm
:byte-bits
))
398 block
(* vm
:vector-data-offset vm
:word-bits
)
400 #+(and :sbcl
:little-endian
)
401 (sb-kernel:ub8-bash-copy buffer offset block
0 64)
402 #-
(or (and :sbcl
:little-endian
) (and :cmu
:little-endian
))
403 (loop for i of-type
(integer 0 16) from
0
404 for j of-type
(integer 0 #.most-positive-fixnum
)
405 from offset to
(+ offset
63) by
4
407 (setf (ub32-aref block i
)
408 (assemble-ub32 (char-code (schar buffer j
))
409 (char-code (schar buffer
(+ j
1)))
410 (char-code (schar buffer
(+ j
2)))
411 (char-code (schar buffer
(+ j
3)))))))
413 (defun fill-block (block buffer offset
)
414 "Convert a complete 64 byte input vector segment into the given 16
415 word MD5 block. This currently works on (unsigned-byte 8) and
416 character simple-arrays, via the functions `fill-block-ub8' and
417 `fill-block-char' respectively. Note that it will not work correctly
418 on character simple-arrays if `char-code-limit' is greater than 256."
419 (declare (type (integer 0 #.
(- most-positive-fixnum
64)) offset
)
420 (type md5-block block
)
421 (type (simple-array * (*)) buffer
)
422 (optimize (speed 3) (safety 0) (space 0) (debug 0)
423 #+lw-int32
(float 0) #+lw-int32
(hcl:fixnum-safety
0)))
425 ((simple-array (unsigned-byte 8) (*))
426 (fill-block-ub8 block buffer offset
))
428 (fill-block-char block buffer offset
))))
430 ;;; Section 3.5: Message Digest Output
432 (declaim (inline md5regs-digest
))
433 (defun md5regs-digest (regs)
434 "Create the final 16 byte message-digest from the MD5 working state
435 in `regs'. Returns a (simple-array (unsigned-byte 8) (16))."
436 (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
437 #+lw-int32
(float 0) #+lw-int32
(hcl:fixnum-safety
0))
438 (type md5-regs regs
))
439 (let ((result (make-array 16 :element-type
'(unsigned-byte 8))))
440 (declare (type (simple-array (unsigned-byte 8) (16)) result
))
441 (macrolet ((frob (reg offset
)
442 (let ((var (gensym)))
443 `(let ((,var
#+lw-int32
(ldb (byte 32 0) (sys:int32-to-integer
,reg
))
445 (declare (type (unsigned-byte 32) ,var
))
447 (aref result
,offset
) (ldb (byte 8 0) ,var
)
448 (aref result
,(+ offset
1)) (ldb (byte 8 8) ,var
)
449 (aref result
,(+ offset
2)) (ldb (byte 8 16) ,var
)
450 (aref result
,(+ offset
3)) (ldb (byte 8 24) ,var
))))))
451 (frob (md5-regs-a regs
) 0)
452 (frob (md5-regs-b regs
) 4)
453 (frob (md5-regs-c regs
) 8)
454 (frob (md5-regs-d regs
) 12))
457 ;;; Mid-Level Drivers
460 (declare (optimize (speed 3) (safety 1) (space 0) (debug 1)
461 #+lw-int32
(float 0)))
462 (defstruct (md5-state
463 (:constructor make-md5-state
())
465 (regs (initial-md5-regs) :type md5-regs
:read-only t
)
467 #-md5-small-length
(integer 0 *)
468 #+md5-small-length
(unsigned-byte 29))
469 (block (make-ub32-vector 16) :read-only t
:type md5-block
)
470 (buffer (make-array 64 :element-type
'(unsigned-byte 8)) :read-only t
471 :type
(simple-array (unsigned-byte 8) (64)))
472 (buffer-index 0 :type
(integer 0 63))
476 (declaim (inline copy-to-buffer
))
477 (defun copy-to-buffer (from from-offset count buffer buffer-offset
)
478 "Copy a partial segment from input vector `from' starting at
479 `from-offset' and copying `count' elements into the 64 byte buffer
480 starting at `buffer-offset'."
481 (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
482 #+lw-int32
(float 0) #+lw-int32
(hcl:fixnum-safety
0))
483 (type (unsigned-byte 29) from-offset
)
484 (type (integer 0 63) count buffer-offset
)
485 (type (simple-array * (*)) from
)
486 (type (simple-array (unsigned-byte 8) (64)) buffer
))
488 (kernel:bit-bash-copy
489 from
(+ (* vm
:vector-data-offset vm
:word-bits
) (* from-offset vm
:byte-bits
))
490 buffer
(+ (* vm
:vector-data-offset vm
:word-bits
)
491 (* buffer-offset vm
:byte-bits
))
492 (* count vm
:byte-bits
))
494 (sb-kernel:ub8-bash-copy from from-offset buffer buffer-offset count
)
498 (loop for buffer-index of-type
(integer 0 64) from buffer-offset
499 for from-index of-type fixnum from from-offset
500 below
(+ from-offset count
)
502 (setf (aref buffer buffer-index
)
503 (char-code (schar (the simple-string from
) from-index
)))))
504 ((simple-array (unsigned-byte 8) (*))
505 (loop for buffer-index of-type
(integer 0 64) from buffer-offset
506 for from-index of-type fixnum from from-offset
507 below
(+ from-offset count
)
509 (setf (aref buffer buffer-index
)
510 (aref (the (simple-array (unsigned-byte 8) (*)) from
)
513 (defun update-md5-state (state sequence
&key
(start 0) (end (length sequence
)))
514 "Update the given md5-state from `sequence', which is either a
515 simple-string or a simple-array with element-type (unsigned-byte 8),
516 bounded by `start' and `end', which must be numeric bounding-indices.
517 Note that usage on simple-strings is DEPRECATED, since this will not
518 work correctly if `char-code-limit' is more than 256. String input
519 should be converted to (unsigned-byte 8) simple-arrays with
520 external-format conversion routines beforehand."
521 (declare (type md5-state state
)
522 (type (simple-array * (*)) sequence
)
523 (type fixnum start end
)
524 (optimize (speed 3) (safety 1) (space 0) (debug 1)
525 #+lw-int32
(float 0) #+lw-int32
(hcl:fixnum-safety
0)))
527 (declare (optimize (safety 0) (debug 0)))
528 (let ((regs (md5-state-regs state
))
529 (block (md5-state-block state
))
530 (buffer (md5-state-buffer state
))
531 (buffer-index (md5-state-buffer-index state
))
532 (length (- end start
)))
533 (declare (type md5-regs regs
) (type fixnum length
)
534 (type (integer 0 63) buffer-index
)
535 (type md5-block block
)
536 (type (simple-array (unsigned-byte 8) (64)) buffer
))
538 (unless (zerop buffer-index
)
539 (let ((amount (min (- 64 buffer-index
) length
)))
540 (declare (type (integer 0 63) amount
))
541 (copy-to-buffer sequence start amount buffer buffer-index
)
542 (setq start
(the fixnum
(+ start amount
)))
543 (let ((new-index (+ buffer-index amount
)))
544 (when (= new-index
64)
545 (fill-block-ub8 block buffer
0)
546 (update-md5-block regs block
)
549 (setf (md5-state-buffer-index state
) new-index
550 (md5-state-amount state
)
551 #-md5-small-length
(+ (md5-state-amount state
) length
)
552 #+md5-small-length
(the (unsigned-byte 29)
553 (+ (md5-state-amount state
) length
)))
554 (return-from update-md5-state state
)))))
555 ;; Handle main-part and new-rest
557 ((simple-array (unsigned-byte 8) (*))
559 (declare (type (simple-array (unsigned-byte 8) (*)) sequence
))
560 (loop for offset of-type
(unsigned-byte 29) from start below end by
64
561 until
(< (- end offset
) 64)
563 (fill-block-ub8 block sequence offset
)
564 (update-md5-block regs block
)
566 (let ((amount (- end offset
)))
567 (unless (zerop amount
)
568 (copy-to-buffer sequence offset amount buffer
0))
569 (setf (md5-state-buffer-index state
) amount
)))))
572 (declare (type simple-string sequence
))
573 (loop for offset of-type
(unsigned-byte 29) from start below end by
64
574 until
(< (- end offset
) 64)
576 (fill-block-char block sequence offset
)
577 (update-md5-block regs block
)
579 (let ((amount (- end offset
)))
580 (unless (zerop amount
)
581 (copy-to-buffer sequence offset amount buffer
0))
582 (setf (md5-state-buffer-index state
) amount
))))))
583 (setf (md5-state-amount state
)
584 #-md5-small-length
(+ (md5-state-amount state
) length
)
585 #+md5-small-length
(the (unsigned-byte 29)
586 (+ (md5-state-amount state
) length
)))
589 (defun finalize-md5-state (state)
590 "If the given md5-state has not already been finalized, finalize it,
591 by processing any remaining input in its buffer, with suitable padding
592 and appended bit-length, as specified by the MD5 standard.
594 The resulting MD5 message-digest is returned as an array of sixteen
595 (unsigned-byte 8) values. Calling `update-md5-state' after a call to
596 `finalize-md5-state' results in unspecified behaviour."
597 (declare (type md5-state state
)
598 (optimize (speed 3) (safety 1) (space 0) (debug 1) #+lw-int32
(float 0)))
600 (declare (optimize (safety 0) (debug 0)))
601 (or (md5-state-finalized-p state
)
602 (let ((regs (md5-state-regs state
))
603 (block (md5-state-block state
))
604 (buffer (md5-state-buffer state
))
605 (buffer-index (md5-state-buffer-index state
))
606 (total-length (* 8 (md5-state-amount state
))))
607 (declare (type md5-regs regs
)
608 (type (integer 0 63) buffer-index
)
609 (type md5-block block
)
610 (type (simple-array (unsigned-byte 8) (*)) buffer
))
611 ;; Add mandatory bit 1 padding
612 (setf (aref buffer buffer-index
) #x80
)
613 ;; Fill with 0 bit padding
614 (loop for index of-type
(integer 0 64)
615 from
(1+ buffer-index
) below
64
616 do
(setf (aref buffer index
) #x00
))
617 (fill-block-ub8 block buffer
0)
618 ;; Flush block first if length wouldn't fit
619 (when (>= buffer-index
56)
620 (update-md5-block regs block
)
621 ;; Create new fully 0 padded block
622 (loop for index of-type
(integer 0 16) from
0 below
16
623 do
(setf (ub32-aref block index
) #x00000000
)))
624 ;; Add 64bit message bit length
625 (setf (ub32-aref block
14) (ldb (byte 32 0) total-length
))
627 (setf (ub32-aref block
15) (ldb (byte 32 32) total-length
))
629 (update-md5-block regs block
)
630 ;; Done, remember digest for later calls
631 (setf (md5-state-finalized-p state
)
632 (md5regs-digest regs
))))))
634 ;;; High-Level Drivers
636 (defun md5sum-sequence (sequence &key
(start 0) end
)
637 "Calculate the MD5 message-digest of data in `sequence', which should
638 be a 1d simple-array with element type (unsigned-byte 8). On CMU CL
639 and SBCL non-simple and non-1d arrays with this element-type are also
640 supported. Use with strings is DEPRECATED, since this will not work
641 correctly on implementations with `char-code-limit' > 256 and ignores
642 character-coding issues. Use md5sum-string instead, or convert to the
643 required (unsigned-byte 8) format through other means before-hand."
644 (declare (optimize (speed 3) (safety 3) (space 0) (debug 1))
645 (type (vector (unsigned-byte 8)) sequence
) (type fixnum start
))
647 (declare (optimize (safety 1) (debug 0)))
648 (let ((state (make-md5-state)))
649 (declare (type md5-state state
))
651 (let ((end (or end
(length sequence
))))
652 (lisp::with-array-data
((data sequence
) (real-start start
) (real-end end
))
653 (declare (ignore real-end
))
654 (update-md5-state state data
:start real-start
655 :end
(+ real-start
(- end start
)))))
657 (let ((end (or end
(length sequence
))))
658 (sb-kernel:with-array-data
((data sequence
)
661 :check-fill-pointer t
)
662 (declare (ignore real-end
))
663 (update-md5-state state data
:start real-start
664 :end
(+ real-start
(- end start
)))))
666 (let ((real-end (or end
(length sequence
))))
667 (declare (type fixnum real-end
))
668 (update-md5-state state sequence
:start start
:end real-end
))
669 (finalize-md5-state state
))))
671 (defun md5sum-string (string &key
(external-format :default
) (start 0) end
)
672 "Calculate the MD5 message-digest of the binary representation of
673 `string' (as octets) in the external format specified by
674 `external-format'. The boundaries `start' and `end' refer to character
675 positions in the string, not to octets in the resulting binary
676 representation. The permissible external format specifiers are
677 determined by the underlying implementation."
678 (declare (optimize (speed 3) (safety 3) (space 0) (debug 1))
679 (type string string
) (type fixnum start
)
680 (ignorable external-format
))
682 (declare (optimize (safety 1) (debug 0)))
685 (stream:string-to-octets string
686 :external-format external-format
687 :start start
:end end
))
690 (sb-ext:string-to-octets string
691 :external-format external-format
692 :start start
:end end
))
693 #+(and :lispworks
(not :lispworks4
))
694 (let ((external-format (system:merge-ef-specs external-format
:utf-8
)))
695 (if (equal (external-format:external-format-foreign-type external-format
)
698 (coerce (external-format:encode-lisp-string string external-format
699 :start start
:end end
)
700 '(simple-array (unsigned-byte 8) (*))))
701 (error "External Format ~S does not yield (unsigned-byte 8) vector!"
705 (ccl:encode-string-to-octets string
:external-format external-format
706 :start start
:end end
))
709 (excl:string-to-octets string
:external-format external-format
710 :null-terminate nil
:start start
:end end
))
711 #-
(or :cmu
:sbcl
(and :lispworks
(not :lispworks4
)) :ccl
:allegro
)
712 (if (<= char-code-limit
256)
713 (md5sum-sequence string
:start start
:end end
)
715 (flexi-streams:string-to-octets string
717 (if (eq external-format
:default
)
719 external-format
))))))
721 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
722 (defconstant +buffer-size
+ (* 128 1024)
723 "Size of internal buffer to use for `md5sum-stream' and `md5sum-file'
724 operations. This should be a multiple of 64, the MD5 block size."))
726 (deftype buffer-index
() `(integer 0 ,+buffer-size
+))
728 (defun md5sum-stream (stream)
729 "Calculate an MD5 message-digest of the contents of `stream'. Its
730 element-type has to be (unsigned-byte 8). Use on character streams is
731 DEPRECATED, as this will not work correctly on implementations with
732 `char-code-limit' > 256 and ignores character coding issues."
733 (declare (optimize (speed 3) (safety 3) (space 0) (debug 1)))
735 (declare (optimize (safety 1) (debug 0)))
736 (let ((state (make-md5-state)))
737 (declare (type md5-state state
))
739 ((equal (stream-element-type stream
) '(unsigned-byte 8))
740 (let ((buffer (make-array +buffer-size
+
741 :element-type
'(unsigned-byte 8))))
742 (declare (type (simple-array (unsigned-byte 8) (#.
+buffer-size
+))
744 (loop for bytes of-type buffer-index
= (read-sequence buffer stream
)
745 do
(update-md5-state state buffer
:end bytes
)
746 until
(< bytes
+buffer-size
+)
748 (return (finalize-md5-state state
)))))
749 ((equal (stream-element-type stream
) 'character
)
750 (let ((buffer (make-string +buffer-size
+)))
751 (declare (type (simple-string #.
+buffer-size
+) buffer
))
752 (loop for bytes of-type buffer-index
= (read-sequence buffer stream
)
753 do
(update-md5-state state buffer
:end bytes
)
754 until
(< bytes
+buffer-size
+)
756 (return (finalize-md5-state state
)))))
758 (error "Unsupported stream element-type ~S for stream ~S."
759 (stream-element-type stream
) stream
))))))
761 (defun md5sum-file (pathname)
762 "Calculate the MD5 message-digest of the file specified by `pathname'."
763 (declare (optimize (speed 3) (safety 3) (space 0) (debug 1)))
764 (with-open-file (stream pathname
:element-type
'(unsigned-byte 8))
765 (md5sum-stream stream
)))
768 (defparameter *rfc1321-testsuite
*
769 '(("" .
"d41d8cd98f00b204e9800998ecf8427e")
770 ("a" .
"0cc175b9c0f1b6a831c399e269772661")
771 ("abc" .
"900150983cd24fb0d6963f7d28e17f72")
772 ("message digest" .
"f96b697d7cb7938d525a2f31aaf161d0")
773 ("abcdefghijklmnopqrstuvwxyz" .
"c3fcd3d76192e4007dfb496cca67e13b")
774 ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" .
775 "d174ab98d277d9f5a5611c2c9f419d9f")
776 ("12345678901234567890123456789012345678901234567890123456789012345678901234567890" .
777 "57edf4a22be3c955ac49da2e2107b67a"))
778 "AList of test input strings and stringified message-digests
779 according to the test suite in Appendix A.5 of RFC 1321")
782 (defparameter *other-testsuite
*
783 '(;; From padding bug report by Edi Weitz
784 ("1631901HERR BUCHHEISTERCITROEN NORD1043360796beckenbauer" .
785 "d734945e5930bb28859ccd13c830358b")
786 ;; Test padding for strings from 0 to 69*8 bits in size.
787 ("" .
"d41d8cd98f00b204e9800998ecf8427e")
788 ("a" .
"0cc175b9c0f1b6a831c399e269772661")
789 ("aa" .
"4124bc0a9335c27f086f24ba207a4912")
790 ("aaa" .
"47bce5c74f589f4867dbd57e9ca9f808")
791 ("aaaa" .
"74b87337454200d4d33f80c4663dc5e5")
792 ("aaaaa" .
"594f803b380a41396ed63dca39503542")
793 ("aaaaaa" .
"0b4e7a0e5fe84ad35fb5f95b9ceeac79")
794 ("aaaaaaa" .
"5d793fc5b00a2348c3fb9ab59e5ca98a")
795 ("aaaaaaaa" .
"3dbe00a167653a1aaee01d93e77e730e")
796 ("aaaaaaaaa" .
"552e6a97297c53e592208cf97fbb3b60")
797 ("aaaaaaaaaa" .
"e09c80c42fda55f9d992e59ca6b3307d")
798 ("aaaaaaaaaaa" .
"d57f21e6a273781dbf8b7657940f3b03")
799 ("aaaaaaaaaaaa" .
"45e4812014d83dde5666ebdf5a8ed1ed")
800 ("aaaaaaaaaaaaa" .
"c162de19c4c3731ca3428769d0cd593d")
801 ("aaaaaaaaaaaaaa" .
"451599a5f9afa91a0f2097040a796f3d")
802 ("aaaaaaaaaaaaaaa" .
"12f9cf6998d52dbe773b06f848bb3608")
803 ("aaaaaaaaaaaaaaaa" .
"23ca472302f49b3ea5592b146a312da0")
804 ("aaaaaaaaaaaaaaaaa" .
"88e42e96cc71151b6e1938a1699b0a27")
805 ("aaaaaaaaaaaaaaaaaa" .
"2c60c24e7087e18e45055a33f9a5be91")
806 ("aaaaaaaaaaaaaaaaaaa" .
"639d76897485360b3147e66e0a8a3d6c")
807 ("aaaaaaaaaaaaaaaaaaaa" .
"22d42eb002cefa81e9ad604ea57bc01d")
808 ("aaaaaaaaaaaaaaaaaaaaa" .
"bd049f221af82804c5a2826809337c9b")
809 ("aaaaaaaaaaaaaaaaaaaaaa" .
"ff49cfac3968dbce26ebe7d4823e58bd")
810 ("aaaaaaaaaaaaaaaaaaaaaaa" .
"d95dbfee231e34cccb8c04444412ed7d")
811 ("aaaaaaaaaaaaaaaaaaaaaaaa" .
"40edae4bad0e5bf6d6c2dc5615a86afb")
812 ("aaaaaaaaaaaaaaaaaaaaaaaaa" .
"a5a8bfa3962f49330227955e24a2e67c")
813 ("aaaaaaaaaaaaaaaaaaaaaaaaaa" .
"ae791f19bdf77357ff10bb6b0e97e121")
814 ("aaaaaaaaaaaaaaaaaaaaaaaaaaa" .
"aaab9c59a88bf0bdfcb170546c5459d6")
815 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
"b0f0545856af1a340acdedce23c54b97")
816 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
"f7ce3d7d44f3342107d884bfa90c966a")
817 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
"59e794d45697b360e18ba972bada0123")
818 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
"3b0845db57c200be6052466f87b2198a")
819 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
"5eca9bd3eb07c006cd43ae48dfde7fd3")
820 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
"b4f13cb081e412f44e99742cb128a1a5")
821 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
"4c660346451b8cf91ef50f4634458d41")
822 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
823 "11db24dc3f6c2145701db08625dd6d76")
824 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
825 "80dad3aad8584778352c68ab06250327")
826 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
827 "1227fe415e79db47285cb2689c93963f")
828 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
829 "8e084f489f1bdf08c39f98ff6447ce6d")
830 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
831 "08b2f2b0864bac1ba1585043362cbec9")
832 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
833 "4697843037d962f62a5a429e611e0f5f")
834 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
835 "10c4da18575c092b486f8ab96c01c02f")
836 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
837 "af205d729450b663f48b11d839a1c8df")
838 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
839 "0d3f91798fac6ee279ec2485b25f1124")
840 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
841 "4c3c7c067634daec9716a80ea886d123")
842 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
843 "d1e358e6e3b707282cdd06e919f7e08c")
844 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
845 "8c6ded4f0af86e0a7e301f8a716c4363")
846 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
847 "4c2d8bcb02d982d7cb77f649c0a2dea8")
848 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
849 "bdb662f765cd310f2a547cab1cfecef6")
850 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
851 "08ff5f7301d30200ab89169f6afdb7af")
852 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
853 "6eb6a030bcce166534b95bc2ab45d9cf")
854 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
855 "1bb77918e5695c944be02c16ae29b25e")
856 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
857 "b6fe77c19f0f0f4946c761d62585bfea")
858 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
859 "e9e7e260dce84ffa6e0e7eb5fd9d37fc")
860 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
861 "eced9e0b81ef2bba605cbc5e2e76a1d0")
862 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
863 "ef1772b6dff9a122358552954ad0df65")
864 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
865 "3b0c8ac703f828b04c6c197006d17218")
866 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
867 "652b906d60af96844ebd21b674f35e93")
868 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
869 "dc2f2f2462a0d72358b2f99389458606")
870 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
871 "762fc2665994b217c52c3c2eb7d9f406")
872 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
873 "cc7ed669cf88f201c3297c6a91e1d18d")
874 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
875 "cced11f7bbbffea2f718903216643648")
876 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
877 "24612f0ce2c9d2cf2b022ef1e027a54f")
878 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
879 "b06521f39153d618550606be297466d5")
880 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
881 "014842d480b571495a4a0363793f7367")
882 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
883 "c743a45e0d2e6a95cb859adae0248435")
884 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
885 "def5d97e01e1219fb2fc8da6c4d6ba2f")
886 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
887 "92cb737f8687ccb93022fdb411a77cca")
888 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
889 "a0d1395c7fb36247bfe2d49376d9d133")
890 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
891 "ab75504250558b788f99d1ebd219abf2"))
892 "AList of test input strings and stringified message-digests
893 according to my additional test suite")
896 (defparameter *ascii-map
*
897 '((#\A .
65) (#\B .
66) (#\C .
67) (#\D .
68) (#\E .
69) (#\F .
70)
898 (#\G .
71) (#\H .
72) (#\I .
73) (#\J .
74) (#\K .
75) (#\L .
76)
899 (#\M .
77) (#\N .
78) (#\O .
79) (#\P .
80) (#\Q .
81) (#\R .
82)
900 (#\S .
83) (#\T .
84) (#\U .
85) (#\V .
86) (#\W .
87) (#\X .
88)
901 (#\Y .
89) (#\Z .
90) (#\a .
97) (#\b .
98) (#\c .
99) (#\d .
100)
902 (#\e .
101) (#\f .
102) (#\g .
103) (#\h .
104) (#\i .
105) (#\j .
106)
903 (#\k .
107) (#\l .
108) (#\m .
109) (#\n .
110) (#\o .
111) (#\p .
112)
904 (#\q .
113) (#\r .
114) (#\s .
115) (#\t .
116) (#\u .
117) (#\v .
118)
905 (#\w .
119) (#\x .
120) (#\y .
121) (#\z .
122) (#\
0 .
48) (#\
1 .
49)
906 (#\
2 .
50) (#\
3 .
51) (#\
4 .
52) (#\
5 .
53) (#\
6 .
54) (#\
7 .
55)
907 (#\
8 .
56) (#\
9 .
57) (#\Space .
32))
908 "AList mapping string characters to ASCII codes for safe binary testing.")
911 (defun test-with-testsuite (testsuite)
912 (flet ((to-vector (string)
913 (loop with result
= (make-array (list (length string
))
914 :element-type
'(unsigned-byte 8))
915 for char across string
916 for byte
= (or (cdr (assoc char
*ascii-map
*))
917 (error "Missing Char in *ascii-map*: ~S" char
))
919 do
(setf (aref result index
) byte
)
920 finally
(return result
)))
921 (incremental-md5sum (input)
922 (loop with state
= (make-md5-state)
923 for index from
0 below
(length input
)
924 do
(update-md5-state state input
:start index
:end
(1+ index
))
925 finally
(return (finalize-md5-state state
)))))
926 (loop for count from
1
927 for
(source . md5-string
) in testsuite
928 for binary-source
= (to-vector source
)
929 for md5-digest
= (md5sum-sequence binary-source
)
930 for md5-digest-inc
= (incremental-md5sum binary-source
)
931 for md5-result-string
= (format nil
"~(~{~2,'0X~}~)"
932 (map 'list
#'identity md5-digest
))
933 for md5-result-string-inc
= (format nil
935 (map 'list
#'identity md5-digest-inc
))
939 "~2&Test-Case ~D:~% Input: ~S~% Required: ~A~% Returned: ~A~% ~
940 Returned incrementally: ~A~%"
941 count source md5-string md5-result-string md5-result-string-inc
)
942 when
(and (string= md5-string md5-result-string
)
943 (string= md5-string md5-result-string-inc
))
944 do
(format *trace-output
* " OK~%")
947 and do
(format *trace-output
* " FAILED~%")
949 (format *trace-output
*
950 "~2&~[All ~D test cases succeeded~:;~:*~D of ~D test cases failed~].~%"
952 (return (zerop failed
)))))
955 (defun test-rfc1321 ()
956 (test-with-testsuite *rfc1321-testsuite
*))
960 (test-with-testsuite *other-testsuite
*))
963 (eval-when (:compile-toplevel
:execute
)
964 (setq *features
* *old-features
*))
967 (eval-when (:compile-toplevel
)
968 (setq ext
:*inline-expansion-limit
* *old-expansion-limit
*))
971 (eval-when (:compile-toplevel
:execute
)
972 (setq *features
* *old-features
*))
974 #+(and :lispworks
(or (not :lispworks4
) :lispworks4.4
))
975 (eval-when (:compile-toplevel
:execute
)
976 (setq *features
* *old-features
*))