From: Kevin M. Rosenberg Date: Sun, 4 May 2003 19:12:26 +0000 (+0000) Subject: r4803: *** empty log message *** X-Git-Tag: v1.8.5~13 X-Git-Url: http://git.kpe.io/?p=md5.git;a=commitdiff_plain;h=40f3c97fb68ce35a0eaaa6cc66768f3b3ca8751b r4803: *** empty log message *** --- diff --git a/md5.lisp b/md5.lisp index ce85d8e..941f188 100644 --- a/md5.lisp +++ b/md5.lisp @@ -5,7 +5,7 @@ ;;;; cmucl-help mailing-list hosted at cons.org, in November 2001 and ;;;; has been placed into the public domain. ;;;; -;;;; $Id: md5.lisp,v 1.2 2002/11/11 11:17:56 kevin Exp $ +;;;; $Id: md5.lisp,v 1.3 2003/05/04 19:12:26 kevin Exp $ ;;;; ;;;; While the implementation should work on all conforming Common ;;;; Lisp implementations, it has only been optimized for CMU CL, @@ -31,6 +31,8 @@ ;;;; *features* prior to compilation. In that case evaluating ;;;; (md5::test-rfc1321) will run all the test-cases present in ;;;; Appendix A.5 of RFC 1321 and report on the results. +;;;; Evaluating (md5::test-other) will run further test-cases +;;;; gathered by the author to cover regressions, etc. ;;;; ;;;; This software is "as is", and has no warranty of any kind. The ;;;; authors assume no responsibility for the consequences of any use @@ -61,10 +63,9 @@ ;;; Section 2: Basic Datatypes -(eval-when (:compile-toplevel :load-toplevel :execute) (deftype ub32 () "Corresponds to the 32bit quantity word of the MD5 Spec" - `(unsigned-byte 32))) + `(unsigned-byte 32)) (defmacro assemble-ub32 (a b c d) "Assemble an ub32 value from the given (unsigned-byte 8) values, @@ -464,23 +465,26 @@ The resulting MD5 message-digest is returned as an array of sixteen (type (integer 0 63) buffer-index) (type (simple-array ub32 (16)) block) (type (simple-array (unsigned-byte 8) (*)) buffer)) + ;; Add mandatory bit 1 padding (setf (aref buffer buffer-index) #x80) + ;; Fill with 0 bit padding (loop for index of-type (integer 0 64) from (1+ buffer-index) below 64 do (setf (aref buffer index) #x00)) (fill-block-ub8 block buffer 0) - (when (< buffer-index 56) - (setf (aref block 14) (ldb (byte 32 0) total-length)) - #-md5-small-length - (setf (aref block 15) (ldb (byte 32 32) total-length))) - (update-md5-block regs block) - (when (< 56 buffer-index 64) + ;; Flush block first if length wouldn't fit + (when (>= buffer-index 56) + (update-md5-block regs block) + ;; Create new fully 0 padded block (loop for index of-type (integer 0 16) from 0 below 16 - do (setf (aref block index) #x00000000)) - (setf (aref block 14) (ldb (byte 32 0) total-length)) - #-md5-small-length - (setf (aref block 15) (ldb (byte 32 32) total-length)) - (update-md5-block regs block)) + do (setf (aref block index) #x00000000))) + ;; Add 64bit message bit length + (setf (aref block 14) (ldb (byte 32 0) total-length)) + #-md5-small-length + (setf (aref block 15) (ldb (byte 32 32) total-length)) + ;; Flush last block + (update-md5-block regs block) + ;; Done, remember digest for later calls (setf (md5-state-finalized-p state) (md5regs-digest regs))))) @@ -504,10 +508,9 @@ simple-arrays with such element types." (update-md5-state state sequence :start start :end real-end)) (finalize-md5-state state))) -(eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +buffer-size+ (* 128 1024) "Size of internal buffer to use for md5sum-stream and md5sum-file -operations. This should be a multiple of 64, the MD5 block size.")) +operations. This should be a multiple of 64, the MD5 block size.") (deftype buffer-index () `(integer 0 ,+buffer-size+)) @@ -561,9 +564,123 @@ element-type has to be either (unsigned-byte 8) or character." according to the test suite in Appendix A.5 of RFC 1321") #+md5-testing -(defun test-rfc1321 () +(defconstant +other-testsuite+ + '(;; From padding bug report by Edi Weitz + ("1631901HERR BUCHHEISTERCITROEN NORD1043360796beckenbauer" . + "d734945e5930bb28859ccd13c830358b") + ;; Test padding for strings from 0 to 69*8 bits in size. + ("" . "d41d8cd98f00b204e9800998ecf8427e") + ("a" . "0cc175b9c0f1b6a831c399e269772661") + ("aa" . "4124bc0a9335c27f086f24ba207a4912") + ("aaa" . "47bce5c74f589f4867dbd57e9ca9f808") + ("aaaa" . "74b87337454200d4d33f80c4663dc5e5") + ("aaaaa" . "594f803b380a41396ed63dca39503542") + ("aaaaaa" . "0b4e7a0e5fe84ad35fb5f95b9ceeac79") + ("aaaaaaa" . "5d793fc5b00a2348c3fb9ab59e5ca98a") + ("aaaaaaaa" . "3dbe00a167653a1aaee01d93e77e730e") + ("aaaaaaaaa" . "552e6a97297c53e592208cf97fbb3b60") + ("aaaaaaaaaa" . "e09c80c42fda55f9d992e59ca6b3307d") + ("aaaaaaaaaaa" . "d57f21e6a273781dbf8b7657940f3b03") + ("aaaaaaaaaaaa" . "45e4812014d83dde5666ebdf5a8ed1ed") + ("aaaaaaaaaaaaa" . "c162de19c4c3731ca3428769d0cd593d") + ("aaaaaaaaaaaaaa" . "451599a5f9afa91a0f2097040a796f3d") + ("aaaaaaaaaaaaaaa" . "12f9cf6998d52dbe773b06f848bb3608") + ("aaaaaaaaaaaaaaaa" . "23ca472302f49b3ea5592b146a312da0") + ("aaaaaaaaaaaaaaaaa" . "88e42e96cc71151b6e1938a1699b0a27") + ("aaaaaaaaaaaaaaaaaa" . "2c60c24e7087e18e45055a33f9a5be91") + ("aaaaaaaaaaaaaaaaaaa" . "639d76897485360b3147e66e0a8a3d6c") + ("aaaaaaaaaaaaaaaaaaaa" . "22d42eb002cefa81e9ad604ea57bc01d") + ("aaaaaaaaaaaaaaaaaaaaa" . "bd049f221af82804c5a2826809337c9b") + ("aaaaaaaaaaaaaaaaaaaaaa" . "ff49cfac3968dbce26ebe7d4823e58bd") + ("aaaaaaaaaaaaaaaaaaaaaaa" . "d95dbfee231e34cccb8c04444412ed7d") + ("aaaaaaaaaaaaaaaaaaaaaaaa" . "40edae4bad0e5bf6d6c2dc5615a86afb") + ("aaaaaaaaaaaaaaaaaaaaaaaaa" . "a5a8bfa3962f49330227955e24a2e67c") + ("aaaaaaaaaaaaaaaaaaaaaaaaaa" . "ae791f19bdf77357ff10bb6b0e97e121") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaa" . "aaab9c59a88bf0bdfcb170546c5459d6") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "b0f0545856af1a340acdedce23c54b97") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "f7ce3d7d44f3342107d884bfa90c966a") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "59e794d45697b360e18ba972bada0123") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "3b0845db57c200be6052466f87b2198a") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "5eca9bd3eb07c006cd43ae48dfde7fd3") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "b4f13cb081e412f44e99742cb128a1a5") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "4c660346451b8cf91ef50f4634458d41") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "11db24dc3f6c2145701db08625dd6d76") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "80dad3aad8584778352c68ab06250327") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "1227fe415e79db47285cb2689c93963f") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "8e084f489f1bdf08c39f98ff6447ce6d") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "08b2f2b0864bac1ba1585043362cbec9") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "4697843037d962f62a5a429e611e0f5f") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "10c4da18575c092b486f8ab96c01c02f") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "af205d729450b663f48b11d839a1c8df") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "0d3f91798fac6ee279ec2485b25f1124") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "4c3c7c067634daec9716a80ea886d123") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "d1e358e6e3b707282cdd06e919f7e08c") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "8c6ded4f0af86e0a7e301f8a716c4363") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "4c2d8bcb02d982d7cb77f649c0a2dea8") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "bdb662f765cd310f2a547cab1cfecef6") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "08ff5f7301d30200ab89169f6afdb7af") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "6eb6a030bcce166534b95bc2ab45d9cf") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "1bb77918e5695c944be02c16ae29b25e") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "b6fe77c19f0f0f4946c761d62585bfea") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "e9e7e260dce84ffa6e0e7eb5fd9d37fc") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "eced9e0b81ef2bba605cbc5e2e76a1d0") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "ef1772b6dff9a122358552954ad0df65") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "3b0c8ac703f828b04c6c197006d17218") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "652b906d60af96844ebd21b674f35e93") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "dc2f2f2462a0d72358b2f99389458606") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "762fc2665994b217c52c3c2eb7d9f406") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "cc7ed669cf88f201c3297c6a91e1d18d") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "cced11f7bbbffea2f718903216643648") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "24612f0ce2c9d2cf2b022ef1e027a54f") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "b06521f39153d618550606be297466d5") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "014842d480b571495a4a0363793f7367") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "c743a45e0d2e6a95cb859adae0248435") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "def5d97e01e1219fb2fc8da6c4d6ba2f") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "92cb737f8687ccb93022fdb411a77cca") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "a0d1395c7fb36247bfe2d49376d9d133") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "ab75504250558b788f99d1ebd219abf2")) + "AList of test input strings and stringified message-digests +according to my additional test suite") + +#+md5-testing +(defun test-with-testsuite (testsuite) (loop for count from 1 - for (source . md5-string) in +rfc1321-testsuite+ + for (source . md5-string) in testsuite for md5-digest = (md5sum-sequence source) for md5-result-string = (format nil "~(~{~2,'0X~}~)" (map 'list #'identity md5-digest)) @@ -583,6 +700,14 @@ according to the test suite in Appendix A.5 of RFC 1321") failed (1- count)) (return (zerop failed)))) +#+md5-testing +(defun test-rfc1321 () + (test-with-testsuite +rfc1321-testsuite+)) + +#+md5-testing +(defun test-other () + (test-with-testsuite +other-testsuite+)) + #+cmu (eval-when (:compile-toplevel :execute) (setq *features* *old-features*))