1;;;; This file implements The MD5 Message-Digest Algorithm, as defined in 2;;;; RFC 1321 by R. Rivest, published April 1992. 3;;;; 4;;;; It was written by Pierre R. Mai, with copious input from the 5;;;; cmucl-help mailing-list hosted at cons.org, in November 2001 and 6;;;; has been placed into the public domain. 7;;;; 8;;;; $Id: md5.lisp 10181 2004-12-04 18:27:59Z kevin $ 9;;;; 10;;;; While the implementation should work on all conforming Common 11;;;; Lisp implementations, it has only been optimized for CMU CL, 12;;;; where it achieved comparable performance to the standard md5sum 13;;;; utility (within a factor of 1.5 or less on iA32 and UltraSparc 14;;;; hardware). 15;;;; 16;;;; Since the implementation makes heavy use of arithmetic on 17;;;; (unsigned-byte 32) numbers, acceptable performance is likely only 18;;;; on CL implementations that support unboxed arithmetic on such 19;;;; numbers in some form. For other CL implementations a 16bit 20;;;; implementation of MD5 is probably more suitable. 21;;;; 22;;;; The code implements correct operation for files of unbounded size 23;;;; as is, at the cost of having to do a single generic integer 24;;;; addition for each call to update-md5-state. If you call 25;;;; update-md5-state frequently with little data, this can pose a 26;;;; performance problem. If you can live with a size restriction of 27;;;; 512 MB, then you can enable fast fixnum arithmetic by putting 28;;;; :md5-small-length onto *features* prior to compiling this file. 29;;;; 30;;;; Testing code can be compiled by including :md5-testing on 31;;;; *features* prior to compilation. In that case evaluating 32;;;; (md5::test-rfc1321) will run all the test-cases present in 33;;;; Appendix A.5 of RFC 1321 and report on the results. 34;;;; Evaluating (md5::test-other) will run further test-cases 35;;;; gathered by the author to cover regressions, etc. 36;;;; 37;;;; This software is "as is", and has no warranty of any kind. The 38;;;; authors assume no responsibility for the consequences of any use 39;;;; of this software. 40 41(defpackage #:md5 (:use #:cl) 42 (:export 43 ;; Low-Level types and functions 44 #:md5-regs #:initial-md5-regs #:md5regs-digest 45 #:update-md5-block #:fill-block #:fill-block-ub8 #:fill-block-char 46 ;; Mid-Level types and functions 47 #:md5-state #:md5-state-p #:make-md5-state 48 #:update-md5-state #:finalize-md5-state 49 ;; High-Level functions on sequences, streams and files 50 #:md5sum-sequence #:md5sum-stream #:md5sum-file)) 51 52(in-package #:md5) 53 54#+cmu 55(eval-when (:compile-toplevel) 56 (defparameter *old-expansion-limit* ext:*inline-expansion-limit*) 57 (setq ext:*inline-expansion-limit* (max ext:*inline-expansion-limit* 1000))) 58 59#+cmu 60(eval-when (:compile-toplevel :execute) 61 (defparameter *old-features* *features*) 62 (pushnew (c:backend-byte-order c:*target-backend*) *features*)) 63 64;;; Section 2: Basic Datatypes 65 66#-lispworks 67(eval-when (:compile-toplevel :load-toplevel :execute) 68 (deftype ub32 () 69 "Corresponds to the 32bit quantity word of the MD5 Spec" 70 `(unsigned-byte 32))) 71 72#+lispworks 73(deftype ub32 () 74 "Corresponds to the 32bit quantity word of the MD5 Spec" 75 `(unsigned-byte 32)) 76 77(eval-when (:compile-toplevel :load-toplevel :execute) 78 (defmacro assemble-ub32 (a b c d) 79 "Assemble an ub32 value from the given (unsigned-byte 8) values, 80where a is the intended low-order byte and d the high-order byte." 81 `(the ub32 (logior (ash ,d 24) (ash ,c 16) (ash ,b 8) ,a)))) 82 83;;; Section 3.4: Auxilliary functions 84 85(declaim (inline f g h i) 86 (ftype (function (ub32 ub32 ub32) ub32) f g h i)) 87 88(defun f (x y z) 89 (declare (type ub32 x y z) 90 (optimize (speed 3) (safety 0) (space 0) (debug 0))) 91 #+cmu 92 (kernel:32bit-logical-or (kernel:32bit-logical-and x y) 93 (kernel:32bit-logical-andc1 x z)) 94 #-cmu 95 (logior (logand x y) (logandc1 x z))) 96 97(defun g (x y z) 98 (declare (type ub32 x y z) 99 (optimize (speed 3) (safety 0) (space 0) (debug 0))) 100 #+cmu 101 (kernel:32bit-logical-or (kernel:32bit-logical-and x z) 102 (kernel:32bit-logical-andc2 y z)) 103 #-cmu 104 (logior (logand x z) (logandc2 y z))) 105 106(defun h (x y z) 107 (declare (type ub32 x y z) 108 (optimize (speed 3) (safety 0) (space 0) (debug 0))) 109 #+cmu 110 (kernel:32bit-logical-xor x (kernel:32bit-logical-xor y z)) 111 #-cmu 112 (logxor x y z)) 113 114(defun i (x y z) 115 (declare (type ub32 x y z) 116 (optimize (speed 3) (safety 0) (space 0) (debug 0))) 117 #+cmu 118 (kernel:32bit-logical-xor y (kernel:32bit-logical-orc2 x z)) 119 #-cmu 120 (ldb (byte 32 0) (logxor y (logorc2 x z)))) 121 122(declaim (inline mod32+) 123 (ftype (function (ub32 ub32) ub32) mod32+)) 124(defun mod32+ (a b) 125 (declare (type ub32 a b) (optimize (speed 3) (safety 0) (space 0) (debug 0))) 126 (ldb (byte 32 0) (+ a b))) 127 128#+cmu 129(define-compiler-macro mod32+ (a b) 130 `(ext:truly-the ub32 (+ ,a ,b))) 131 132(declaim (inline rol32) 133 (ftype (function (ub32 (unsigned-byte 5)) ub32) rol32)) 134(defun rol32 (a s) 135 (declare (type ub32 a) (type (unsigned-byte 5) s) 136 (optimize (speed 3) (safety 0) (space 0) (debug 0))) 137 #+cmu 138 (kernel:32bit-logical-or #+little-endian (kernel:shift-towards-end a s) 139 #+big-endian (kernel:shift-towards-start a s) 140 (ash a (- s 32))) 141 #-cmu 142 (logior (ldb (byte 32 0) (ash a s)) (ash a (- s 32)))) 143 144;;; Section 3.4: Table T 145 146(eval-when (:compile-toplevel :load-toplevel :execute) 147 (defparameter *t* (make-array 64 :element-type 'ub32 148 :initial-contents 149 (loop for i from 1 to 64 150 collect 151 (truncate 152 (* 4294967296 153 (abs (sin (float i 0.0d0))))))))) 154 155;;; Section 3.4: Helper Macro for single round definitions 156 157(defmacro with-md5-round ((op block) &rest clauses) 158 (loop for (a b c d k s i) in clauses 159 collect 160 `(setq ,a (mod32+ ,b (rol32 (mod32+ (mod32+ ,a (,op ,b ,c ,d)) 161 (mod32+ (aref ,block ,k) 162 ,(aref *t* (1- i)))) 163 ,s))) 164 into result 165 finally 166 (return `(progn ,@result)))) 167 168;;; Section 3.3: (Initial) MD5 Working Set 169 170(deftype md5-regs () 171 "The working state of the MD5 algorithm, which contains the 4 32-bit 172registers A, B, C and D." 173 `(simple-array (unsigned-byte 32) (4))) 174 175(defmacro md5-regs-a (regs) 176 `(aref ,regs 0)) 177 178(defmacro md5-regs-b (regs) 179 `(aref ,regs 1)) 180 181(defmacro md5-regs-c (regs) 182 `(aref ,regs 2)) 183 184(defmacro md5-regs-d (regs) 185 `(aref ,regs 3)) 186 187(defconstant +md5-magic-a+ (assemble-ub32 #x01 #x23 #x45 #x67) 188 "Initial value of Register A of the MD5 working state.") 189(defconstant +md5-magic-b+ (assemble-ub32 #x89 #xab #xcd #xef) 190 "Initial value of Register B of the MD5 working state.") 191(defconstant +md5-magic-c+ (assemble-ub32 #xfe #xdc #xba #x98) 192 "Initial value of Register C of the MD5 working state.") 193(defconstant +md5-magic-d+ (assemble-ub32 #x76 #x54 #x32 #x10) 194 "Initial value of Register D of the MD5 working state.") 195 196(declaim (inline initial-md5-regs)) 197(defun initial-md5-regs () 198 "Create the initial working state of an MD5 run." 199 (declare (optimize (speed 3) (safety 0) (space 0) (debug 0))) 200 (let ((regs (make-array 4 :element-type '(unsigned-byte 32)))) 201 (declare (type md5-regs regs)) 202 (setf (md5-regs-a regs) +md5-magic-a+ 203 (md5-regs-b regs) +md5-magic-b+ 204 (md5-regs-c regs) +md5-magic-c+ 205 (md5-regs-d regs) +md5-magic-d+) 206 regs)) 207 208;;; Section 3.4: Operation on 16-Word Blocks 209 210(defun update-md5-block (regs block) 211 "This is the core part of the MD5 algorithm. It takes a complete 16 212word block of input, and updates the working state in A, B, C, and D 213accordingly." 214 (declare (type md5-regs regs) 215 (type (simple-array ub32 (16)) block) 216 (optimize (speed 3) (safety 0) (space 0) (debug 0))) 217 (let ((A (md5-regs-a regs)) (B (md5-regs-b regs)) 218 (C (md5-regs-c regs)) (D (md5-regs-d regs))) 219 (declare (type ub32 A B C D)) 220 ;; Round 1 221 (with-md5-round (f block) 222 (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) 223 (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) 224 (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) 225 (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)) 226 ;; Round 2 227 (with-md5-round (g block) 228 (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) 229 (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) 230 (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) 231 (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)) 232 ;; Round 3 233 (with-md5-round (h block) 234 (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) 235 (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) 236 (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) 237 (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)) 238 ;; Round 4 239 (with-md5-round (i block) 240 (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) 241 (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) 242 (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) 243 (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)) 244 ;; Update and return 245 (setf (md5-regs-a regs) (mod32+ (md5-regs-a regs) A) 246 (md5-regs-b regs) (mod32+ (md5-regs-b regs) B) 247 (md5-regs-c regs) (mod32+ (md5-regs-c regs) C) 248 (md5-regs-d regs) (mod32+ (md5-regs-d regs) D)) 249 regs)) 250 251;;; Section 3.4: Converting 8bit-vectors into 16-Word Blocks 252 253(declaim (inline fill-block fill-block-ub8 fill-block-char)) 254 255(defun fill-block-ub8 (block buffer offset) 256 "Convert a complete 64 (unsigned-byte 8) input vector segment 257starting from offset into the given 16 word MD5 block." 258 (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset) 259 (type (simple-array ub32 (16)) block) 260 (type (simple-array (unsigned-byte 8) (*)) buffer) 261 (optimize (speed 3) (safety 0) (space 0) (debug 0))) 262 #+(and :cmu :little-endian) 263 (kernel:bit-bash-copy 264 buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits)) 265 block (* vm:vector-data-offset vm:word-bits) 266 (* 64 vm:byte-bits)) 267 #-(and :cmu :little-endian) 268 (loop for i of-type (integer 0 16) from 0 269 for j of-type (integer 0 #.most-positive-fixnum) 270 from offset to (+ offset 63) by 4 271 do 272 (setf (aref block i) 273 (assemble-ub32 (aref buffer j) 274 (aref buffer (+ j 1)) 275 (aref buffer (+ j 2)) 276 (aref buffer (+ j 3)))))) 277 278(defun fill-block-char (block buffer offset) 279 "Convert a complete 64 character input string segment starting from 280offset into the given 16 word MD5 block." 281 (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset) 282 (type (simple-array ub32 (16)) block) 283 (type simple-string buffer) 284 (optimize (speed 3) (safety 0) (space 0) (debug 0))) 285 #+(and :cmu :little-endian) 286 (kernel:bit-bash-copy 287 buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits)) 288 block (* vm:vector-data-offset vm:word-bits) 289 (* 64 vm:byte-bits)) 290 #-(and :cmu :little-endian) 291 (loop for i of-type (integer 0 16) from 0 292 for j of-type (integer 0 #.most-positive-fixnum) 293 from offset to (+ offset 63) by 4 294 do 295 (setf (aref block i) 296 (assemble-ub32 (char-code (schar buffer j)) 297 (char-code (schar buffer (+ j 1))) 298 (char-code (schar buffer (+ j 2))) 299 (char-code (schar buffer (+ j 3))))))) 300 301(defun fill-block (block buffer offset) 302 "Convert a complete 64 byte input vector segment into the given 16 303word MD5 block. This currently works on (unsigned-byte 8) and 304character simple-arrays, via the functions `fill-block-ub8' and 305`fill-block-char' respectively." 306 (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset) 307 (type (simple-array ub32 (16)) block) 308 (type (simple-array * (*)) buffer) 309 (optimize (speed 3) (safety 0) (space 0) (debug 0))) 310 (etypecase buffer 311 ((simple-array (unsigned-byte 8) (*)) 312 (fill-block-ub8 block buffer offset)) 313 (simple-string 314 (fill-block-char block buffer offset)))) 315 316;;; Section 3.5: Message Digest Output 317 318(declaim (inline md5regs-digest)) 319(defun md5regs-digest (regs) 320 "Create the final 16 byte message-digest from the MD5 working state 321in regs. Returns a (simple-array (unsigned-byte 8) (16))." 322 (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)) 323 (type md5-regs regs)) 324 (let ((result (make-array 16 :element-type '(unsigned-byte 8)))) 325 (declare (type (simple-array (unsigned-byte 8) (16)) result)) 326 (macrolet ((frob (reg offset) 327 (let ((var (gensym))) 328 `(let ((,var ,reg)) 329 (declare (type ub32 ,var)) 330 (setf 331 (aref result ,offset) (ldb (byte 8 0) ,var) 332 (aref result ,(+ offset 1)) (ldb (byte 8 8) ,var) 333 (aref result ,(+ offset 2)) (ldb (byte 8 16) ,var) 334 (aref result ,(+ offset 3)) (ldb (byte 8 24) ,var)))))) 335 (frob (md5-regs-a regs) 0) 336 (frob (md5-regs-b regs) 4) 337 (frob (md5-regs-c regs) 8) 338 (frob (md5-regs-d regs) 12)) 339 result)) 340 341;;; Mid-Level Drivers 342 343(defstruct (md5-state 344 (:constructor make-md5-state ()) 345 (:copier)) 346 (regs (initial-md5-regs) :type md5-regs :read-only t) 347 (amount 0 :type 348 #-md5-small-length (integer 0 *) 349 #+md5-small-length (unsigned-byte 29)) 350 (block (make-array 16 :element-type '(unsigned-byte 32)) :read-only t 351 :type (simple-array (unsigned-byte 32) (16))) 352 (buffer (make-array 64 :element-type '(unsigned-byte 8)) :read-only t 353 :type (simple-array (unsigned-byte 8) (64))) 354 (buffer-index 0 :type (integer 0 63)) 355 (finalized-p nil)) 356 357(declaim (inline copy-to-buffer)) 358(defun copy-to-buffer (from from-offset count buffer buffer-offset) 359 "Copy a partial segment from input vector from starting at 360from-offset and copying count elements into the 64 byte buffer 361starting at buffer-offset." 362 (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)) 363 (type (unsigned-byte 29) from-offset) 364 (type (integer 0 63) count buffer-offset) 365 (type (simple-array * (*)) from) 366 (type (simple-array (unsigned-byte 8) (64)) buffer)) 367 #+cmu 368 (kernel:bit-bash-copy 369 from (+ (* vm:vector-data-offset vm:word-bits) (* from-offset vm:byte-bits)) 370 buffer (+ (* vm:vector-data-offset vm:word-bits) 371 (* buffer-offset vm:byte-bits)) 372 (* count vm:byte-bits)) 373 #-cmu 374 (etypecase from 375 (simple-string 376 (loop for buffer-index of-type (integer 0 64) from buffer-offset 377 for from-index of-type fixnum from from-offset 378 below (+ from-offset count) 379 do 380 (setf (aref buffer buffer-index) 381 (char-code (schar (the simple-string from) from-index))))) 382 ((simple-array (unsigned-byte 8) (*)) 383 (loop for buffer-index of-type (integer 0 64) from buffer-offset 384 for from-index of-type fixnum from from-offset 385 below (+ from-offset count) 386 do 387 (setf (aref buffer buffer-index) 388 (aref (the (simple-array (unsigned-byte 8) (*)) from) 389 from-index)))))) 390 391(defun update-md5-state (state sequence &key (start 0) (end (length sequence))) 392 "Update the given md5-state from sequence, which is either a 393simple-string or a simple-array with element-type (unsigned-byte 8), 394bounded by start and end, which must be numeric bounding-indices." 395 (declare (type md5-state state) 396 (type (simple-array * (*)) sequence) 397 (type fixnum start end) 398 (optimize (speed 3) #+cmu (safety 0) (space 0) (debug 0)) 399 #+cmu 400 (ext:optimize-interface (safety 1) (debug 1))) 401 (let ((regs (md5-state-regs state)) 402 (block (md5-state-block state)) 403 (buffer (md5-state-buffer state))) 404 (declare (type md5-regs regs) 405 (type (simple-array (unsigned-byte 32) (16)) block) 406 (type (simple-array (unsigned-byte 8) (64)) buffer)) 407 ;; Handle old rest 408 (unless (zerop (md5-state-buffer-index state)) 409 (let* ((buffer-index (md5-state-buffer-index state)) 410 (remainder (- 64 buffer-index)) 411 (length (- end start)) 412 (amount (min remainder length))) 413 (declare (type (integer 0 63) buffer-index remainder amount) 414 (type fixnum length)) 415 (copy-to-buffer sequence start amount buffer buffer-index) 416 (setf (md5-state-amount state) 417 #-md5-small-length (+ (md5-state-amount state) amount) 418 #+md5-small-length (the (unsigned-byte 29) 419 (+ (md5-state-amount state) amount))) 420 (setq start (the fixnum (+ start amount))) 421 (if (< length remainder) 422 (setf (md5-state-buffer-index state) 423 (the (integer 0 63) (+ buffer-index amount))) 424 (progn 425 (fill-block-ub8 block buffer 0) 426 (update-md5-block regs block) 427 (setf (md5-state-buffer-index state) 0))))) 428 ;; Leave when nothing to do 429 (when (>= start end) 430 (return-from update-md5-state state)) 431 ;; Handle main-part and new-rest 432 (etypecase sequence 433 ((simple-array (unsigned-byte 8) (*)) 434 (locally 435 (declare (type (simple-array (unsigned-byte 8) (*)) sequence)) 436 (loop for offset of-type (unsigned-byte 29) from start below end by 64 437 until (< (- end offset) 64) 438 do 439 (fill-block-ub8 block sequence offset) 440 (update-md5-block regs block) 441 finally 442 (let ((amount (- end offset))) 443 (unless (zerop amount) 444 (copy-to-buffer sequence offset amount buffer 0)) 445 (setf (md5-state-buffer-index state) amount))))) 446 (simple-string 447 (locally 448 (declare (type simple-string sequence)) 449 (loop for offset of-type (unsigned-byte 29) from start below end by 64 450 until (< (- end offset) 64) 451 do 452 (fill-block-char block sequence offset) 453 (update-md5-block regs block) 454 finally 455 (let ((amount (- end offset))) 456 (unless (zerop amount) 457 (copy-to-buffer sequence offset amount buffer 0)) 458 (setf (md5-state-buffer-index state) amount)))))) 459 (setf (md5-state-amount state) 460 #-md5-small-length (+ (md5-state-amount state) 461 (the fixnum (- end start))) 462 #+md5-small-length (the (unsigned-byte 29) 463 (+ (md5-state-amount state) 464 (the fixnum (- end start))))) 465 state)) 466 467(defun finalize-md5-state (state) 468 "If the given md5-state has not already been finalized, finalize it, 469by processing any remaining input in its buffer, with suitable padding 470and appended bit-length, as specified by the MD5 standard. 471 472The resulting MD5 message-digest is returned as an array of sixteen 473(unsigned-byte 8) values. Calling `update-md5-state' after a call to 474`finalize-md5-state' results in unspecified behaviour." 475 (declare (type md5-state state) 476 (optimize (speed 3) #+cmu (safety 0) (space 0) (debug 0)) 477 #+cmu 478 (ext:optimize-interface (safety 1) (debug 1))) 479 (or (md5-state-finalized-p state) 480 (let ((regs (md5-state-regs state)) 481 (block (md5-state-block state)) 482 (buffer (md5-state-buffer state)) 483 (buffer-index (md5-state-buffer-index state)) 484 (total-length (* 8 (md5-state-amount state)))) 485 (declare (type md5-regs regs) 486 (type (integer 0 63) buffer-index) 487 (type (simple-array ub32 (16)) block) 488 (type (simple-array (unsigned-byte 8) (*)) buffer)) 489 ;; Add mandatory bit 1 padding 490 (setf (aref buffer buffer-index) #x80) 491 ;; Fill with 0 bit padding 492 (loop for index of-type (integer 0 64) 493 from (1+ buffer-index) below 64 494 do (setf (aref buffer index) #x00)) 495 (fill-block-ub8 block buffer 0) 496 ;; Flush block first if length wouldn't fit 497 (when (>= buffer-index 56) 498 (update-md5-block regs block) 499 ;; Create new fully 0 padded block 500 (loop for index of-type (integer 0 16) from 0 below 16 501 do (setf (aref block index) #x00000000))) 502 ;; Add 64bit message bit length 503 (setf (aref block 14) (ldb (byte 32 0) total-length)) 504 #-md5-small-length 505 (setf (aref block 15) (ldb (byte 32 32) total-length)) 506 ;; Flush last block 507 (update-md5-block regs block) 508 ;; Done, remember digest for later calls 509 (setf (md5-state-finalized-p state) 510 (md5regs-digest regs))))) 511 512;;; High-Level Drivers 513 514(defun md5sum-sequence (sequence &key (start 0) end) 515 "Calculate the MD5 message-digest of data in sequence. On CMU CL 516this works for all sequences whose element-type is supported by the 517underlying MD5 routines, on other implementations it only works for 1d 518simple-arrays with such element types." 519 (declare (optimize (speed 3) (space 0) (debug 0)) 520 (type vector sequence) (type fixnum start)) 521 (let ((state (make-md5-state))) 522 (declare (type md5-state state)) 523 #+cmu 524 (lisp::with-array-data ((data sequence) (real-start start) (real-end end)) 525 (update-md5-state state data :start real-start :end real-end)) 526 #-cmu 527 (let ((real-end (or end (length sequence)))) 528 (declare (type fixnum real-end)) 529 (update-md5-state state sequence :start start :end real-end)) 530 (finalize-md5-state state))) 531 532(eval-when (:compile-toplevel :load-toplevel :execute) 533 (defconstant +buffer-size+ (* 128 1024) 534 "Size of internal buffer to use for md5sum-stream and md5sum-file 535operations. This should be a multiple of 64, the MD5 block size.")) 536 537(deftype buffer-index () `(integer 0 ,+buffer-size+)) 538 539(defun md5sum-stream (stream) 540 "Calculate an MD5 message-digest of the contents of stream. Its 541element-type has to be either (unsigned-byte 8) or character." 542 (declare (optimize (speed 3) (space 0) (debug 0))) 543 (let ((state (make-md5-state))) 544 (declare (type md5-state state)) 545 (cond 546 ((equal (stream-element-type stream) '(unsigned-byte 8)) 547 (let ((buffer (make-array +buffer-size+ 548 :element-type '(unsigned-byte 8)))) 549 (declare (type (simple-array (unsigned-byte 8) (#.+buffer-size+)) 550 buffer)) 551 (loop for bytes of-type buffer-index = (read-sequence buffer stream) 552 do (update-md5-state state buffer :end bytes) 553 until (< bytes +buffer-size+) 554 finally 555 (return (finalize-md5-state state))))) 556 ((equal (stream-element-type stream) 'character) 557 (let ((buffer (make-string +buffer-size+))) 558 (declare (type (simple-string #.+buffer-size+) buffer)) 559 (loop for bytes of-type buffer-index = (read-sequence buffer stream) 560 do (update-md5-state state buffer :end bytes) 561 until (< bytes +buffer-size+) 562 finally 563 (return (finalize-md5-state state))))) 564 (t 565 (error "Unsupported stream element-type ~S for stream ~S." 566 (stream-element-type stream) stream))))) 567 568(defun md5sum-file (pathname) 569 "Calculate the MD5 message-digest of the file specified by pathname." 570 (declare (optimize (speed 3) (space 0) (debug 0))) 571 (with-open-file (stream pathname :element-type '(unsigned-byte 8)) 572 (md5sum-stream stream))) 573 574#+md5-testing 575(defconstant +rfc1321-testsuite+ 576 '(("" . "d41d8cd98f00b204e9800998ecf8427e") 577 ("a" ."0cc175b9c0f1b6a831c399e269772661") 578 ("abc" . "900150983cd24fb0d6963f7d28e17f72") 579 ("message digest" . "f96b697d7cb7938d525a2f31aaf161d0") 580 ("abcdefghijklmnopqrstuvwxyz" . "c3fcd3d76192e4007dfb496cca67e13b") 581 ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" . 582 "d174ab98d277d9f5a5611c2c9f419d9f") 583 ("12345678901234567890123456789012345678901234567890123456789012345678901234567890" . 584 "57edf4a22be3c955ac49da2e2107b67a")) 585 "AList of test input strings and stringified message-digests 586according to the test suite in Appendix A.5 of RFC 1321") 587 588#+md5-testing 589(defconstant +other-testsuite+ 590 '(;; From padding bug report by Edi Weitz 591 ("1631901HERR BUCHHEISTERCITROEN NORD1043360796beckenbauer" . 592 "d734945e5930bb28859ccd13c830358b") 593 ;; Test padding for strings from 0 to 69*8 bits in size. 594 ("" . "d41d8cd98f00b204e9800998ecf8427e") 595 ("a" . "0cc175b9c0f1b6a831c399e269772661") 596 ("aa" . "4124bc0a9335c27f086f24ba207a4912") 597 ("aaa" . "47bce5c74f589f4867dbd57e9ca9f808") 598 ("aaaa" . "74b87337454200d4d33f80c4663dc5e5") 599 ("aaaaa" . "594f803b380a41396ed63dca39503542") 600 ("aaaaaa" . "0b4e7a0e5fe84ad35fb5f95b9ceeac79") 601 ("aaaaaaa" . "5d793fc5b00a2348c3fb9ab59e5ca98a") 602 ("aaaaaaaa" . "3dbe00a167653a1aaee01d93e77e730e") 603 ("aaaaaaaaa" . "552e6a97297c53e592208cf97fbb3b60") 604 ("aaaaaaaaaa" . "e09c80c42fda55f9d992e59ca6b3307d") 605 ("aaaaaaaaaaa" . "d57f21e6a273781dbf8b7657940f3b03") 606 ("aaaaaaaaaaaa" . "45e4812014d83dde5666ebdf5a8ed1ed") 607 ("aaaaaaaaaaaaa" . "c162de19c4c3731ca3428769d0cd593d") 608 ("aaaaaaaaaaaaaa" . "451599a5f9afa91a0f2097040a796f3d") 609 ("aaaaaaaaaaaaaaa" . "12f9cf6998d52dbe773b06f848bb3608") 610 ("aaaaaaaaaaaaaaaa" . "23ca472302f49b3ea5592b146a312da0") 611 ("aaaaaaaaaaaaaaaaa" . "88e42e96cc71151b6e1938a1699b0a27") 612 ("aaaaaaaaaaaaaaaaaa" . "2c60c24e7087e18e45055a33f9a5be91") 613 ("aaaaaaaaaaaaaaaaaaa" . "639d76897485360b3147e66e0a8a3d6c") 614 ("aaaaaaaaaaaaaaaaaaaa" . "22d42eb002cefa81e9ad604ea57bc01d") 615 ("aaaaaaaaaaaaaaaaaaaaa" . "bd049f221af82804c5a2826809337c9b") 616 ("aaaaaaaaaaaaaaaaaaaaaa" . "ff49cfac3968dbce26ebe7d4823e58bd") 617 ("aaaaaaaaaaaaaaaaaaaaaaa" . "d95dbfee231e34cccb8c04444412ed7d") 618 ("aaaaaaaaaaaaaaaaaaaaaaaa" . "40edae4bad0e5bf6d6c2dc5615a86afb") 619 ("aaaaaaaaaaaaaaaaaaaaaaaaa" . "a5a8bfa3962f49330227955e24a2e67c") 620 ("aaaaaaaaaaaaaaaaaaaaaaaaaa" . "ae791f19bdf77357ff10bb6b0e97e121") 621 ("aaaaaaaaaaaaaaaaaaaaaaaaaaa" . "aaab9c59a88bf0bdfcb170546c5459d6") 622 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "b0f0545856af1a340acdedce23c54b97") 623 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "f7ce3d7d44f3342107d884bfa90c966a") 624 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "59e794d45697b360e18ba972bada0123") 625 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "3b0845db57c200be6052466f87b2198a") 626 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "5eca9bd3eb07c006cd43ae48dfde7fd3") 627 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "b4f13cb081e412f44e99742cb128a1a5") 628 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "4c660346451b8cf91ef50f4634458d41") 629 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 630 "11db24dc3f6c2145701db08625dd6d76") 631 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 632 "80dad3aad8584778352c68ab06250327") 633 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 634 "1227fe415e79db47285cb2689c93963f") 635 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 636 "8e084f489f1bdf08c39f98ff6447ce6d") 637 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 638 "08b2f2b0864bac1ba1585043362cbec9") 639 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 640 "4697843037d962f62a5a429e611e0f5f") 641 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 642 "10c4da18575c092b486f8ab96c01c02f") 643 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 644 "af205d729450b663f48b11d839a1c8df") 645 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 646 "0d3f91798fac6ee279ec2485b25f1124") 647 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 648 "4c3c7c067634daec9716a80ea886d123") 649 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 650 "d1e358e6e3b707282cdd06e919f7e08c") 651 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 652 "8c6ded4f0af86e0a7e301f8a716c4363") 653 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 654 "4c2d8bcb02d982d7cb77f649c0a2dea8") 655 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 656 "bdb662f765cd310f2a547cab1cfecef6") 657 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 658 "08ff5f7301d30200ab89169f6afdb7af") 659 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 660 "6eb6a030bcce166534b95bc2ab45d9cf") 661 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 662 "1bb77918e5695c944be02c16ae29b25e") 663 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 664 "b6fe77c19f0f0f4946c761d62585bfea") 665 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 666 "e9e7e260dce84ffa6e0e7eb5fd9d37fc") 667 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 668 "eced9e0b81ef2bba605cbc5e2e76a1d0") 669 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 670 "ef1772b6dff9a122358552954ad0df65") 671 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 672 "3b0c8ac703f828b04c6c197006d17218") 673 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 674 "652b906d60af96844ebd21b674f35e93") 675 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 676 "dc2f2f2462a0d72358b2f99389458606") 677 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 678 "762fc2665994b217c52c3c2eb7d9f406") 679 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 680 "cc7ed669cf88f201c3297c6a91e1d18d") 681 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 682 "cced11f7bbbffea2f718903216643648") 683 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 684 "24612f0ce2c9d2cf2b022ef1e027a54f") 685 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 686 "b06521f39153d618550606be297466d5") 687 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 688 "014842d480b571495a4a0363793f7367") 689 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 690 "c743a45e0d2e6a95cb859adae0248435") 691 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 692 "def5d97e01e1219fb2fc8da6c4d6ba2f") 693 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 694 "92cb737f8687ccb93022fdb411a77cca") 695 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 696 "a0d1395c7fb36247bfe2d49376d9d133") 697 ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . 698 "ab75504250558b788f99d1ebd219abf2")) 699 "AList of test input strings and stringified message-digests 700according to my additional test suite") 701 702#+md5-testing 703(defun test-with-testsuite (testsuite) 704 (loop for count from 1 705 for (source . md5-string) in testsuite 706 for md5-digest = (md5sum-sequence source) 707 for md5-result-string = (format nil "~(~{~2,'0X~}~)" 708 (map 'list #'identity md5-digest)) 709 do 710 (format 711 *trace-output* 712 "~2&Test-Case ~D:~% Input: ~S~% Required: ~A~% Returned: ~A~%" 713 count source md5-string md5-result-string) 714 when (string= md5-string md5-result-string) 715 do (format *trace-output* " OK~%") 716 else 717 count 1 into failed 718 and do (format *trace-output* " FAILED~%") 719 finally 720 (format *trace-output* 721 "~2&~[All ~D test cases succeeded~:;~:*~D of ~D test cases failed~].~%" 722 failed (1- count)) 723 (return (zerop failed)))) 724 725#+md5-testing 726(defun test-rfc1321 () 727 (test-with-testsuite +rfc1321-testsuite+)) 728 729#+md5-testing 730(defun test-other () 731 (test-with-testsuite +other-testsuite+)) 732 733#+cmu 734(eval-when (:compile-toplevel :execute) 735 (setq *features* *old-features*)) 736 737#+cmu 738(eval-when (:compile-toplevel) 739 (setq ext:*inline-expansion-limit* *old-expansion-limit*)) 740