1 files changed, 138 insertions, 0 deletions
diff --git a/elisp/erbot/contrib/geek.el b/elisp/erbot/contrib/geek.el
new file mode 100644
index 0000000..6563884
--- /dev/null
+++ b/elisp/erbot/contrib/geek.el
@@ -0,0 +1,138 @@
+;;; geek.el --- annoy lusers who think the geek code is wAY ko0l RADIKuL D00D!1
+
+;; Copyright (C) 1995 American Telephone & Telegraph, Inc.
+
+;; Author: Noah Friedman <friedman@prep.ai.mit.edu>
+;; Maintainer: friedman@prep.ai.mit.edu
+;; Created: 1995-01-07
+
+;; $Id: geek.el,v 1.1 2004/12/16 01:44:34 mwolson Exp $
+
+;; This software is is guaranteed to do nothing useful, except when it
+;; does.  You may sell it, burn it, use it, modify it, or give it away, at
+;; your leisure.  You may even require that other people use it.  You may
+;; also require that people not use it, as you see fit.  Government
+;; agencies are encouraged to integrate this software into weapons control
+;; systems and other instruments of destruction.
+
+;;; Commentary:
+;;; Code:
+
+(defvar geek-header "X-Geek-Code")
+
+(defvar geek-suffix-single-chars ["?" "@" "$" "!" "*"])
+(defvar geek-suffix-long-chars [?+ ?- ?+ ?- ?+ ?- ?+ ?- ?+ ?- ?+ ?- ?'])
+(defvar geek-infix-chars [">" ":"])
+
+(defvar geek-letters
+  ["A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M" "N" "O" "P" "Q" "R"
+   "S" "T" "U" "V" "W" "X" "Y" "Z"
+   "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m" "n" "o" "p" "q" "r"
+   "s" "t" "u" "v" "w" "x" "y" "z"
+   "0" "1" "2" "3" "4" "5" "6" "7" "8" "9"])
+
+(if (string-lessp emacs-version "19")
+    (defun geek-random (&optional n)
+      (if (numberp n)
+          (abs (% (random) n))
+        (random n)))
+  (defalias 'geek-random 'random))
+
+(defun geek-item (v)
+  (aref v (geek-random (length v))))
+
+(defun geek-code ()
+  (let ((ncodes (+ 10 (geek-random 40)))
+        (codes "")
+        (nflavors (+ 4 (geek-random 8)))
+        (flavors "")
+        letter
+        len len1
+        char char1
+        tem
+        i
+        (vmajor (int-to-string (1+ (geek-random 8))))
+        (vminor (int-to-string (geek-random 100))))
+    (setq i nflavors)
+    (while (not (zerop i))
+      (setq flavors (concat flavors "/"))
+      (setq len (1+ (geek-random 2)))
+      (while (not (zerop len))
+        (setq tem (geek-item geek-letters))
+        (setq flavors (concat flavors tem))
+        (setq len (1- len)))
+      (setq i (1- i)))
+    (aset flavors 0 ?G)
+
+    (setq i ncodes)
+    (while (not (zerop i))
+      (setq letter (geek-item geek-letters))
+      (and (zerop (geek-random 10))
+           (setq letter (concat letter (geek-item geek-letters))))
+
+      (setq len (geek-random 5))
+      (setq char (geek-item geek-suffix-long-chars))
+      (setq letter (concat letter (make-string len char)))
+
+      (cond
+       ((zerop len))
+       ((= char ?'))
+       ((zerop (geek-random 5))
+        (setq char1 (geek-item geek-infix-chars))
+        (setq letter (concat letter char1))
+
+        (setq len1 (1+ (geek-random 4)))
+        (setq char1 char)
+        (while (= char char1)
+          (setq char1 (geek-item geek-suffix-long-chars)))
+        (setq letter (concat letter (make-string len1 char1)))))
+
+       (cond
+        ((zerop len)
+         (and (zerop (geek-random 3))
+              (setq letter (concat letter
+                                   (geek-item geek-suffix-single-chars)))))
+        ((zerop (geek-random 5))
+         (setq len1 (1+ (geek-random 2)))
+         (setq letter (concat letter "(" (make-string len1 ?*) ")"))))
+
+       (setq codes (concat codes " " letter))
+      (setq i (1- i)))
+    (setq codes (concat "(V" vmajor "." vminor ") "
+                        flavors codes))
+    codes))
+
+(defun geek-replace-header (s)
+  (save-excursion
+    (cond
+     ((mail-position-on-field geek-header 'soft)
+      (let* ((data (match-data))
+             (end (point))
+             (beg (progn
+                    (re-search-backward (concat geek-header ": "))
+                    (match-end 0)))
+             (orig (buffer-substring beg end))
+             ;; avoid creating any permanent undo boundaries
+             (buffer-undo-list nil))
+        (store-match-data (match-data))
+        (delete-region beg end)
+        (goto-char beg)
+        (insert s)
+        orig)))))
+
+(defun geek-subvert-header ()
+  (let ((s (geek-replace-header (geek-code))))
+    (add-hook 'mail-send-actions (list 'geek-restore-header s) 'append)))
+
+(defun geek-restore-header (s)
+  (and s (geek-replace-header s)))
+
+;; mib is an extra special twit.
+(cond 
+ ((and (string= (user-login-name) "mib")
+       (fboundp 'add-hook))
+  (add-hook 'mail-send-hook 'geek-subvert-header 'append)))
+
+(provide 'geek)
+
+;;; geek.el ends here.