[prev in list] [next in list] [prev in thread] [next in thread]
List: sbcl-commits
Subject: [Sbcl-commits] master: Incorporate latest code from MD5 github repo
From: "Douglas Katzman" <snuglas () users ! sourceforge ! net>
Date: 2017-04-21 19:58:30
Message-ID: 1492804711.343642.26899 () sfp-scm-1 ! v30 ! ch3 ! sourceforge ! com
[Download RAW message or body]
The branch "master" has been updated in SBCL:
via 1d44b0f080420b72b9d0a993a16d34f73c66e95c (commit)
from 92424e4082ba4a92f593d4328a459e290d6f822c (commit)
- Log -----------------------------------------------------------------
commit 1d44b0f080420b72b9d0a993a16d34f73c66e95c
Author: Douglas Katzman <dougk@google.com>
Date: Fri Apr 21 15:41:41 2017 -0400
Incorporate latest code from MD5 github repo
---
NEWS | 4 +
contrib/sb-md5/COPYING | 130 +++++++
contrib/sb-md5/NEWS | 57 ++++
contrib/sb-md5/md5.lisp | 849 +++++++++++++++++++++++++++++++++++-----------
contrib/sb-md5/sb-md5.asd | 24 +-
5 files changed, 866 insertions(+), 198 deletions(-)
diff --git a/NEWS b/NEWS
index bb14a80..c3fab3c 100644
--- a/NEWS
+++ b/NEWS
@@ -9,6 +9,10 @@ changes relative to sbcl-1.3.16:
for page faults outside of dynamic space by changing the C symbol
"sbcl_fallback_sigsegv_handler".
* bug fix: sb-cover does not lose source positions for AND/OR/COND.
+ * The bundled sb-md5 contrib has been updated to release 2.0.4
+ which is licensed under Creative Commons CC0 per author's statement
+ https://github.com/pmai/md5/commit/fd134e71b71a10ab78905833a7cb9d4d6817c589
+ (Refer to NEWS and COPYING in the contrib/sb-md5 subdirectory)
changes in sbcl-1.3.16 relative to sbcl-1.3.15:
* optimization: various small tweaks give around 5% faster garbage
diff --git a/contrib/sb-md5/COPYING b/contrib/sb-md5/COPYING
new file mode 100644
index 0000000..13a75db
--- /dev/null
+++ b/contrib/sb-md5/COPYING
@@ -0,0 +1,130 @@
+This software has been placed into the public domain.
+
+This software is "as is", and has no warranty of any kind. The
+authors assume no responsibility for the consequences of any use of
+this software.
+
+Additionally for all parts of this software ("The Work" below) authored
+by Pierre R. Mai copyright is waived under the CC0 as affirmed below:
+
+Creative Commons Legal Code
+
+CC0 1.0 Universal
+
+ CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE
+ LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN
+ ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS
+ INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES
+ REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS
+ PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM
+ THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED
+ HEREUNDER.
+
+Statement of Purpose
+
+The laws of most jurisdictions throughout the world automatically confer
+exclusive Copyright and Related Rights (defined below) upon the creator
+and subsequent owner(s) (each and all, an "owner") of an original work of
+authorship and/or a database (each, a "Work").
+
+Certain owners wish to permanently relinquish those rights to a Work for
+the purpose of contributing to a commons of creative, cultural and
+scientific works ("Commons") that the public can reliably and without fear
+of later claims of infringement build upon, modify, incorporate in other
+works, reuse and redistribute as freely as possible in any form whatsoever
+and for any purposes, including without limitation commercial purposes.
+These owners may contribute to the Commons to promote the ideal of a free
+culture and the further production of creative, cultural and scientific
+works, or to gain reputation or greater distribution for their Work in
+part through the use and efforts of others.
+
+For these and/or other purposes and motivations, and without any
+expectation of additional consideration or compensation, the person
+associating CC0 with a Work (the "Affirmer"), to the extent that he or she
+is an owner of Copyright and Related Rights in the Work, voluntarily
+elects to apply CC0 to the Work and publicly distribute the Work under its
+terms, with knowledge of his or her Copyright and Related Rights in the
+Work and the meaning and intended legal effect of CC0 on those rights.
+
+1. Copyright and Related Rights. A Work made available under CC0 may be
+protected by copyright and related or neighboring rights ("Copyright and
+Related Rights"). Copyright and Related Rights include, but are not
+limited to, the following:
+
+ i. the right to reproduce, adapt, distribute, perform, display,
+ communicate, and translate a Work;
+ ii. moral rights retained by the original author(s) and/or performer(s);
+iii. publicity and privacy rights pertaining to a person's image or
+ likeness depicted in a Work;
+ iv. rights protecting against unfair competition in regards to a Work,
+ subject to the limitations in paragraph 4(a), below;
+ v. rights protecting the extraction, dissemination, use and reuse of data
+ in a Work;
+ vi. database rights (such as those arising under Directive 96/9/EC of the
+ European Parliament and of the Council of 11 March 1996 on the legal
+ protection of databases, and under any national implementation
+ thereof, including any amended or successor version of such
+ directive); and
+vii. other similar, equivalent or corresponding rights throughout the
+ world based on applicable law or treaty, and any national
+ implementations thereof.
+
+2. Waiver. To the greatest extent permitted by, but not in contravention
+of, applicable law, Affirmer hereby overtly, fully, permanently,
+irrevocably and unconditionally waives, abandons, and surrenders all of
+Affirmer's Copyright and Related Rights and associated claims and causes
+of action, whether now known or unknown (including existing as well as
+future claims and causes of action), in the Work (i) in all territories
+worldwide, (ii) for the maximum duration provided by applicable law or
+treaty (including future time extensions), (iii) in any current or future
+medium and for any number of copies, and (iv) for any purpose whatsoever,
+including without limitation commercial, advertising or promotional
+purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each
+member of the public at large and to the detriment of Affirmer's heirs and
+successors, fully intending that such Waiver shall not be subject to
+revocation, rescission, cancellation, termination, or any other legal or
+equitable action to disrupt the quiet enjoyment of the Work by the public
+as contemplated by Affirmer's express Statement of Purpose.
+
+3. Public License Fallback. Should any part of the Waiver for any reason
+be judged legally invalid or ineffective under applicable law, then the
+Waiver shall be preserved to the maximum extent permitted taking into
+account Affirmer's express Statement of Purpose. In addition, to the
+extent the Waiver is so judged Affirmer hereby grants to each affected
+person a royalty-free, non transferable, non sublicensable, non exclusive,
+irrevocable and unconditional license to exercise Affirmer's Copyright and
+Related Rights in the Work (i) in all territories worldwide, (ii) for the
+maximum duration provided by applicable law or treaty (including future
+time extensions), (iii) in any current or future medium and for any number
+of copies, and (iv) for any purpose whatsoever, including without
+limitation commercial, advertising or promotional purposes (the
+"License"). The License shall be deemed effective as of the date CC0 was
+applied by Affirmer to the Work. Should any part of the License for any
+reason be judged legally invalid or ineffective under applicable law, such
+partial invalidity or ineffectiveness shall not invalidate the remainder
+of the License, and in such case Affirmer hereby affirms that he or she
+will not (i) exercise any of his or her remaining Copyright and Related
+Rights in the Work or (ii) assert any associated claims and causes of
+action with respect to the Work, in either case contrary to Affirmer's
+express Statement of Purpose.
+
+4. Limitations and Disclaimers.
+
+ a. No trademark or patent rights held by Affirmer are waived, abandoned,
+ surrendered, licensed or otherwise affected by this document.
+ b. Affirmer offers the Work as-is and makes no representations or
+ warranties of any kind concerning the Work, express, implied,
+ statutory or otherwise, including without limitation warranties of
+ title, merchantability, fitness for a particular purpose, non
+ infringement, or the absence of latent or other defects, accuracy, or
+ the present or absence of errors, whether or not discoverable, all to
+ the greatest extent permissible under applicable law.
+ c. Affirmer disclaims responsibility for clearing rights of other persons
+ that may apply to the Work or any use thereof, including without
+ limitation any person's Copyright and Related Rights in the Work.
+ Further, Affirmer disclaims responsibility for obtaining any necessary
+ consents, permissions or other rights required for any use of the
+ Work.
+ d. Affirmer understands and acknowledges that Creative Commons is not a
+ party to this document and has no duty or obligation with respect to
+ this CC0 or use of the Work.
diff --git a/contrib/sb-md5/NEWS b/contrib/sb-md5/NEWS
new file mode 100644
index 0000000..0c42cae
--- /dev/null
+++ b/contrib/sb-md5/NEWS
@@ -0,0 +1,57 @@
+Release 2.0.4
+=============
+
+ * Clarified public domain status for code authored by Pierre R. Mai
+ through additional CC0 waiver.
+
+Release 2.0.3
+=============
+
+ * Add support for md5sum-string for other implementations through
+ through flexi-streams. Patch supplied by Daniel Kochmanski.
+
+
+Release 2.0.2
+=============
+
+ * This release adds support for LispWorks 7.0, reworking the fixes
+ for 64-bit implementations of Lispworks in 2.0.1 and incorrect
+ use of the sys:simple-int32-vector type. Patch supplied by
+ Martin Simmons from LispWorks.
+
+ * Minor fix to prevent style-warnings for implementations with no
+ support for md5sum-string.
+
+
+Release 2.0.1
+=============
+
+ * This release fixes problems on 64-bit implementations of Lispworks,
+ where sys:int32 arithmetic can overflow 32-bit values and hence
+ yield wrong results.
+
+
+Release 2.0.0
+=============
+
+ * This release consolidates the various versions of md5 that have
+ been floating around, including versions with Lispworks
+ optimizations, the version maintained by Kevin M. Rosenberg, the
+ SBCL-optimized version, and various patches and fixes.
+
+ * This release tries to separate out string-handling from actual
+ byte-based MD5 hash generation. Hence users who want to generate
+ hashes from strings should use the new md5sum-string function,
+ which will go through your implementation's external-format
+ handling to generate the actual byte-array that is hashed. Usage
+ of md5sum-sequence for strings and md5sum-stream for character
+ streams is deprecated, since it only ever worked correctly for 8bit
+ characters in most implementations.
+
+ * This release should work correctly on at least recentish versions
+ of CMUCL, SBCL, ECL, CCL, Lispworks, AllegroCL and ABCL and
+ generally most other conforming implementations. It has been
+ optimized for CMUCL, SBCL and Lispworks, and should work with
+ adequate performance on most 64bit implementations. Performance on
+ other 32bit implementations is still sub-optimal if they don't
+ support unboxed bit-operations on (unsigned-byte 32).
diff --git a/contrib/sb-md5/md5.lisp b/contrib/sb-md5/md5.lisp
index 39fd10e..e8f5f99 100644
--- a/contrib/sb-md5/md5.lisp
+++ b/contrib/sb-md5/md5.lisp
@@ -1,31 +1,56 @@
;;;; This file implements The MD5 Message-Digest Algorithm, as defined in
;;;; RFC 1321 by R. Rivest, published April 1992.
;;;;
-;;;; It was written by Pierre R. Mai, with copious input from the
-;;;; cmucl-help mailing-list hosted at cons.org, in November 2001 and
-;;;; has been placed into the public domain.
+;;;; It was originally written by Pierre R. Mai, with copious input
+;;;; from the cmucl-help mailing-list hosted at cons.org, in November
+;;;; 2001 and has been placed into the public domain. In the meantime
+;;;; various fixes and improvements for other implementations as well
+;;;; as maintenance have been provided by Christophe Rhodes, Alexey
+;;;; Dejneka, Nathan Froyd, Andreas Fuchs, John Desoi, Dmitriy Ivanov,
+;;;; and Kevin M. Rosenberg, and have been reintegrated into this
+;;;; consolidated version by Pierre R. Mai.
;;;;
-;;;; $Id$
+;;;; WARNING: The MD5 Message-Digest Algorithm has been compromised as
+;;;; a cryptographically secure hash for some time, with known
+;;;; theoretical and practical attacks. Therefore use of this
+;;;; implemenation is only recommended for legacy uses or uses which
+;;;; do not require a cryptographically secure hash. Use one of the
+;;;; newer SHA-2 and SHA-3 secure hash standards, or whatever is
+;;;; currently deemed cryptographically secure for all other uses.
+;;;;
+;;;; $Id: 05ed5d97f2c1822c4fcb0b041f8c3a0746a962ad $
;;;;
;;;; While the implementation should work on all conforming Common
-;;;; Lisp implementations, it has only been optimized for CMU CL,
-;;;; where it achieved comparable performance to the standard md5sum
-;;;; utility (within a factor of 1.5 or less on iA32 and UltraSparc
-;;;; hardware).
+;;;; Lisp implementations, it has originally been optimized for CMU
+;;;; CL, where it achieved comparable performance to the standard
+;;;; md5sum utility (within a factor of 1.5 or less on iA32 and
+;;;; UltraSparc hardware).
+;;;;
+;;;; Currently, this implementation has also been optimized for SBCL
+;;;; and LispWorks.
;;;;
;;;; Since the implementation makes heavy use of arithmetic on
;;;; (unsigned-byte 32) numbers, acceptable performance is likely only
;;;; on CL implementations that support unboxed arithmetic on such
-;;;; numbers in some form. For other CL implementations a 16bit
+;;;; numbers in some form. This should include most 64bit CL
+;;;; implementations. For other CL implementations a 16bit
;;;; implementation of MD5 is probably more suitable.
;;;;
-;;;; The code implements correct operation for files of unbounded size
-;;;; as is, at the cost of having to do a single generic integer
-;;;; addition for each call to update-md5-state. If you call
-;;;; update-md5-state frequently with little data, this can pose a
-;;;; performance problem. If you can live with a size restriction of
-;;;; 512 MB, then you can enable fast fixnum arithmetic by putting
-;;;; :md5-small-length onto *features* prior to compiling this file.
+;;;; The code implements correct operation for files/sequences of
+;;;; unbounded size as is, at the cost of having to do a single
+;;;; generic integer addition for each call to update-md5-state. If
+;;;; you call update-md5-state frequently with little data, this can
+;;;; pose a performance problem. If you can live with a size
+;;;; restriction of 512 MB, then you can enable fast fixnum arithmetic
+;;;; by putting :md5-small-length onto *features* prior to compiling
+;;;; this file.
+;;;;
+;;;; Testing code can be compiled by including :md5-testing on
+;;;; *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
@@ -42,18 +67,68 @@
;; High-Level functions on sequences, streams and files
#:md5sum-sequence #:md5sum-string #:md5sum-stream #:md5sum-file))
-(in-package :sb-md5)
+(in-package sb-md5)
+
+#+cmu
+(eval-when (:compile-toplevel)
+ (defparameter *old-expansion-limit* ext:*inline-expansion-limit*)
+ (setq ext:*inline-expansion-limit* (max ext:*inline-expansion-limit* 1000)))
+
+#+cmu
+(eval-when (:compile-toplevel :execute)
+ (defparameter *old-features* *features*)
+ (pushnew (c:backend-byte-order c:*target-backend*) *features*))
+
+#+sbcl
+(eval-when (:compile-toplevel :execute)
+ (defparameter *old-features* *features*)
+ (pushnew sb-c:*backend-byte-order* *features*))
+
+#+(and :lispworks (or (not :lispworks4) :lispworks4.4))
+(eval-when (:compile-toplevel :execute)
+ (defparameter *old-features* *features*)
+ (pushnew :lw-int32 *features*)
+ (defmacro lw-int32-no-overflow (value)
+ ;; Prevent overflow in 64-bit prior to LispWorks 7.0.
+ #+(and :lispworks-64bit (or :lispworks5 :lispworks6))
+ `(sys:int32>> (sys:int32<< ,value #.(sys:integer-to-int32 32))
+ #.(sys:integer-to-int32 32))
+ #-(and :lispworks-64bit (or :lispworks5 :lispworks6))
+ value))
;;; Section 2: Basic Datatypes
(deftype ub32 ()
"Corresponds to the 32bit quantity word of the MD5 Spec"
- `(unsigned-byte 32))
+ #+lw-int32 'sys:int32
+ #-lw-int32 '(unsigned-byte 32))
-(defmacro assemble-ub32 (a b c d)
- "Assemble an ub32 value from the given (unsigned-byte 8) values,
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defmacro assemble-ub32 (a b c d)
+ "Assemble an ub32 value from the given (unsigned-byte 8) values,
where a is the intended low-order byte and d the high-order byte."
- `(the ub32 (logior (ash ,d 24) (ash ,c 16) (ash ,b 8) ,a)))
+ #+lw-int32
+ `(lw-int32-no-overflow
+ (sys:int32-logior (sys:int32<< ,d 24)
+ (sys:int32-logior (sys:int32<< ,c 16)
+ (sys:int32-logior (sys:int32<< ,b 8) ,a))))
+ #-lw-int32
+ `(the ub32 (logior (ash ,d 24) (ash ,c 16) (ash ,b 8) ,a))))
+
+(deftype ub32-vector (length)
+ #+lw-int32 (declare (ignore length))
+ #+lw-int32 'sys:simple-int32-vector
+ #-lw-int32 `(simple-array (unsigned-byte 32) (,length)))
+
+(defmacro make-ub32-vector (length &rest args)
+ #+lw-int32 `(sys:make-simple-int32-vector ,length ,@args)
+ #-lw-int32 `(make-array ,length :element-type 'ub32 ,@args))
+
+(defmacro ub32-aref (vector index)
+ #+lw-int32
+ `(sys:int32-aref ,vector ,index)
+ #-lw-int32
+ `(aref ,vector ,index))
;;; Section 3.4: Auxilliary functions
@@ -62,41 +137,93 @@ where a is the intended low-order byte and d the high-order byte."
(defun f (x y z)
(declare (type ub32 x y z)
- (optimize (speed 3) (safety 0) (space 0) (debug 0)))
+ (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0)))
+ #+cmu
+ (kernel:32bit-logical-or (kernel:32bit-logical-and x y)
+ (kernel:32bit-logical-andc1 x z))
+ #+lw-int32
+ (sys:int32-logior (sys:int32-logand x y) (sys:int32-logandc1 x z))
+ #-(or :cmu :lw-int32)
(logior (logand x y) (logandc1 x z)))
(defun g (x y z)
(declare (type ub32 x y z)
- (optimize (speed 3) (safety 0) (space 0) (debug 0)))
+ (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0)))
+ #+cmu
+ (kernel:32bit-logical-or (kernel:32bit-logical-and x z)
+ (kernel:32bit-logical-andc2 y z))
+ #+lw-int32
+ (sys:int32-logior (sys:int32-logand x z) (sys:int32-logandc2 y z))
+ #-(or :cmu :lw-int32)
(logior (logand x z) (logandc2 y z)))
(defun h (x y z)
(declare (type ub32 x y z)
- (optimize (speed 3) (safety 0) (space 0) (debug 0)))
+ (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0)))
+ #+cmu
+ (kernel:32bit-logical-xor x (kernel:32bit-logical-xor y z))
+ #+lw-int32
+ (sys:int32-logxor x (sys:int32-logxor y z))
+ #-(or :cmu :lw-int32)
(logxor x y z))
(defun i (x y z)
(declare (type ub32 x y z)
- (optimize (speed 3) (safety 0) (space 0) (debug 0)))
+ (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0)))
+ #+cmu
+ (kernel:32bit-logical-xor y (kernel:32bit-logical-orc2 x z))
+ #+lw-int32
+ (lw-int32-no-overflow (sys:int32-logxor y (sys:int32-logorc2 x z)))
+ #-(or :cmu :lw-int32)
(ldb (byte 32 0) (logxor y (logorc2 x z))))
(declaim (inline mod32+)
(ftype (function (ub32 ub32) ub32) mod32+))
(defun mod32+ (a b)
- (declare (type ub32 a b) (optimize (speed 3) (safety 0) (space 0) (debug 0)))
+ (declare (type ub32 a b)
+ (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0)))
+ #+lw-int32
+ (lw-int32-no-overflow (sys:int32+ a b))
+ #-lw-int32
(ldb (byte 32 0) (+ a b)))
+#+cmu
+(define-compiler-macro mod32+ (a b)
+ `(ext:truly-the ub32 (+ ,a ,b)))
+
;;; Dunno why we need this, but without it MOD32+ wasn't being
;;; inlined. Oh well. -- CSR, 2003-09-14
+#+sbcl
(define-compiler-macro mod32+ (a b)
`(ldb (byte 32 0) (+ ,a ,b)))
+#+lw-int32
+(declaim (inline int32>>logical)
+ (ftype (function (sys:int32 (unsigned-byte 5)) sys:int32) int32>>logical))
+#+lw-int32
+(defun int32>>logical (a s)
+ (declare (type ub32 a) (type (unsigned-byte 5) s)
+ (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0)))
+ (if (sys:int32-minusp a)
+ (sys:int32-logandc2 (sys:int32>> a s) (sys:int32<< -1 (- 32 s)))
+ (sys:int32>> a s)))
+
(declaim (inline rol32)
(ftype (function (ub32 (unsigned-byte 5)) ub32) rol32))
(defun rol32 (a s)
(declare (type ub32 a) (type (unsigned-byte 5) s)
- (optimize (speed 3) (safety 0) (space 0) (debug 0)))
- (sb-rotate-byte:rotate-byte s (byte 32 0) a))
+ (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0)))
+ #+cmu
+ (kernel:32bit-logical-or #+little-endian (kernel:shift-towards-end a s)
+ #+big-endian (kernel:shift-towards-start a s)
+ (ash a (- s 32)))
+ #+sbcl
+ (sb-rotate-byte:rotate-byte s (byte 32 0) a)
+ #+lw-int32
+ (sys:int32-logior (lw-int32-no-overflow (sys:int32<< a s))
+ (int32>>logical a (- 32 s)))
+ #-(or :cmu :sbcl :lw-int32)
+ (logior (ldb (byte 32 0) (ash a s)) (ash a (- s 32))))
;;; Section 3.4: Table T
@@ -111,35 +238,54 @@ where a is the intended low-order byte and d the high-order byte."
;;; Section 3.4: Helper Macro for single round definitions
+#-lw-int32
(defmacro with-md5-round ((op block) &rest clauses)
(loop for (a b c d k s i) in clauses
collect
`(setq ,a (mod32+ ,b (rol32 (mod32+ (mod32+ ,a (,op ,b ,c ,d))
- (mod32+ (aref ,block ,k)
+ (mod32+ (ub32-aref ,block ,k)
,(aref *t* (1- i))))
,s)))
into result
finally
(return `(progn ,@result))))
+#+lw-int32
+(defmacro with-md5-round ((op block) &rest clauses)
+ (loop for (a b c d k s i) in clauses
+ collect
+ `(setq ,a (mod32+ ,b (rol32 (mod32+ (mod32+ ,a (,op ,b ,c ,d))
+ (mod32+ (ub32-aref ,block ,k)
+ (sys:integer-to-int32
+ ,(let ((t-val (aref *t* (1- i))))
+ (dpb (ldb (byte 32 0) t-val)
+ (byte 32 0)
+ (if (logbitp 31 t-val)
+ -1
+ 0))))))
+ ,s)))
+ into result
+ finally
+ (return `(progn ,@result))))
+
;;; Section 3.3: (Initial) MD5 Working Set
(deftype md5-regs ()
"The working state of the MD5 algorithm, which contains the 4 32-bit
registers A, B, C and D."
- `(simple-array (unsigned-byte 32) (4)))
+ `(ub32-vector 4))
(defmacro md5-regs-a (regs)
- `(aref ,regs 0))
+ `(ub32-aref ,regs 0))
(defmacro md5-regs-b (regs)
- `(aref ,regs 1))
+ `(ub32-aref ,regs 1))
(defmacro md5-regs-c (regs)
- `(aref ,regs 2))
+ `(ub32-aref ,regs 2))
(defmacro md5-regs-d (regs)
- `(aref ,regs 3))
+ `(ub32-aref ,regs 3))
(defconstant +md5-magic-a+ (assemble-ub32 #x01 #x23 #x45 #x67)
"Initial value of Register A of the MD5 working state.")
@@ -153,8 +299,8 @@ registers A, B, C and D."
(declaim (inline initial-md5-regs))
(defun initial-md5-regs ()
"Create the initial working state of an MD5 run."
- (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))
- (let ((regs (make-array 4 :element-type '(unsigned-byte 32))))
+ (declare (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0)))
+ (let ((regs (make-ub32-vector 4)))
(declare (type md5-regs regs))
(setf (md5-regs-a regs) +md5-magic-a+
(md5-regs-b regs) +md5-magic-b+
@@ -164,16 +310,20 @@ registers A, B, C and D."
;;; Section 3.4: Operation on 16-Word Blocks
+(deftype md5-block ()
+ "The basic 16x32-bit word blocks that MD5 operates on."
+ `(ub32-vector 16))
+
(defun update-md5-block (regs block)
"This is the core part of the MD5 algorithm. It takes a complete 16
word block of input, and updates the working state in A, B, C, and D
accordingly."
(declare (type md5-regs regs)
- (type (simple-array ub32 (16)) block)
- (optimize (speed 3) (safety 0) (space 0) (debug 0)))
- (let ((a (md5-regs-a regs)) (b (md5-regs-b regs))
- (c (md5-regs-c regs)) (d (md5-regs-d regs)))
- (declare (type ub32 a b c d))
+ (type md5-block block)
+ (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0)))
+ (let ((A (md5-regs-a regs)) (B (md5-regs-b regs))
+ (C (md5-regs-c regs)) (D (md5-regs-d regs)))
+ (declare (type ub32 A B C D))
;; Round 1
(with-md5-round (f block)
(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)
@@ -199,51 +349,62 @@ accordingly."
(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)
(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))
;; Update and return
- (setf (md5-regs-a regs) (mod32+ (md5-regs-a regs) a)
- (md5-regs-b regs) (mod32+ (md5-regs-b regs) b)
- (md5-regs-c regs) (mod32+ (md5-regs-c regs) c)
- (md5-regs-d regs) (mod32+ (md5-regs-d regs) d))
+ (setf (md5-regs-a regs) (mod32+ (md5-regs-a regs) A)
+ (md5-regs-b regs) (mod32+ (md5-regs-b regs) B)
+ (md5-regs-c regs) (mod32+ (md5-regs-c regs) C)
+ (md5-regs-d regs) (mod32+ (md5-regs-d regs) D))
regs))
;;; Section 3.4: Converting 8bit-vectors into 16-Word Blocks
(declaim (inline fill-block fill-block-ub8 fill-block-char))
-
(defun fill-block-ub8 (block buffer offset)
"Convert a complete 64 (unsigned-byte 8) input vector segment
-starting from offset into the given 16 word MD5 block."
+starting from `offset' into the given 16 word MD5 block."
(declare (type (integer 0 #.(- most-positive-fixnum 64)) offset)
- (type (simple-array ub32 (16)) block)
+ (type md5-block block)
(type (simple-array (unsigned-byte 8) (*)) buffer)
- (optimize (speed 3) (safety 0) (space 0) (debug 0)))
- #+little-endian
+ (optimize (speed 3) (safety 0) (space 0) (debug 0)
+ #+lw-int32 (float 0) #+lw-int32 (hcl:fixnum-safety 0)))
+ #+(and :cmu :little-endian)
+ (kernel:bit-bash-copy
+ buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits))
+ block (* vm:vector-data-offset vm:word-bits)
+ (* 64 vm:byte-bits))
+ #+(and :sbcl :little-endian)
(sb-kernel:ub8-bash-copy buffer offset block 0 64)
- #+big-endian
+ #-(or (and :sbcl :little-endian) (and :cmu :little-endian))
(loop for i of-type (integer 0 16) from 0
for j of-type (integer 0 #.most-positive-fixnum)
from offset to (+ offset 63) by 4
do
- (setf (aref block i)
+ (setf (ub32-aref block i)
(assemble-ub32 (aref buffer j)
(aref buffer (+ j 1))
(aref buffer (+ j 2))
(aref buffer (+ j 3))))))
(defun fill-block-char (block buffer offset)
- "Convert a complete 64 character input string segment starting from
-offset into the given 16 word MD5 block."
+ "DEPRECATED: Convert a complete 64 character input string segment
+starting from `offset' into the given 16 word MD5 block."
(declare (type (integer 0 #.(- most-positive-fixnum 64)) offset)
- (type (simple-array ub32 (16)) block)
+ (type md5-block block)
(type simple-string buffer)
- (optimize (speed 3) (safety 0) (space 0) (debug 0)))
- #+little-endian
+ (optimize (speed 3) (safety 0) (space 0) (debug 0)
+ #+lw-int32 (float 0) #+lw-int32 (hcl:fixnum-safety 0)))
+ #+(and :cmu :little-endian)
+ (kernel:bit-bash-copy
+ buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits))
+ block (* vm:vector-data-offset vm:word-bits)
+ (* 64 vm:byte-bits))
+ #+(and :sbcl :little-endian)
(sb-kernel:ub8-bash-copy buffer offset block 0 64)
- #+big-endian
+ #-(or (and :sbcl :little-endian) (and :cmu :little-endian))
(loop for i of-type (integer 0 16) from 0
for j of-type (integer 0 #.most-positive-fixnum)
from offset to (+ offset 63) by 4
do
- (setf (aref block i)
+ (setf (ub32-aref block i)
(assemble-ub32 (char-code (schar buffer j))
(char-code (schar buffer (+ j 1)))
(char-code (schar buffer (+ j 2)))
@@ -253,11 +414,13 @@ offset into the given 16 word MD5 block."
"Convert a complete 64 byte input vector segment into the given 16
word MD5 block. This currently works on (unsigned-byte 8) and
character simple-arrays, via the functions `fill-block-ub8' and
-`fill-block-char' respectively."
+`fill-block-char' respectively. Note that it will not work correctly
+on character simple-arrays if `char-code-limit' is greater than 256."
(declare (type (integer 0 #.(- most-positive-fixnum 64)) offset)
- (type (simple-array ub32 (16)) block)
+ (type md5-block block)
(type (simple-array * (*)) buffer)
- (optimize (speed 3) (safety 0) (space 0) (debug 0)))
+ (optimize (speed 3) (safety 0) (space 0) (debug 0)
+ #+lw-int32 (float 0) #+lw-int32 (hcl:fixnum-safety 0)))
(etypecase buffer
((simple-array (unsigned-byte 8) (*))
(fill-block-ub8 block buffer offset))
@@ -269,17 +432,17 @@ character simple-arrays, via the functions `fill-block-ub8' and
(declaim (inline md5regs-digest))
(defun md5regs-digest (regs)
"Create the final 16 byte message-digest from the MD5 working state
-in regs. Returns a (simple-array (unsigned-byte 8) (16))."
- (declare (optimize (speed 3) (safety 0) (space 0) (debug 0))
+in `regs'. Returns a (simple-array (unsigned-byte 8) (16))."
+ (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
+ #+lw-int32 (float 0) #+lw-int32 (hcl:fixnum-safety 0))
(type md5-regs regs))
(let ((result (make-array 16 :element-type '(unsigned-byte 8))))
(declare (type (simple-array (unsigned-byte 8) (16)) result))
(macrolet ((frob (reg offset)
- ;; Avoid efficiency notes.
- (declare (optimize (speed 1) (safety 1) (space 1) (debug 1)))
(let ((var (gensym)))
- `(let ((,var ,reg))
- (declare (type ub32 ,var))
+ `(let ((,var #+lw-int32 (ldb (byte 32 0) (sys:int32-to-integer ,reg))
+ #-lw-int32 ,reg))
+ (declare (type (unsigned-byte 32) ,var))
(setf
(aref result ,offset) (ldb (byte 8 0) ,var)
(aref result ,(+ offset 1)) (ldb (byte 8 8) ,var)
@@ -293,6 +456,9 @@ in regs. Returns a (simple-array (unsigned-byte 8) (16))."
;;; Mid-Level Drivers
+(locally
+ (declare (optimize (speed 3) (safety 1) (space 0) (debug 1)
+ #+lw-int32 (float 0)))
(defstruct (md5-state
(:constructor make-md5-state ())
(:copier))
@@ -300,89 +466,125 @@ in regs. Returns a (simple-array (unsigned-byte 8) (16))."
(amount 0 :type
#-md5-small-length (integer 0 *)
#+md5-small-length (unsigned-byte 29))
- (block (make-array 16 :element-type '(unsigned-byte 32)) :read-only t
- :type (simple-array (unsigned-byte 32) (16)))
+ (block (make-ub32-vector 16) :read-only t :type md5-block)
(buffer (make-array 64 :element-type '(unsigned-byte 8)) :read-only t
:type (simple-array (unsigned-byte 8) (64)))
(buffer-index 0 :type (integer 0 63))
(finalized-p nil))
+)
(declaim (inline copy-to-buffer))
(defun copy-to-buffer (from from-offset count buffer buffer-offset)
- "Copy a partial segment from input vector from starting at
-from-offset and copying count elements into the 64 byte buffer
-starting at buffer-offset."
- (declare (optimize (speed 3) (safety 0) (space 0) (debug 0))
+ "Copy a partial segment from input vector `from' starting at
+`from-offset' and copying `count' elements into the 64 byte buffer
+starting at `buffer-offset'."
+ (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
+ #+lw-int32 (float 0) #+lw-int32 (hcl:fixnum-safety 0))
(type (unsigned-byte 29) from-offset)
(type (integer 0 63) count buffer-offset)
(type (simple-array * (*)) from)
(type (simple-array (unsigned-byte 8) (64)) buffer))
- (sb-kernel:ub8-bash-copy from from-offset buffer buffer-offset count))
+ #+cmu
+ (kernel:bit-bash-copy
+ from (+ (* vm:vector-data-offset vm:word-bits) (* from-offset vm:byte-bits))
+ buffer (+ (* vm:vector-data-offset vm:word-bits)
+ (* buffer-offset vm:byte-bits))
+ (* count vm:byte-bits))
+ #+sbcl
+ (sb-kernel:ub8-bash-copy from from-offset buffer buffer-offset count)
+ #-(or :cmu :sbcl)
+ (etypecase from
+ (simple-string
+ (loop for buffer-index of-type (integer 0 64) from buffer-offset
+ for from-index of-type fixnum from from-offset
+ below (+ from-offset count)
+ do
+ (setf (aref buffer buffer-index)
+ (char-code (schar (the simple-string from) from-index)))))
+ ((simple-array (unsigned-byte 8) (*))
+ (loop for buffer-index of-type (integer 0 64) from buffer-offset
+ for from-index of-type fixnum from from-offset
+ below (+ from-offset count)
+ do
+ (setf (aref buffer buffer-index)
+ (aref (the (simple-array (unsigned-byte 8) (*)) from)
+ from-index))))))
(defun update-md5-state (state sequence &key (start 0) (end (length sequence)))
- "Update the given md5-state from sequence, which is either a
+ "Update the given md5-state from `sequence', which is either a
simple-string or a simple-array with element-type (unsigned-byte 8),
-bounded by start and end, which must be numeric bounding-indices."
+bounded by `start' and `end', which must be numeric bounding-indices.
+Note that usage on simple-strings is DEPRECATED, since this will not
+work correctly if `char-code-limit' is more than 256. String input
+should be converted to (unsigned-byte 8) simple-arrays with
+external-format conversion routines beforehand."
(declare (type md5-state state)
(type (simple-array * (*)) sequence)
(type fixnum start end)
- (optimize (speed 3) (safety 0) (space 0) (debug 0)))
- (let ((regs (md5-state-regs state))
- (block (md5-state-block state))
- (buffer (md5-state-buffer state))
- (buffer-index (md5-state-buffer-index state))
- (length (- end start)))
- (declare (type md5-regs regs) (type fixnum length)
- (type (integer 0 63) buffer-index)
- (type (simple-array (unsigned-byte 32) (16)) block)
- (type (simple-array (unsigned-byte 8) (64)) buffer))
- ;; Handle old rest
- (unless (zerop buffer-index)
- (let ((amount (min (- 64 buffer-index) length)))
- (declare (type (integer 0 63) amount))
- (copy-to-buffer sequence start amount buffer buffer-index)
- (setq start (the fixnum (+ start amount)))
- (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) (*))
- (locally
- (declare (type (simple-array (unsigned-byte 8) (*)) sequence))
- (loop for offset of-type (unsigned-byte 29) from start below end by 64
- until (< (- end offset) 64)
- do
- (fill-block-ub8 block sequence offset)
- (update-md5-block regs block)
- finally
- (let ((amount (- end offset)))
- (unless (zerop amount)
- (copy-to-buffer sequence offset amount buffer 0))
- (setf (md5-state-buffer-index state) amount)))))
- (simple-string
- (locally
- (declare (type simple-string sequence))
- (loop for offset of-type (unsigned-byte 29) from start below end by 64
- until (< (- end offset) 64)
- do
- (fill-block-char block sequence offset)
- (update-md5-block regs block)
- finally
- (let ((amount (- end offset)))
- (unless (zerop amount)
- (copy-to-buffer sequence offset amount buffer 0))
- (setf (md5-state-buffer-index state) amount))))))
- (setf (md5-state-amount state)
- #-md5-small-length (+ (md5-state-amount state) length)
- #+md5-small-length (the (unsigned-byte 29)
- (+ (md5-state-amount state) length)))
- state))
+ (optimize (speed 3) (safety 1) (space 0) (debug 1)
+ #+lw-int32 (float 0) #+lw-int32 (hcl:fixnum-safety 0)))
+ (locally
+ (declare (optimize (safety 0) (debug 0)))
+ (let ((regs (md5-state-regs state))
+ (block (md5-state-block state))
+ (buffer (md5-state-buffer state))
+ (buffer-index (md5-state-buffer-index state))
+ (length (- end start)))
+ (declare (type md5-regs regs) (type fixnum length)
+ (type (integer 0 63) buffer-index)
+ (type md5-block block)
+ (type (simple-array (unsigned-byte 8) (64)) buffer))
+ ;; Handle old rest
+ (unless (zerop buffer-index)
+ (let ((amount (min (- 64 buffer-index) length)))
+ (declare (type (integer 0 63) amount))
+ (copy-to-buffer sequence start amount buffer buffer-index)
+ (setq start (the fixnum (+ start amount)))
+ (let ((new-index (+ buffer-index amount)))
+ (when (= new-index 64)
+ (fill-block-ub8 block buffer 0)
+ (update-md5-block regs block)
+ (setq new-index 0))
+ (when (>= start end)
+ (setf (md5-state-buffer-index state) new-index
+ (md5-state-amount state)
+ #-md5-small-length (+ (md5-state-amount state) length)
+ #+md5-small-length (the (unsigned-byte 29)
+ (+ (md5-state-amount state) length)))
+ (return-from update-md5-state state)))))
+ ;; Handle main-part and new-rest
+ (etypecase sequence
+ ((simple-array (unsigned-byte 8) (*))
+ (locally
+ (declare (type (simple-array (unsigned-byte 8) (*)) sequence))
+ (loop for offset of-type (unsigned-byte 29) from start below end by 64
+ until (< (- end offset) 64)
+ do
+ (fill-block-ub8 block sequence offset)
+ (update-md5-block regs block)
+ finally
+ (let ((amount (- end offset)))
+ (unless (zerop amount)
+ (copy-to-buffer sequence offset amount buffer 0))
+ (setf (md5-state-buffer-index state) amount)))))
+ (simple-string
+ (locally
+ (declare (type simple-string sequence))
+ (loop for offset of-type (unsigned-byte 29) from start below end by 64
+ until (< (- end offset) 64)
+ do
+ (fill-block-char block sequence offset)
+ (update-md5-block regs block)
+ finally
+ (let ((amount (- end offset)))
+ (unless (zerop amount)
+ (copy-to-buffer sequence offset amount buffer 0))
+ (setf (md5-state-buffer-index state) amount))))))
+ (setf (md5-state-amount state)
+ #-md5-small-length (+ (md5-state-amount state) length)
+ #+md5-small-length (the (unsigned-byte 29)
+ (+ (md5-state-amount state) length)))
+ state)))
(defun finalize-md5-state (state)
"If the given md5-state has not already been finalized, finalize it,
@@ -393,53 +595,65 @@ The resulting MD5 message-digest is returned as an array of sixteen
(unsigned-byte 8) values. Calling `update-md5-state' after a call to
`finalize-md5-state' results in unspecified behaviour."
(declare (type md5-state state)
- (optimize (speed 3) (safety 0) (space 0) (debug 0)))
- (or (md5-state-finalized-p state)
- (let ((regs (md5-state-regs state))
- (block (md5-state-block state))
- (buffer (md5-state-buffer state))
- (buffer-index (md5-state-buffer-index state))
- (total-length (* 8 (md5-state-amount state))))
- (declare (type md5-regs regs)
- (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)
- ;; Flush block first if length wouldn't fit
- (when (>= buffer-index 56)
+ (optimize (speed 3) (safety 1) (space 0) (debug 1) #+lw-int32 (float 0)))
+ (locally
+ (declare (optimize (safety 0) (debug 0)))
+ (or (md5-state-finalized-p state)
+ (let ((regs (md5-state-regs state))
+ (block (md5-state-block state))
+ (buffer (md5-state-buffer state))
+ (buffer-index (md5-state-buffer-index state))
+ (total-length (* 8 (md5-state-amount state))))
+ (declare (type md5-regs regs)
+ (type (integer 0 63) buffer-index)
+ (type md5-block 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)
+ ;; 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 (ub32-aref block index) #x00000000)))
+ ;; Add 64bit message bit length
+ (setf (ub32-aref block 14) (ldb (byte 32 0) total-length))
+ #-md5-small-length
+ (setf (ub32-aref block 15) (ldb (byte 32 32) total-length))
+ ;; Flush last block
(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)))
- ;; 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)))))
+ ;; Done, remember digest for later calls
+ (setf (md5-state-finalized-p state)
+ (md5regs-digest regs))))))
;;; High-Level Drivers
(defun md5sum-sequence (sequence &key (start 0) end)
- "Calculate the MD5 message-digest of data bounded by START and END
-in SEQUENCE , which must be a vector with element-type (UNSIGNED-BYTE
-8)."
+ "Calculate the MD5 message-digest of data in `sequence', which should
+be a 1d simple-array with element type (unsigned-byte 8). On CMU CL
+and SBCL non-simple and non-1d arrays with this element-type are also
+supported. Use with strings is DEPRECATED, since this will not work
+correctly on implementations with `char-code-limit' > 256 and ignores
+character-coding issues. Use md5sum-string instead, or convert to the
+required (unsigned-byte 8) format through other means before-hand."
(declare (optimize (speed 3) (safety 3) (space 0) (debug 1))
(type (vector (unsigned-byte 8)) sequence) (type fixnum start))
(locally
- (declare (optimize (safety 1) (debug 0)))
+ (declare (optimize (safety 1) (debug 0)))
(let ((state (make-md5-state)))
(declare (type md5-state state))
- ;; respect the fill pointer
+ #+cmu
+ (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
(let ((end (or end (length sequence))))
(sb-kernel:with-array-data ((data sequence)
(real-start start)
@@ -448,35 +662,77 @@ in SEQUENCE , which must be a vector with element-type (UNSIGNED-BYTE
(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))
+ (update-md5-state state sequence :start start :end real-end))
(finalize-md5-state state))))
(defun md5sum-string (string &key (external-format :default) (start 0) end)
- "Calculate the MD5 message-digest of the binary representation
-of STRING (as octets) in EXTERNAL-FORMAT. The boundaries START
-and END refer to character positions in the string, not to octets
-in the resulting binary representation."
+ "Calculate the MD5 message-digest of the binary representation of
+`string' (as octets) in the external format specified by
+`external-format'. The boundaries `start' and `end' refer to character
+positions in the string, not to octets in the resulting binary
+representation. The permissible external format specifiers are
+determined by the underlying implementation."
(declare (optimize (speed 3) (safety 3) (space 0) (debug 1))
- (type string string) (type fixnum start))
+ (type string string) (type fixnum start)
+ (ignorable external-format))
(locally
(declare (optimize (safety 1) (debug 0)))
+ #+cmu
+ (md5sum-sequence
+ (stream:string-to-octets string
+ :external-format external-format
+ :start start :end end))
+ #+sbcl
(md5sum-sequence
(sb-ext:string-to-octets string
:external-format external-format
- :start start :end end))))
+ :start start :end end))
+ #+(and :lispworks (not :lispworks4))
+ (let ((external-format (system:merge-ef-specs external-format :utf-8)))
+ (if (equal (external-format:external-format-foreign-type external-format)
+ '(unsigned-byte 8))
+ (md5sum-sequence
+ (coerce (external-format:encode-lisp-string string external-format
+ :start start :end end)
+ '(simple-array (unsigned-byte 8) (*))))
+ (error "External Format ~S does not yield (unsigned-byte 8) vector!"
+ external-format)))
+ #+ccl
+ (md5sum-sequence
+ (ccl:encode-string-to-octets string :external-format external-format
+ :start start :end end))
+ #+allegro
+ (md5sum-sequence
+ (excl:string-to-octets string :external-format external-format
+ :null-terminate nil :start start :end end))
+ #-(or :cmu :sbcl (and :lispworks (not :lispworks4)) :ccl :allegro)
+ (if (<= char-code-limit 256)
+ (md5sum-sequence string :start start :end end)
+ (md5sum-sequence
+ (flexi-streams:string-to-octets string
+ :external-format
+ (if (eq external-format :default)
+ :UTF-8
+ external-format))))))
-(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.")
+(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."))
(deftype buffer-index () `(integer 0 ,+buffer-size+))
(defun md5sum-stream (stream)
- "Calculate an MD5 message-digest of the contents of STREAM, whose
-element-type has to be (UNSIGNED-BYTE 8)."
+ "Calculate an MD5 message-digest of the contents of `stream'. Its
+element-type has to be (unsigned-byte 8). Use on character streams is
+DEPRECATED, as this will not work correctly on implementations with
+`char-code-limit' > 256 and ignores character coding issues."
(declare (optimize (speed 3) (safety 3) (space 0) (debug 1)))
- (declare (type stream stream))
(locally
- (declare (optimize (safety 1) (debug 0)))
+ (declare (optimize (safety 1) (debug 0)))
(let ((state (make-md5-state)))
(declare (type md5-state state))
(cond
@@ -489,8 +745,7 @@ element-type has to be (UNSIGNED-BYTE 8)."
do (update-md5-state state buffer :end bytes)
until (< bytes +buffer-size+)
finally
- (return (finalize-md5-state state)))))
- #+(or)
+ (return (finalize-md5-state state)))))
((equal (stream-element-type stream) 'character)
(let ((buffer (make-string +buffer-size+)))
(declare (type (simple-string #.+buffer-size+) buffer))
@@ -498,16 +753,224 @@ element-type has to be (UNSIGNED-BYTE 8)."
do (update-md5-state state buffer :end bytes)
until (< bytes +buffer-size+)
finally
- (return (finalize-md5-state state)))))
+ (return (finalize-md5-state state)))))
(t
(error "Unsupported stream element-type ~S for stream ~S."
(stream-element-type stream) stream))))))
(defun md5sum-file (pathname)
- "Calculate the MD5 message-digest of the file designated by
-pathname."
+ "Calculate the MD5 message-digest of the file specified by `pathname'."
(declare (optimize (speed 3) (safety 3) (space 0) (debug 1)))
- (locally
- (declare (optimize (safety 1) (debug 0)))
- (with-open-file (stream pathname :element-type '(unsigned-byte 8))
- (md5sum-stream stream))))
+ (with-open-file (stream pathname :element-type '(unsigned-byte 8))
+ (md5sum-stream stream)))
+
+#+md5-testing
+(defparameter *rfc1321-testsuite*
+ '(("" . "d41d8cd98f00b204e9800998ecf8427e")
+ ("a" ."0cc175b9c0f1b6a831c399e269772661")
+ ("abc" . "900150983cd24fb0d6963f7d28e17f72")
+ ("message digest" . "f96b697d7cb7938d525a2f31aaf161d0")
+ ("abcdefghijklmnopqrstuvwxyz" . "c3fcd3d76192e4007dfb496cca67e13b")
+ ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" .
+ "d174ab98d277d9f5a5611c2c9f419d9f")
+ ("12345678901234567890123456789012345678901234567890123456789012345678901234567890" .
+ "57edf4a22be3c955ac49da2e2107b67a"))
+ "AList of test input strings and stringified message-digests
+according to the test suite in Appendix A.5 of RFC 1321")
+
+#+md5-testing
+(defparameter *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
+(defparameter *ascii-map*
+ '((#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68) (#\E . 69) (#\F . 70)
+ (#\G . 71) (#\H . 72) (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76)
+ (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80) (#\Q . 81) (#\R . 82)
+ (#\S . 83) (#\T . 84) (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88)
+ (#\Y . 89) (#\Z . 90) (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100)
+ (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104) (#\i . 105) (#\j . 106)
+ (#\k . 107) (#\l . 108) (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112)
+ (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116) (#\u . 117) (#\v . 118)
+ (#\w . 119) (#\x . 120) (#\y . 121) (#\z . 122) (#\0 . 48) (#\1 . 49)
+ (#\2 . 50) (#\3 . 51) (#\4 . 52) (#\5 . 53) (#\6 . 54) (#\7 . 55)
+ (#\8 . 56) (#\9 . 57) (#\Space . 32))
+ "AList mapping string characters to ASCII codes for safe binary testing.")
+
+#+md5-testing
+(defun test-with-testsuite (testsuite)
+ (flet ((to-vector (string)
+ (loop with result = (make-array (list (length string))
+ :element-type '(unsigned-byte 8))
+ for char across string
+ for byte = (or (cdr (assoc char *ascii-map*))
+ (error "Missing Char in *ascii-map*: ~S" char))
+ for index upfrom 0
+ do (setf (aref result index) byte)
+ finally (return result)))
+ (incremental-md5sum (input)
+ (loop with state = (make-md5-state)
+ for index from 0 below (length input)
+ do (update-md5-state state input :start index :end (1+ index))
+ finally (return (finalize-md5-state state)))))
+ (loop for count from 1
+ for (source . md5-string) in testsuite
+ for binary-source = (to-vector source)
+ for md5-digest = (md5sum-sequence binary-source)
+ for md5-digest-inc = (incremental-md5sum binary-source)
+ for md5-result-string = (format nil "~(~{~2,'0X~}~)"
+ (map 'list #'identity md5-digest))
+ for md5-result-string-inc = (format nil
+ "~(~{~2,'0X~}~)"
+ (map 'list #'identity md5-digest-inc))
+ do
+ (format
+ *trace-output*
+ "~2&Test-Case ~D:~% Input: ~S~% Required: ~A~% Returned: ~A~% ~
+ Returned incrementally: ~A~%"
+ count source md5-string md5-result-string md5-result-string-inc)
+ when (and (string= md5-string md5-result-string)
+ (string= md5-string md5-result-string-inc))
+ do (format *trace-output* " OK~%")
+ else
+ count 1 into failed
+ and do (format *trace-output* " FAILED~%")
+ finally
+ (format *trace-output*
+ "~2&~[All ~D test cases succeeded~:;~:*~D of ~D test cases failed~].~%"
+ 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*))
+
+#+cmu
+(eval-when (:compile-toplevel)
+ (setq ext:*inline-expansion-limit* *old-expansion-limit*))
+
+#+sbcl
+(eval-when (:compile-toplevel :execute)
+ (setq *features* *old-features*))
+
+#+(and :lispworks (or (not :lispworks4) :lispworks4.4))
+(eval-when (:compile-toplevel :execute)
+ (setq *features* *old-features*))
diff --git a/contrib/sb-md5/sb-md5.asd b/contrib/sb-md5/sb-md5.asd
index 6eb49be..6ad5892 100644
--- a/contrib/sb-md5/sb-md5.asd
+++ b/contrib/sb-md5/sb-md5.asd
@@ -1,13 +1,27 @@
-;;; -*- Lisp -*-
+;;;; MD5 --- RFC 1321 The MD5 Message-Digest Algorithm
(defpackage #:sb-md5-system
(:use #:cl #:asdf))
-
(in-package #:sb-md5-system)
+;;;; %File Description:
+;;;;
+;;;; This file contains the system definition form for the MD5
+;;;; Library. System definitions use the ASDF system definition
+;;;; facility.
+;;;;
+
(defsystem sb-md5
- :depends-on (sb-rotate-byte)
- :version "1.8"
+ :description "The MD5 Message-Digest Algorithm RFC 1321"
+ :author "Pierre R. Mai <pmai@pmsf.de>"
+ :maintainer "Pierre R. Mai <pmai@pmsf.de>"
+ :licence "CC0"
+ :version "2.0.4"
+ :depends-on (#+sbcl "sb-rotate-byte"
+ #-(or :cmu :sbcl
+ (and :lispworks (not :lispworks4))
+ :ccl :allegro)
+ "flexi-streams")
#+sb-building-contrib :pathname
#+sb-building-contrib #p"SYS:CONTRIB;SB-MD5;"
:components ((:file "md5")))
@@ -21,7 +35,7 @@
(defsystem sb-md5-tests
:depends-on (sb-md5 sb-rt)
- :version "1.8"
+ :version "2.0.4"
:components ((:file "md5-tests")))
(defmethod perform ((o test-op) (c (eql (find-system :sb-md5-tests))))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
------------------------------------------------------------------------------
Check out the vibrant tech community on one of the world's most
engaging tech sites, Slashdot.org! http://sdm.link/slashdot
_______________________________________________
Sbcl-commits mailing list
Sbcl-commits@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/sbcl-commits
[prev in list] [next in list] [prev in thread] [next in thread]
Configure |
About |
News |
Add a list |
Sponsored by KoreLogic