[Cl-irc-cvs] CVS update: cl-irc/example/cliki.lisp

[Lisppaste and co.]

Update of /project/cl-irc/cvsroot/cl-irc/example
In directory common-lisp.net:/home/lisppaste/cl-irc/example

Modified Files:
	cliki.lisp 
Log Message:
For bmastenbrook: protect acronym generation from abuse

Date: Sat Oct 15 21:16:52 2005
Author: lisppaste

Index: cl-irc/example/cliki.lisp
diff -u cl-irc/example/cliki.lisp:1.37 cl-irc/example/cliki.lisp:1.38
--- cl-irc/example/cliki.lisp:1.37	Thu Oct 13 21:52:33 2005
+++ cl-irc/example/cliki.lisp	Sat Oct 15 21:16:52 2005
@@ -1,4 +1,4 @@
-;;;; $Id: cliki.lisp,v 1.37 2005/10/13 19:52:33 lisppaste Exp $
+;;;; $Id: cliki.lisp,v 1.38 2005/10/15 19:16:52 lisppaste Exp $
 ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/cliki.lisp,v $
 
 ;;;; cliki.lisp - CLiki as an infobot; only works on SBCL.
@@ -433,40 +433,44 @@
 
 (defparameter *last-warning-time* 0)
 
+(defmacro without-abuse (&body body)
+  `(flet ((doit () , at body))
+     (if (> (- (get-universal-time) 60)
+	    *last-warning-time*)
+	 (let ((time-6 (first *last-eliza-times*))
+	       (time-4 (third *last-eliza-times*))
+	       (time-2 (fifth *last-eliza-times*))
+	       (current-time (get-universal-time))
+	       (count 0)
+	       (overload 0))
+	   (if (or
+		(and
+		 (< (- current-time 60)
+		    time-2)
+		 (setf count 3)
+		 (setf overload (- current-time time-2)))
+		(and
+		 (< (- current-time 75)
+		    time-4)
+		 (setf count 5)
+		 (setf overload (- current-time time-4)))
+		(and
+		 (< (- current-time 90)
+		    time-6)
+		 (setf count 7)
+		 (setf overload (- current-time time-6))))
+	       (progn
+		 (setf *last-warning-time* (get-universal-time))
+		 (format nil "Would you /please/ stop playing with me? ~A messages in ~A seconds is too many." count overload))
+	       (progn
+		 (setf *last-eliza-times* (nconc (cdr *last-eliza-times*)
+						 (list (get-universal-time))))
+		 (doit))
+	       
+	     )))))
+
 (defun do-eliza (first-pass)
-  (if (> (- (get-universal-time) 60)
-         *last-warning-time*)
-      (let ((time-6 (first *last-eliza-times*))
-            (time-4 (third *last-eliza-times*))
-            (time-2 (fifth *last-eliza-times*))
-            (current-time (get-universal-time))
-            (count 0)
-            (overload 0))
-        (if (or
-             (and
-              (< (- current-time 60)
-                 time-2)
-              (setf count 3)
-              (setf overload (- current-time time-2)))
-             (and
-              (< (- current-time 75)
-                 time-4)
-              (setf count 5)
-              (setf overload (- current-time time-4)))
-             (and
-              (< (- current-time 90)
-                 time-6)
-              (setf count 7)
-              (setf overload (- current-time time-6))))
-            (progn
-              (setf *last-warning-time* (get-universal-time))
-              (format nil "Would you /please/ stop playing with me? ~A messages in ~A seconds is too many." count overload))
-            (progn
-              (setf *last-eliza-times* (nconc (cdr *last-eliza-times*)
-                                              (list (get-universal-time))))
-              (ignore-errors (eliza::eliza first-pass)))
-            
-            ))))
+  (without-abuse (ignore-errors (eliza::eliza first-pass))))
 
 (defvar *more* "CODE")
 
@@ -685,11 +689,12 @@
 		     (and str
 			  (let ((letters (remove #\" (elt str 0))))
 			    (when (< (length letters) 9)
-			      (if (and (> (length letters) 2)
-				       (string-equal (subseq letters (- (length letters) 2)) "cl"))
-				  (steel-bazooka:steel-whatever :letters (string-downcase (subseq letters 0 (- (length letters) 2))))
-				  (steel-bazooka:steel-whatever :letters (string-downcase letters) :suffix nil))))))
-                   (let ((str (nth-value 1 (scan-to-strings "^(?i)shorten\\s+(\\w+://.+\\S)\\s*$" term-with-question))))
+			      (without-abuse
+				  (if (and (> (length letters) 2)
+					   (string-equal (subseq letters (- (length letters) 2)) "cl"))
+				      (steel-bazooka:steel-whatever :letters (string-downcase (subseq letters 0 (- (length letters) 2))))
+				      (steel-bazooka:steel-whatever :letters (string-downcase letters) :suffix nil)))))))
+		   (let ((str (nth-value 1 (scan-to-strings "^(?i)shorten\\s+(\\w+://.+\\S)\\s*$" term-with-question))))
                      (and str
                           (shorten (elt str 0))))
                    (if (should-do-lookup first-pass (or channel sender ""))