[bpt/emacs.git] / lisp / md4.el

;;; md4.el --- MD4 Message Digest Algorithm.

;; Copyright (C) 2001, 2004, 2007, 2008  Free Software Foundation, Inc.

;; Author: Taro Kawagishi <tarok@transpulse.org>
;; Keywords: MD4
;; Version: 1.00
;; Created: February 2001

;; This file is part of GNU Emacs.

;; GNU Emacs 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 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs 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 GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Code:

;;;
;;; MD4 hash calculation

(defvar md4-buffer (make-vector 4 '(0 . 0))
  "work buffer of four 32-bit integers")

(defun md4 (in n)
  "Returns the MD4 hash string of 16 bytes long for a string IN of N
bytes long.  N is required to handle strings containing character 0."
  (let (m
	(b (cons 0 (* n 8)))
	(i 0)
	(buf (make-string 128 0)) c4)
    ;; initial values
    (aset md4-buffer 0 '(26437 . 8961))		;0x67452301
    (aset md4-buffer 1 '(61389 . 43913))	;0xefcdab89
    (aset md4-buffer 2 '(39098 . 56574))	;0x98badcfe
    (aset md4-buffer 3 '(4146 . 21622))		;0x10325476

    ;; process the string in 64 bits chunks
    (while (> n 64)
      (setq m (md4-copy64 (substring in 0 64)))
      (md4-64 m)
      (setq in (substring in 64))
      (setq n (- n 64)))

    ;; process the rest of the string (length is now n <= 64)
    (setq i 0)
    (while (< i n)
      (aset buf i (aref in i))
      (setq i (1+ i)))
    (aset buf n 128)			;0x80
    (if (<= n 55)
	(progn
	  (setq c4 (md4-pack-int32 b))
	  (aset buf 56 (aref c4 0))
	  (aset buf 57 (aref c4 1))
	  (aset buf 58 (aref c4 2))
	  (aset buf 59 (aref c4 3))
	  (setq m (md4-copy64 buf))
	  (md4-64 m))
      ;; else
      (setq c4 (md4-pack-int32 b))
      (aset buf 120 (aref c4 0))
      (aset buf 121 (aref c4 1))
      (aset buf 122 (aref c4 2))
      (aset buf 123 (aref c4 3))
      (setq m (md4-copy64 buf))
      (md4-64 m)
      (setq m (md4-copy64 (substring buf 64)))
      (md4-64 m)))

    (concat (md4-pack-int32 (aref md4-buffer 0))
	    (md4-pack-int32 (aref md4-buffer 1))
	    (md4-pack-int32 (aref md4-buffer 2))
	    (md4-pack-int32 (aref md4-buffer 3))))

(defsubst md4-F (x y z) (logior (logand x y) (logand (lognot x) z)))
(defsubst md4-G (x y z) (logior (logand x y) (logand x z) (logand y z)))
(defsubst md4-H (x y z) (logxor x y z))

(defmacro md4-make-step (name func)
  `(defun ,name (a b c d xk s ac)
     (let*
         ((h1 (+ (car a) (,func (car b) (car c) (car d)) (car xk) (car ac)))
          (l1 (+ (cdr a) (,func (cdr b) (cdr c) (cdr d)) (cdr xk) (cdr ac)))
          (h2 (logand 65535 (+ h1 (lsh l1 -16))))
          (l2 (logand 65535 l1))
	  ;; cyclic shift of 32 bits integer
          (h3 (logand 65535 (if (> s 15)
                                (+ (lsh h2 (- s 32)) (lsh l2 (- s 16)))
                              (+ (lsh h2 s) (lsh l2 (- s 16))))))
          (l3 (logand 65535 (if (> s 15)
                                (+ (lsh l2 (- s 32)) (lsh h2 (- s 16)))
                              (+ (lsh l2 s) (lsh h2 (- s 16)))))))
       (cons h3 l3))))

(md4-make-step md4-round1 md4-F)
(md4-make-step md4-round2 md4-G)
(md4-make-step md4-round3 md4-H)

(defsubst md4-add (x y)
  "Return 32-bit sum of 32-bit integers X and Y."
  (let ((h (+ (car x) (car y)))
	(l (+ (cdr x) (cdr y))))
    (cons (logand 65535 (+ h (lsh l -16))) (logand 65535 l))))

(defsubst md4-and (x y)
  (cons (logand (car x) (car y)) (logand (cdr x) (cdr y))))

(defun md4-64 (m)
  "Calculate md4 of 64 bytes chunk M which is represented as 16 pairs of
32 bits integers.  The resulting md4 value is placed in md4-buffer."
  (let ((a (aref md4-buffer 0))
	(b (aref md4-buffer 1))
	(c (aref md4-buffer 2))
	(d (aref md4-buffer 3)))
    (setq a (md4-round1 a b c d (aref m  0)   3 '(0 . 0))
	  d (md4-round1 d a b c (aref m  1)   7 '(0 . 0))
	  c (md4-round1 c d a b (aref m  2)  11 '(0 . 0))
	  b (md4-round1 b c d a (aref m  3)  19 '(0 . 0))
	  a (md4-round1 a b c d (aref m  4)   3 '(0 . 0))
	  d (md4-round1 d a b c (aref m  5)   7 '(0 . 0))
	  c (md4-round1 c d a b (aref m  6)  11 '(0 . 0))
	  b (md4-round1 b c d a (aref m  7)  19 '(0 . 0))
	  a (md4-round1 a b c d (aref m  8)   3 '(0 . 0))
	  d (md4-round1 d a b c (aref m  9)   7 '(0 . 0))
	  c (md4-round1 c d a b (aref m 10)  11 '(0 . 0))
	  b (md4-round1 b c d a (aref m 11)  19 '(0 . 0))
	  a (md4-round1 a b c d (aref m 12)   3 '(0 . 0))
	  d (md4-round1 d a b c (aref m 13)   7 '(0 . 0))
	  c (md4-round1 c d a b (aref m 14)  11 '(0 . 0))
	  b (md4-round1 b c d a (aref m 15)  19 '(0 . 0))

	  a (md4-round2 a b c d (aref m  0)   3 '(23170 . 31129)) ;0x5A827999
	  d (md4-round2 d a b c (aref m  4)   5 '(23170 . 31129))
	  c (md4-round2 c d a b (aref m  8)   9 '(23170 . 31129))
	  b (md4-round2 b c d a (aref m 12)  13 '(23170 . 31129))
	  a (md4-round2 a b c d (aref m  1)   3 '(23170 . 31129))
	  d (md4-round2 d a b c (aref m  5)   5 '(23170 . 31129))
	  c (md4-round2 c d a b (aref m  9)   9 '(23170 . 31129))
	  b (md4-round2 b c d a (aref m 13)  13 '(23170 . 31129))
	  a (md4-round2 a b c d (aref m  2)   3 '(23170 . 31129))
	  d (md4-round2 d a b c (aref m  6)   5 '(23170 . 31129))
	  c (md4-round2 c d a b (aref m 10)   9 '(23170 . 31129))
	  b (md4-round2 b c d a (aref m 14)  13 '(23170 . 31129))
	  a (md4-round2 a b c d (aref m  3)   3 '(23170 . 31129))
	  d (md4-round2 d a b c (aref m  7)   5 '(23170 . 31129))
	  c (md4-round2 c d a b (aref m 11)   9 '(23170 . 31129))
	  b (md4-round2 b c d a (aref m 15)  13 '(23170 . 31129))

	  a (md4-round3 a b c d (aref m  0)   3 '(28377 . 60321)) ;0x6ED9EBA1
	  d (md4-round3 d a b c (aref m  8)   9 '(28377 . 60321))
	  c (md4-round3 c d a b (aref m  4)  11 '(28377 . 60321))
	  b (md4-round3 b c d a (aref m 12)  15 '(28377 . 60321))
	  a (md4-round3 a b c d (aref m  2)   3 '(28377 . 60321))
	  d (md4-round3 d a b c (aref m 10)   9 '(28377 . 60321))
	  c (md4-round3 c d a b (aref m  6)  11 '(28377 . 60321))
	  b (md4-round3 b c d a (aref m 14)  15 '(28377 . 60321))
	  a (md4-round3 a b c d (aref m  1)   3 '(28377 . 60321))
	  d (md4-round3 d a b c (aref m  9)   9 '(28377 . 60321))
	  c (md4-round3 c d a b (aref m  5)  11 '(28377 . 60321))
	  b (md4-round3 b c d a (aref m 13)  15 '(28377 . 60321))
	  a (md4-round3 a b c d (aref m  3)   3 '(28377 . 60321))
	  d (md4-round3 d a b c (aref m 11)   9 '(28377 . 60321))
	  c (md4-round3 c d a b (aref m  7)  11 '(28377 . 60321))
	  b (md4-round3 b c d a (aref m 15)  15 '(28377 . 60321)))

    (aset md4-buffer 0 (md4-add a (aref md4-buffer 0)))
    (aset md4-buffer 1 (md4-add b (aref md4-buffer 1)))
    (aset md4-buffer 2 (md4-add c (aref md4-buffer 2)))
    (aset md4-buffer 3 (md4-add d (aref md4-buffer 3)))
    ))

(defun md4-copy64 (seq)
  "Unpack a 64 bytes string into 16 pairs of 32 bits integers."
  (let ((int32s (make-vector 16 0)) (i 0) j)
    (while (< i 16)
      (setq j (* i 4))
      (aset int32s i (cons (+ (aref seq (+ j 2)) (lsh (aref seq (+ j 3)) 8))
			   (+ (aref seq j) (lsh (aref seq (1+ j)) 8))))
      (setq i (1+ i)))
    int32s))

;;;
;;; sub functions

(defun md4-pack-int16 (int16)
  "Pack 16 bits integer in 2 bytes string as little endian."
  (let ((str (make-string 2 0)))
    (aset str 0 (logand int16 255))
    (aset str 1 (lsh int16 -8))
    str))

(defun md4-pack-int32 (int32)
  "Pack 32 bits integer in a 4 bytes string as little endian.  A 32 bits
integer is represented as a pair of two 16 bits integers (cons high low)."
  (let ((str (make-string 4 0))
	(h (car int32)) (l (cdr int32)))
    (aset str 0 (logand l 255))
    (aset str 1 (lsh l -8))
    (aset str 2 (logand h 255))
    (aset str 3 (lsh h -8))
    str))

(defun md4-unpack-int16 (str)
  (if (eq 2 (length str))
      (+ (lsh (aref str 1) 8) (aref str 0))
    (error "%s is not 2 bytes long" str)))

(defun md4-unpack-int32 (str)
  (if (eq 4 (length str))
      (cons (+ (lsh (aref str 3) 8) (aref str 2))
	    (+ (lsh (aref str 1) 8) (aref str 0)))
    (error "%s is not 4 bytes long" str)))

(provide 'md4)

;; arch-tag: 99d706fe-089b-42ea-9507-67ae41091e6e
;;; md4.el ends here
Commit	Line	Data
9b0200f7 GM	1	;;; md4.el --- MD4 Message Digest Algorithm.
9b0200f7 GM	2
dcb8ac09	3	;; Copyright (C) 2001, 2004, 2007, 2008 Free Software Foundation, Inc.
9b0200f7 GM	4
	5	;; Author: Taro Kawagishi <tarok@transpulse.org>
	6	;; Keywords: MD4
	7	;; Version: 1.00
	8	;; Created: February 2001
	9
	10	;; This file is part of GNU Emacs.
	11
eb3fa2cf	12	;; GNU Emacs is free software: you can redistribute it and/or modify
9b0200f7	13	;; it under the terms of the GNU General Public License as published by
eb3fa2cf GM	14	;; the Free Software Foundation, either version 3 of the License, or
eb3fa2cf GM	15	;; (at your option) any later version.
9b0200f7 GM	16
	17	;; GNU Emacs is distributed in the hope that it will be useful,
	18	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	19	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	20	;; GNU General Public License for more details.
	21
	22	;; You should have received a copy of the GNU General Public License
eb3fa2cf	23	;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
9b0200f7 GM	24
	25	;;; Code:
	26
	27	;;;
	28	;;; MD4 hash calculation
	29
	30	(defvar md4-buffer (make-vector 4 '(0 . 0))
	31	"work buffer of four 32-bit integers")
	32
	33	(defun md4 (in n)
	34	"Returns the MD4 hash string of 16 bytes long for a string IN of N
	35	bytes long. N is required to handle strings containing character 0."
	36	(let (m
	37	(b (cons 0 (* n 8)))
	38	(i 0)
	39	(buf (make-string 128 0)) c4)
	40	;; initial values
	41	(aset md4-buffer 0 '(26437 . 8961)) ;0x67452301
	42	(aset md4-buffer 1 '(61389 . 43913)) ;0xefcdab89
	43	(aset md4-buffer 2 '(39098 . 56574)) ;0x98badcfe
	44	(aset md4-buffer 3 '(4146 . 21622)) ;0x10325476
	45
	46	;; process the string in 64 bits chunks
	47	(while (> n 64)
	48	(setq m (md4-copy64 (substring in 0 64)))
	49	(md4-64 m)
	50	(setq in (substring in 64))
	51	(setq n (- n 64)))
	52
	53	;; process the rest of the string (length is now n <= 64)
	54	(setq i 0)
	55	(while (< i n)
	56	(aset buf i (aref in i))
	57	(setq i (1+ i)))
	58	(aset buf n 128) ;0x80
	59	(if (<= n 55)
	60	(progn
	61	(setq c4 (md4-pack-int32 b))
	62	(aset buf 56 (aref c4 0))
	63	(aset buf 57 (aref c4 1))
	64	(aset buf 58 (aref c4 2))
	65	(aset buf 59 (aref c4 3))
	66	(setq m (md4-copy64 buf))
	67	(md4-64 m))
	68	;; else
	69	(setq c4 (md4-pack-int32 b))
	70	(aset buf 120 (aref c4 0))
	71	(aset buf 121 (aref c4 1))
	72	(aset buf 122 (aref c4 2))
	73	(aset buf 123 (aref c4 3))
	74	(setq m (md4-copy64 buf))
	75	(md4-64 m)
	76	(setq m (md4-copy64 (substring buf 64)))
	77	(md4-64 m)))
	78
	79	(concat (md4-pack-int32 (aref md4-buffer 0))
	80	(md4-pack-int32 (aref md4-buffer 1))
	81	(md4-pack-int32 (aref md4-buffer 2))
	82	(md4-pack-int32 (aref md4-buffer 3))))
	83
	84	(defsubst md4-F (x y z) (logior (logand x y) (logand (lognot x) z)))
	85	(defsubst md4-G (x y z) (logior (logand x y) (logand x z) (logand y z)))
	86	(defsubst md4-H (x y z) (logxor x y z))
	87
88	(defmacro md4-make-step (name func)
89	`(defun ,name (a b c d xk s ac)
90	(let*
91	((h1 (+ (car a) (,func (car b) (car c) (car d)) (car xk) (car ac)))
92	(l1 (+ (cdr a) (,func (cdr b) (cdr c) (cdr d)) (cdr xk) (cdr ac)))
93	(h2 (logand 65535 (+ h1 (lsh l1 -16))))
94	(l2 (logand 65535 l1))
95	;; cyclic shift of 32 bits integer
96	(h3 (logand 65535 (if (> s 15)
97	(+ (lsh h2 (- s 32)) (lsh l2 (- s 16)))
98	(+ (lsh h2 s) (lsh l2 (- s 16))))))
99	(l3 (logand 65535 (if (> s 15)
100	(+ (lsh l2 (- s 32)) (lsh h2 (- s 16)))
101	(+ (lsh l2 s) (lsh h2 (- s 16)))))))
102	(cons h3 l3))))
103
104	(md4-make-step md4-round1 md4-F)
105	(md4-make-step md4-round2 md4-G)
106	(md4-make-step md4-round3 md4-H)
107
108	(defsubst md4-add (x y)
109	"Return 32-bit sum of 32-bit integers X and Y."
110	(let ((h (+ (car x) (car y)))
111	(l (+ (cdr x) (cdr y))))
112	(cons (logand 65535 (+ h (lsh l -16))) (logand 65535 l))))
113
114	(defsubst md4-and (x y)
115	(cons (logand (car x) (car y)) (logand (cdr x) (cdr y))))
116
117	(defun md4-64 (m)
118	"Calculate md4 of 64 bytes chunk M which is represented as 16 pairs of
119	32 bits integers. The resulting md4 value is placed in md4-buffer."
120	(let ((a (aref md4-buffer 0))
121	(b (aref md4-buffer 1))
122	(c (aref md4-buffer 2))
123	(d (aref md4-buffer 3)))
124	(setq a (md4-round1 a b c d (aref m 0) 3 '(0 . 0))
125	d (md4-round1 d a b c (aref m 1) 7 '(0 . 0))
126	c (md4-round1 c d a b (aref m 2) 11 '(0 . 0))
127	b (md4-round1 b c d a (aref m 3) 19 '(0 . 0))
128	a (md4-round1 a b c d (aref m 4) 3 '(0 . 0))
129	d (md4-round1 d a b c (aref m 5) 7 '(0 . 0))
130	c (md4-round1 c d a b (aref m 6) 11 '(0 . 0))
131	b (md4-round1 b c d a (aref m 7) 19 '(0 . 0))
132	a (md4-round1 a b c d (aref m 8) 3 '(0 . 0))
133	d (md4-round1 d a b c (aref m 9) 7 '(0 . 0))
134	c (md4-round1 c d a b (aref m 10) 11 '(0 . 0))
135	b (md4-round1 b c d a (aref m 11) 19 '(0 . 0))
136	a (md4-round1 a b c d (aref m 12) 3 '(0 . 0))
137	d (md4-round1 d a b c (aref m 13) 7 '(0 . 0))
138	c (md4-round1 c d a b (aref m 14) 11 '(0 . 0))
139	b (md4-round1 b c d a (aref m 15) 19 '(0 . 0))
140
141	a (md4-round2 a b c d (aref m 0) 3 '(23170 . 31129)) ;0x5A827999
142	d (md4-round2 d a b c (aref m 4) 5 '(23170 . 31129))
143	c (md4-round2 c d a b (aref m 8) 9 '(23170 . 31129))
144	b (md4-round2 b c d a (aref m 12) 13 '(23170 . 31129))
145	a (md4-round2 a b c d (aref m 1) 3 '(23170 . 31129))
146	d (md4-round2 d a b c (aref m 5) 5 '(23170 . 31129))
147	c (md4-round2 c d a b (aref m 9) 9 '(23170 . 31129))
148	b (md4-round2 b c d a (aref m 13) 13 '(23170 . 31129))
149	a (md4-round2 a b c d (aref m 2) 3 '(23170 . 31129))
150	d (md4-round2 d a b c (aref m 6) 5 '(23170 . 31129))
151	c (md4-round2 c d a b (aref m 10) 9 '(23170 . 31129))
152	b (md4-round2 b c d a (aref m 14) 13 '(23170 . 31129))
153	a (md4-round2 a b c d (aref m 3) 3 '(23170 . 31129))
154	d (md4-round2 d a b c (aref m 7) 5 '(23170 . 31129))
155	c (md4-round2 c d a b (aref m 11) 9 '(23170 . 31129))
156	b (md4-round2 b c d a (aref m 15) 13 '(23170 . 31129))
157
158	a (md4-round3 a b c d (aref m 0) 3 '(28377 . 60321)) ;0x6ED9EBA1
159	d (md4-round3 d a b c (aref m 8) 9 '(28377 . 60321))
160	c (md4-round3 c d a b (aref m 4) 11 '(28377 . 60321))
161	b (md4-round3 b c d a (aref m 12) 15 '(28377 . 60321))
162	a (md4-round3 a b c d (aref m 2) 3 '(28377 . 60321))
163	d (md4-round3 d a b c (aref m 10) 9 '(28377 . 60321))
164	c (md4-round3 c d a b (aref m 6) 11 '(28377 . 60321))
165	b (md4-round3 b c d a (aref m 14) 15 '(28377 . 60321))
166	a (md4-round3 a b c d (aref m 1) 3 '(28377 . 60321))
167	d (md4-round3 d a b c (aref m 9) 9 '(28377 . 60321))
168	c (md4-round3 c d a b (aref m 5) 11 '(28377 . 60321))
169	b (md4-round3 b c d a (aref m 13) 15 '(28377 . 60321))
170	a (md4-round3 a b c d (aref m 3) 3 '(28377 . 60321))
171	d (md4-round3 d a b c (aref m 11) 9 '(28377 . 60321))
172	c (md4-round3 c d a b (aref m 7) 11 '(28377 . 60321))
173	b (md4-round3 b c d a (aref m 15) 15 '(28377 . 60321)))
174
175	(aset md4-buffer 0 (md4-add a (aref md4-buffer 0)))
176	(aset md4-buffer 1 (md4-add b (aref md4-buffer 1)))
177	(aset md4-buffer 2 (md4-add c (aref md4-buffer 2)))
178	(aset md4-buffer 3 (md4-add d (aref md4-buffer 3)))
179	))
180
181	(defun md4-copy64 (seq)
182	"Unpack a 64 bytes string into 16 pairs of 32 bits integers."
183	(let ((int32s (make-vector 16 0)) (i 0) j)
184	(while (< i 16)
185	(setq j (* i 4))
186	(aset int32s i (cons (+ (aref seq (+ j 2)) (lsh (aref seq (+ j 3)) 8))
187	(+ (aref seq j) (lsh (aref seq (1+ j)) 8))))
188	(setq i (1+ i)))
189	int32s))
190
191	;;;
192	;;; sub functions
193
194	(defun md4-pack-int16 (int16)
195	"Pack 16 bits integer in 2 bytes string as little endian."
196	(let ((str (make-string 2 0)))
197	(aset str 0 (logand int16 255))
198	(aset str 1 (lsh int16 -8))
199	str))
200
201	(defun md4-pack-int32 (int32)
202	"Pack 32 bits integer in a 4 bytes string as little endian. A 32 bits
203	integer is represented as a pair of two 16 bits integers (cons high low)."
204	(let ((str (make-string 4 0))
205	(h (car int32)) (l (cdr int32)))
206	(aset str 0 (logand l 255))
207	(aset str 1 (lsh l -8))
208	(aset str 2 (logand h 255))
209	(aset str 3 (lsh h -8))
210	str))
211
212	(defun md4-unpack-int16 (str)
213	(if (eq 2 (length str))
214	(+ (lsh (aref str 1) 8) (aref str 0))
215	(error "%s is not 2 bytes long" str)))
216
217	(defun md4-unpack-int32 (str)
218	(if (eq 4 (length str))
219	(cons (+ (lsh (aref str 3) 8) (aref str 2))
220	(+ (lsh (aref str 1) 8) (aref str 0)))
221	(error "%s is not 4 bytes long" str)))
222
223	(provide 'md4)
224
cbee283d	225	;; arch-tag: 99d706fe-089b-42ea-9507-67ae41091e6e
9b0200f7	226	;;; md4.el ends here