0.9.46.7:

	Fix SB-MD5 bugs:
	* Updating the MD5 state with a "short" sequence was buggy;
	  ...and the moral of the story is: (SAFETY 0) hides real bugs
	* MD5SUM-SEQUENCE did not respect fill pointers.

diff --git a/contrib/sb-md5/md5-tests.lisp b/contrib/sb-md5/md5-tests.lisp
index c0f8da1..5c0aff6 100644 (file)
--- a/contrib/sb-md5/md5-tests.lisp
+++ b/contrib/sb-md5/md5-tests.lisp
@@ -2,18 +2,45 @@
   (:use #:sb-md5 #:cl #:sb-rt))
 (in-package #:sb-md5-tests)
 
+(defun byte-array-to-hex-string (bytevec)
+  (format nil "~(~{~2,'0X~}~)" (coerce bytevec 'list)))
+
+(defun one-shot-test (string)
+  (md5sum-string string :external-format :ascii))
+
+(defun incremental-test (string)
+  (let ((bytevec (sb-ext:string-to-octets string :external-format :ascii))
+        (state (sb-md5:make-md5-state)))
+    (dotimes (i (length bytevec) (sb-md5:finalize-md5-state state))
+      (sb-md5:update-md5-state state bytevec :start i :end (1+ i)))))
+
+(defun fill-pointer-test (string)
+  (let* ((bytevec (sb-ext:string-to-octets string :external-format :ascii))
+         (fillvec (let ((x (make-array (* 2 (length bytevec))
+                                       :fill-pointer 0
+                                       :element-type '(unsigned-byte 8))))
+                    (dotimes (i (length bytevec) x)
+                      (vector-push (aref bytevec i) x)))))
+    (sb-md5:md5sum-sequence fillvec)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defun tests-for-test-suite (basename index string expected-result)
+  (loop for (test-kind testfun) in '(("ONE-SHOT" one-shot-test)
+                                     ("INCREMENTAL" incremental-test)
+                                     ("FILL-POINTER" fill-pointer-test))
+     collect `(deftest ,(intern (format nil "~A.~A.~A" basename test-kind index))
+                  (string= (byte-array-to-hex-string (funcall ',testfun ,string))
+                           ,expected-result)
+                t) into test-forms
+       finally (return `(progn ,@test-forms))))
+) ; EVAL-WHEN
+    
 (macrolet
     ((define-rfc1321-tests (test-list)
          `(progn
            ,@(loop for i upfrom 0
                    for (string . expected-result) in test-list
-                   collect
-                   `(deftest ,(intern (format nil "SB-MD5.RFC1321.~A" i))
-                     (string= (format nil
-                               "~(~{~2,'0X~}~)"
-                               (coerce (md5sum-string ,string :external-format :ascii) 'list))
-                      ,expected-result)
-                     t)))))
+                   collect (tests-for-test-suite "SB-MD5.RFC1321" i string expected-result)))))
   (define-rfc1321-tests
       (("" . "d41d8cd98f00b204e9800998ecf8427e")
        ("a" ."0cc175b9c0f1b6a831c399e269772661")
@@ -28,13 +55,7 @@
          `(progn
            ,@(loop for i upfrom 0
                    for (string . expected-result) in test-list
-                   collect
-                   `(deftest ,(intern (format nil "SB-MD5.OTHER.~A" i))
-                     (string=
-                      (format nil "~(~{~2,'0X~}~)"
-                       (coerce (md5sum-string ,string :external-format :ascii) 'list))
-                      ,expected-result)
-                     t)))))
+                   collect (tests-for-test-suite "SB-MD5.OTHER" i string expected-result)))))
   (define-other-tests
       (;; From padding bug report by Edi Weitz
        ("1631901HERR BUCHHEISTERCITROEN NORD1043360796beckenbauer" . "d734945e5930bb28859ccd13c830358b")

diff --git a/contrib/sb-md5/md5.lisp b/contrib/sb-md5/md5.lisp
index 4d7edac..54d5810 100644 (file)
--- a/contrib/sb-md5/md5.lisp
+++ b/contrib/sb-md5/md5.lisp
@@ -416,11 +416,14 @@ bounded by start and end, which must be numeric bounding-indices."
         (declare (type (integer 0 63) amount))
         (copy-to-buffer sequence start amount buffer buffer-index)
         (setq start (the fixnum (+ start amount)))
-        (when (>= start end)
-          (setf (md5-state-buffer-index state) (+ buffer-index amount))
-          (return-from update-md5-state state)))
-      (fill-block-ub8 block buffer 0)
-      (update-md5-block regs block))
+        (let ((new-index (mod (+ buffer-index amount) 64)))
+          (when (zerop new-index)
+            (fill-block-ub8 block buffer 0)
+            (update-md5-block regs block))
+          (when (>= start end)
+            (setf (md5-state-buffer-index state) new-index)
+            (incf (md5-state-amount state) length)
+            (return-from update-md5-state state)))))
     ;; Handle main-part and new-rest
     (etypecase sequence
       ((simple-array (unsigned-byte 8) (*))
@@ -513,11 +516,19 @@ in SEQUENCE , which must be a vector with element-type (UNSIGNED-BYTE
     (let ((state (make-md5-state)))
       (declare (type md5-state state))
       #+cmu
-      (lisp::with-array-data ((data sequence) (real-start start) (real-end end))
-        (update-md5-state state data :start real-start :end real-end))
+      ;; respect the fill pointer
+      (let ((end (or end (length sequence))))
+        (lisp::with-array-data ((data sequence) (real-start start) (real-end end))
+          (declare (ignore real-end))
+          (update-md5-state state data :start real-start
+                            :end (+ real-start (- end start)))))
       #+sbcl
-      (sb-kernel:with-array-data ((data sequence) (real-start start) (real-end end))
-        (update-md5-state state data :start real-start :end real-end))
+      ;; respect the fill pointer
+      (let ((end (or end (length sequence))))
+        (sb-kernel:with-array-data ((data sequence) (real-start start) (real-end end))
+          (declare (ignore real-end))
+          (update-md5-state state data :start real-start
+                            :end (+ real-start (- end start)))))
       #-(or cmu sbcl)
       (let ((real-end (or end (length sequence))))
         (declare (type fixnum real-end))

diff --git a/version.lisp-expr b/version.lisp-expr
index 8309609..51c538a 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.9.6.46"
+"0.9.6.47"