;;;  md5-old.el -- MD5 message digest algorithm

;; Copyright (C) 1998 Ray Jones

;; Author: Ray Jones, rjones@pobox.com
;; Keywords: MD5, message digest
;; Created: 1998-04-27

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, you can either send email to this
;; program's maintainer or write to: The Free Software Foundation,
;; Inc.; 675 Massachusetts Avenue; Cambridge, MA 02139, USA.

;;; Commentary:

;; this is a slower, more clear, version of md5.el.  it's based on md5-old.el

;;; Code:
(require 'cl)

(defun md5 (string)
  "return the md5 hash of a string, as a 128 bit string"
  (let* ((length (length string))
	 ;; md5 requires the message be padded to a length of 512*k +
	 ;; 64 (bits).  confusion source: we're working with bytes.
	 ;; padding is always done.
	 ;; 512 bits = 64 bytes, 64 bits = 8 bytes
	 (next-512 (+ 64 (logand (+ length 8) (lognot 63))))
	 (pad-bytes (- next-512 length 8))
	 (pad-string (make-string pad-bytes 0))
	 (len-string (make-string 8 0)))
    ;; message is constructed as:
    ;; original-message | pad | length-in-bits
    ;; pad is 10000... (bitwise)
    ;; length-in-bits is length before padding, and is 64 bits long

    ;; fill in the single bit of the pad
    (aset pad-string 0 (ash 1 7))

    ;; there's a slim chance of overflow when multiplying the length
    ;; by 8 to get the length in bits.  to avoid this, do some
    ;; slightly hairier math when writing the length into len-string.
    ;; also, it has to be LSB-first.  be still my aching brain.

    ;; LSB sucks.

    ;; only do the first 4 bytes, even though supposedly there are 8.
    ;; 32 bit emacsen think that (ash 40 -37) => 1
    ;; (supposed to be fixed in future releases)
    (dotimes (idx 4)
      (aset len-string idx (logand ?\xff
				   (ash length (- 3 (* idx 8))))))
    
    (md5-vector
     (md5-string-to-32bit-vec
      (concat string pad-string len-string)))))

(defun md5-string-to-32bit-vec (string)
  ;; emacs doesn't actually have 32 bits, in most implementations.
  ;; 32 bit numbers are represented as a pair of 16 bit numbers

  ;; 4 chars per 32 bit number, in LSB-first!
  (let* ((veclen (/ (length string) 4))
	 (vec (make-vector veclen nil))
	 (stridx 0))
    (dotimes (vecidx veclen)
      ;; MD5 integers are (hi . lo) 16 bit words
      (aset vec vecidx (cons (+ (ash (aref string (+ stridx 3)) 8)
				(aref string (+ stridx 2)))
			     (+ (ash (aref string (+ stridx 1)) 8)
				(aref string (+ stridx 0)))))
      (incf stridx 4))

    vec))

(defsubst md5-f2 (x y z)
  (logior (logand x y)
	  (logand (lognot x)
		  z)))

(defsubst md5-g2 (x y z)
  (logior (logand x z)
	  (logand y (lognot z))))

(defsubst md5-h2 (x y z)
  (logxor x y z))

(defsubst md5-i2 (x y z)
  (logxor y
	  (logior x
		  ;; this is normally a lognot, but that would set
		  ;; high bits, and there's no logand to clear them.
		  (logxor z #xffff))))

(defsubst md5-f (x y z)
  (cons (md5-f2 (car x) (car y) (car z))
	(md5-f2 (cdr x) (cdr y) (cdr z))))

(defsubst md5-g (x y z)
  (cons (md5-g2 (car x) (car y) (car z))
	(md5-g2 (cdr x) (cdr y) (cdr z))))

(defsubst md5-h (x y z)
  (cons (md5-h2 (car x) (car y) (car z))
	(md5-h2 (cdr x) (cdr y) (cdr z))))

(defsubst md5-i (x y z)
  (cons (md5-i2 (car x) (car y) (car z))
	(md5-i2 (cdr x) (cdr y) (cdr z))))

(defsubst md5<<< (val shift)
  "circular shift md5 32 bit int VAL by SHIFT bits"
  (let ((a (car val))
	(b (cdr val)))

    ;; shifts greater than 16 need to be handled by a swap, then a
    ;; smaller shift
    (when (> shift 16)
      (rotatef a b)
      (decf shift 16))

    (cons (logand #xffff (logior (ash a shift) (ash b (- shift 16))))
	  (logand #xffff (logior (ash b shift) (ash a (- shift 16)))))))

(defsubst md5+ (&rest args)
  ;; enough room to just add without carry checks
  (let* ((lo (apply #'+ (mapcar #'cdr args)))
	 (hi (+ (ash lo -16) (apply #'+ (mapcar #'car args)))))
    (cons (logand #xffff hi)
	  (logand #xffff lo))))

;; array of values for i=[1..64] => floor(2^32 * abs(sin(i)))
(defconst md5-t

  [(#xd76a . #xa478)
   (#xe8c7 . #xb756)
   (#x2420 . #x70db)
   (#xc1bd . #xceee)
   (#xf57c . #x0faf)
   (#x4787 . #xc62a)
   (#xa830 . #x4613)
   (#xfd46 . #x9501)
   (#x6980 . #x98d8)
   (#x8b44 . #xf7af)
   (#xffff . #x5bb1)
   (#x895c . #xd7be)
   (#x6b90 . #x1122)
   (#xfd98 . #x7193)
   (#xa679 . #x438e)
   (#x49b4 . #x0821)

   (#xf61e . #x2562)
   (#xc040 . #xb340)
   (#x265e . #x5a51)
   (#xe9b6 . #xc7aa)
   (#xd62f . #x105d)
   (#x0244 . #x1453)
   (#xd8a1 . #xe681)
   (#xe7d3 . #xfbc8)
   (#x21e1 . #xcde6)
   (#xc337 . #x07d6)
   (#xf4d5 . #x0d87)
   (#x455a . #x14ed)
   (#xa9e3 . #xe905)
   (#xfcef . #xa3f8)
   (#x676f . #x02d9)
   (#x8d2a . #x4c8a)

   (#xfffa . #x3942)
   (#x8771 . #xf681)
   (#x6d9d . #x6122)
   (#xfde5 . #x380c)
   (#xa4be . #xea44)
   (#x4bde . #xcfa9)
   (#xf6bb . #x4b60)
   (#xbebf . #xbc70)
   (#x289b . #x7ec6)
   (#xeaa1 . #x27fa)
   (#xd4ef . #x3085)
   (#x0488 . #x1d05)
   (#xd9d4 . #xd039)
   (#xe6db . #x99e5)
   (#x1fa2 . #x7cf8)
   (#xc4ac . #x5665)

   (#xf429 . #x2244)
   (#x432a . #xff97)
   (#xab94 . #x23a7)
   (#xfc93 . #xa039)
   (#x655b . #x59c3)
   (#x8f0c . #xcc92)
   (#xffef . #xf47d)
   (#x8584 . #x5dd1)
   (#x6fa8 . #x7e4f)
   (#xfe2c . #xe6e0)
   (#xa301 . #x4314)
   (#x4e08 . #x11a1)
   (#xf753 . #x7e82)
   (#xbd3a . #xf235)
   (#x2ad7 . #xd2bb)
   (#xeb86 . #xd391)])

(eval-and-compile
  (defun md5-rewrite (fun w x y z vec-idx shift)
    "helper function for md5-vector, below.  ugly coding practice,
having a macro-rewriter elsewhere, but the indentation was getting a
bit out of control.
NB: vec, v-offset, and t-idx below must be defined where the macro is
called!" 
    `(setq ,w (md5+ ,x
		    (md5<<< (md5+ ,w
				  ,(list fun x y z)
				  (aref vec (+ v-offset ,vec-idx))
				  (aref md5-t t-idx))
			    ,shift)))))


(defun md5-vector (vec)
  ;; initialize the chaining variables
  (let ((a (cons #x6745 #x2301))
	(b (cons #xefcd #xab89))
	(c (cons #x98ba #xdcfe))
	(d (cons #x1032 #x5476))
	(v-offset 0))

    (dotimes (count (/ (length vec) 16))
      (let ((AA a) (BB b) (CC c) (DD d)
	    (t-idx 0))
	(macrolet
	    ((f (v1 v2 v3 v4 v-idx shift)
		`(progn
		   ,(md5-rewrite 'md5-f v1 v2 v3 v4 v-idx shift)
		   (incf t-idx))))

	  (f a b c d  0  7) (f d a b c  1 12) (f c d a b  2 17) (f b c d a  3 22)
	  (f a b c d  4  7) (f d a b c  5 12) (f c d a b  6 17) (f b c d a  7 22)
	  (f a b c d  8  7) (f d a b c  9 12) (f c d a b 10 17) (f b c d a 11 22)
	  (f a b c d 12  7) (f d a b c 13 12) (f c d a b 14 17) (f b c d a 15 22))

	(macrolet
	    ((g (v1 v2 v3 v4 v-idx shift)
		`(progn
		   ,(md5-rewrite 'md5-g v1 v2 v3 v4 v-idx shift)
		   (incf t-idx))))

	  (g a b c d  1  5) (g d a b c  6  9) (g c d a b 11 14) (g b c d a  0 20)
	  (g a b c d  5  5) (g d a b c 10  9) (g c d a b 15 14) (g b c d a  4 20)
	  (g a b c d  9  5) (g d a b c 14  9) (g c d a b  3 14) (g b c d a  8 20)
	  (g a b c d 13  5) (g d a b c  2  9) (g c d a b  7 14) (g b c d a 12 20))

	(macrolet
	    ((h (v1 v2 v3 v4 v-idx shift)
		`(progn
		   ,(md5-rewrite 'md5-h v1 v2 v3 v4 v-idx shift)
		   (incf t-idx))))

	  (h a b c d  5  4) (h d a b c  8 11) (h c d a b 11 16) (h b c d a 14 23)
	  (h a b c d  1  4) (h d a b c  4 11) (h c d a b  7 16) (h b c d a 10 23)
	  (h a b c d 13  4) (h d a b c  0 11) (h c d a b  3 16) (h b c d a  6 23)
	  (h a b c d  9  4) (h d a b c 12 11) (h c d a b 15 16) (h b c d a  2 23))

	(macrolet
	    ((i (v1 v2 v3 v4 v-idx shift)
		`(progn
		   ,(md5-rewrite `md5-i v1 v2 v3 v4 v-idx shift)
		   (incf t-idx))))

	  (i a b c d  0  6) (i d a b c  7 10) (i c d a b 14 15) (i b c d a  5 21)
	  (i a b c d 12  6) (i d a b c  3 10) (i c d a b 10 15) (i b c d a  1 21)
	  (i a b c d  8  6) (i d a b c 15 10) (i c d a b  6 15) (i b c d a 13 21)
	  (i a b c d  4  6) (i d a b c 11 10) (i c d a b  2 15) (i b c d a  9 21))

	(setq a (md5+ AA a)
	      b (md5+ BB b)
	      c (md5+ CC c)
	      d (md5+ DD d)))

      (incf v-offset 16))

    ;; swap back from LSB-first.  i feel ill.
    (mapconcat #'(lambda (x) (format "%02x%02x" (logand #xff x) (ash x -8)))
	       (list (cdr a) (car a)
		     (cdr b) (car b)
		     (cdr c) (car c)
		     (cdr d) (car d))
	       "")))

(provide 'md5)