Move here from gnus/.

1 files changed, 228 insertions, 0 deletions

diff --git a/lisp/md4.el b/lisp/md4.el
new file mode 100644
index 00000000000..7ccb22a20fe
--- /dev/null
+++ b/lisp/md4.el
@@ -0,0 +1,228 @@
+;;; md4.el --- MD4 Message Digest Algorithm.
+
+;; Copyright (C) 2001, 2004, 2007  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, 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; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; 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