r4803: *** empty log message ***
authorKevin M. Rosenberg <kevin@rosenberg.net>
Sun, 4 May 2003 19:12:26 +0000 (19:12 +0000)
committerKevin M. Rosenberg <kevin@rosenberg.net>
Sun, 4 May 2003 19:12:26 +0000 (19:12 +0000)
md5.lisp

index ce85d8e..941f188 100644 (file)
--- 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
 
 ;;; 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*))