cl-irc-cvs June 2004

cl-irc-cvs@common-lisp.net

2 participants
12 discussions

Re: [Cl-irc-cvs] CVS update: cl-irc/command.lisp cl-irc/package.lisp cl-irc/protocol.lisp
by Erik Huelsmann 22 Jun '04

22 Jun '04

> > This commit broke start-background-message-handler on non-threaded > > SBCL which apparently is the only system which was still using > > server-socket. How about this patch to fix? > > Sounds great! Go ahead and commit it. (I believe you have CVS access?) I > had made my own patch but it was much more complicated than this; this one > looks fine. Done. bye, Erik. -- +++ Jetzt WLAN-Router f�r alle DSL-Einsteiger und Wechsler +++ GMX DSL-Powertarife zudem 3 Monate gratis* http://www.gmx.net/dsl

1 1

[Cl-irc-cvs] CVS update: cl-irc/example/cliki.lisp
by Brian Mastenbrook 22 Jun '04

22 Jun '04

Update of /project/cl-irc/cvsroot/cl-irc/example In directory common-lisp.net:/home/bmastenbrook/cl-irc/example Modified Files: cliki.lisp Log Message: Memos and better aliases oh my! Date: Tue Jun 22 11:21:05 2004 Author: bmastenbrook Index: cl-irc/example/cliki.lisp diff -u cl-irc/example/cliki.lisp:1.10 cl-irc/example/cliki.lisp:1.11 --- cl-irc/example/cliki.lisp:1.10 Thu Jun 17 10:40:35 2004 +++ cl-irc/example/cliki.lisp Tue Jun 22 11:21:05 2004 @@ -1,4 +1,4 @@ -;;;; $Id: cliki.lisp,v 1.10 2004/06/17 17:40:35 bmastenbrook Exp $ +;;;; $Id: cliki.lisp,v 1.11 2004/06/22 18:21:05 bmastenbrook Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/cliki.lisp,v $ ;;;; cliki.lisp - CLiki as an infobot; only works on SBCL. @@ -12,32 +12,115 @@ :*respond-to-general-hellos* :shut-up :un-shut-up)) (in-package :cliki) - (defvar *small-definitions* nil) +(defvar *aliases* nil) + +(defun forget (term-or-alias) + (setf *small-definitions* (remove term-or-alias *small-definitions* :test #'string-equal :key #'car)) + (setf *aliases* (remove term-or-alias *aliases* :test #'string-equal :key #'car)) + (write-small-definitions)) + +(defun fix-aliases () + (setf *small-definitions* + (loop for defn in *small-definitions* + if (stringp (cdr defn)) + collect defn + else do (push (cons (first defn) (second defn)) + *aliases*)))) + (defun read-small-definitions () (setf *small-definitions* nil) + (setf *aliases* nil) (with-open-file (sd-file "sd.lisp-expr" :direction :input :if-does-not-exist nil) (when sd-file - (block nil - (loop (let ((defn (read sd-file nil))) - (if defn (push defn *small-definitions*) - (return (setf *small-definitions* (nreverse *small-definitions*)))))))))) + (loop for defn = (read sd-file nil) + if defn do (ecase (car defn) + (:sd (push (cdr defn) *small-definitions*)) + (:alias (push (cdr defn) *aliases*))) + else return *small-definitions*)))) (defun write-small-definitions () (with-open-file (sd-file "sd.lisp-expr" :direction :output :if-exists :supersede) - (mapc #'(lambda (defn) - (prin1 defn sd-file) - (format sd-file "~%")) *small-definitions*))) + (mapc #'(lambda (db) + (mapc #'(lambda (defn) + (prin1 (cons (car db) defn) sd-file) + (format sd-file "~%")) (reverse (cdr db)))) + (list (cons :sd *small-definitions*) + (cons :alias *aliases*))))) -(defun write-top-definition () +(defun write-top-definition (&key (of *small-definitions*) (type :sd)) (with-open-file (sd-file "sd.lisp-expr" :direction :output :if-exists :append) - (prin1 (car *small-definitions*) sd-file) + (prin1 (cons type (car of)) sd-file) (format sd-file "~%"))) (defun add-small-definition (term defn) (push (cons term defn) *small-definitions*) - (write-small-definitions)) + (write-top-definition)) + +(defun add-alias (term defn) + (push (cons term defn) *aliases*) + (write-top-definition :of *aliases* :type :alias)) + +(defvar *lookup-depth* 0) + +(defvar *followed-aliases* nil) + +(defun alias-string-equal (orig candidate) + (unless (member candidate *followed-aliases* :test #'string-equal) + (string-equal orig candidate))) + +(defun small-definition-lookup (text) + (cdr (assoc text *small-definitions* :test #'string-equal))) + +(defun alias-lookup (text) + (let ((alias (or (cdr (assoc text *aliases* :test #'alias-string-equal)) + (car (rassoc text *aliases* :test #'alias-string-equal))))) + (if alias + (let ((*lookup-depth* (1+ *lookup-depth*)) + (*followed-aliases* (cons alias *followed-aliases*))) + (if (> *lookup-depth* 5) + "Too many recursive lookups." + (cliki-lookup alias)))))) + +(defclass memo () + ((from :accessor memo-from :initarg :from) + (to :accessor memo-to :initarg :to) + (contents :accessor memo-contents :initarg :contents))) + +(defun without-non-alphanumeric (string) + (with-output-to-string (s) + (loop for char across string + if (alphanumericp char) + do (princ char s)))) + +(defvar *pending-memos* nil) + +(defun memo-alias-test (orig candidate) + (or (string-equal orig (car candidate)) + (string-equal orig (cdr candidate)) + (string-equal orig (without-non-alphanumeric (car candidate))) + (string-equal orig (without-non-alphanumeric (cdr candidate))))) + +(defun take-care-of-memos (channel user &key (original-user user) (no-alias nil)) + (let ((found (find (without-non-alphanumeric user) *pending-memos* :test #'string-equal :key #'memo-to :from-end t))) + (if found + (progn + (setf *pending-memos* (remove found *pending-memos*)) + (privmsg *cliki-connection* channel (format nil "~A, memo from ~A: ~A" original-user (memo-from found) (memo-contents found))) + (take-care-of-memos channel user :original-user original-user)) + (if (not no-alias) + (let ((alias (find (without-non-alphanumeric user) + *aliases* + :test #'memo-alias-test))) + (if alias + (take-care-of-memos channel (cdr alias) :original-user original-user :no-alias t))))))) + +(defun add-memo (from to contents) + (push (make-instance 'memo :from from + :to (without-non-alphanumeric to) + :contents contents) + *pending-memos*)) (defun url-port (url) (assert (string-equal url "http://" :end1 7)) @@ -138,8 +221,8 @@ (setf first-line (regex-replace-all "<[^>]+>" first-line "")) (setf first-line (regex-replace-all "^(([^.]|\\.\\S)+)\\.\\s+.*$" first-line "\\1.")) (setf first-line (regex-replace-all "(\\s)\\s+" first-line "\\1")) - (setf first-line (regex-replace-all "^\\s(.+)$" first-line "\\1")) - (when (scan "^([^.]|\\.\\S)+\\.$" first-line) + (setf first-line (regex-replace-all "^\\s*(.+\\S)\\s*$" first-line "\\1")) + (when (scan "^([^.]|\\.\\S)+[.?!]$" first-line) (setf first-line (concatenate 'string first-line " " cliki-url)) (return-from cliki-return first-line)))) (format nil "No definition was found in the first 5 lines of ~A" cliki-url))) @@ -155,7 +238,6 @@ (defun un-shut-up () (setf (irc:client-stream *cliki-connection*) *trace-output*)) - (defmacro aif (test conseq &optional (else nil)) `(let ((it ,test)) (if it ,conseq @@ -173,48 +255,69 @@ (let ((first-pass (regex-replace-all "^(\\s*)([^?]+)(\\?*)$" term-with-question "\\2"))) (setf first-pass (regex-replace-all "\\s\\s+" first-pass "")) (setf first-pass (regex-replace-all "\\s*$" first-pass "")) - (if (scan "^add \"([^\"]+)\" as: (.+)$" first-pass) - (let ((term (regex-replace "^add \"([^\"]+)\" .*$" first-pass "\\1")) - (defn (regex-replace "^add \"[^\"]+\" as: (.+)$" first-pass "\\1"))) - (add-small-definition term defn) - "OK, done.") - (if (scan "^alias \"([^\"]+)\" as: (.+)$" first-pass) - (let ((term (regex-replace "^alias \"([^\"]+)\" .*$" first-pass "\\1")) - (defn (regex-replace "^alias \"[^\"]+\" as: (.+)$" first-pass "\\1"))) - (add-small-definition term (list defn)) - "OK, done.") - (progn - (setf first-pass (regex-replace-all "(:|/|\\\\|\\#)" first-pass "")) - (when (and (scan "^(?i)lisppaste(\\s|!|\\?|\\.|$)*" first-pass) - (find-package :lisppaste) - channel - (> (length channel) 0) - (char= (elt channel 0) #\#) - (funcall (intern "SAY-HELP" :lisppaste) - channel)) - (return-from cliki-lookup nil)) - (or - (if (string-equal first-pass "help") *cliki-bot-help*) - (if (scan "^(?i)hello(\\s|$)*" first-pass) "what's up?") - (if (scan "^(?i)hi(\\s|$)*" first-pass) "what's up?") - (if (scan "^(?i)yo(\\s|$)*" first-pass) "what's up?") - (if (scan "^(?i)thank(s| you)(\\s|!|\\?|\\.|$)*" first-pass) - (if sender - (format nil "~A: you failed the inverse turing test!" sender) - "you failed the inverse turing test!")) - (if (scan "^(?i)version(\\s|!|\\?|\\.|$)*" first-pass) - (format nil "This is the minion bot, running on a ~A (~A) and running under ~A ~A." (machine-type) (machine-version) (lisp-implementation-type) (lisp-implementation-version))) - (if (scan "^(?i)(?i)do my bidding!*$" first-pass) "Yes, my master.") - (aif (or (let ((term (cdr (assoc first-pass *small-definitions* :test #'string-equal)))) - (if term (if (stringp term) term (cliki-lookup (car term))))) - (cliki-first-sentence first-pass)) (concatenate 'string first-pass ": " it)) - (if (scan "(!|\\.|\\s.+\\?|\\)|\\()\\s*$" term-with-question) - ;;(generate-text (+ 20 (random 6))) - (ignore-errors (eliza::eliza first-pass)) - ) - (format nil "Sorry, I couldn't find anything in the database for ``~A''.~A" first-pass (if (scan " " first-pass) " Maybe you meant to end with punctuation?" "")) - )))))) - + (let ((scanned (or (nth-value 1 (scan-to-strings "^add\\s+\"([^\"]+)\"\\s+as:*\\s+(.+)$" first-pass)) + (nth-value 1 (scan-to-strings "^add\\s+(.+)\\s+as:\\s+(.+)$" first-pass))))) + (if scanned + (let ((term (elt scanned 0)) + (defn (elt scanned 1))) + (add-small-definition term defn) + "OK, done.") + (let ((scanned (or + (nth-value 1 (scan-to-strings "^alias\\s+\"([^\"]+)\"\\s+as:*\\s+(.+)$" first-pass)) + (nth-value 1 (scan-to-strings "^alias\\s+(.+)\\s+as:*\\s+(.+)$" first-pass)) + (nth-value 1 (scan-to-strings "^(.+)\\s+is\\s+another\\s+(name|word)\\s+for:*\\s+([^.]+)\\.*$" first-pass))))) + (if scanned + (let ((term (elt scanned 0)) + (defn (elt scanned (1- (length scanned))))) + (add-alias term defn) + "OK, done.") + (progn + (setf first-pass (regex-replace-all "(:|/|\\\\|\\#)" first-pass "")) + (when (and (scan "^(?i)lisppaste(\\s|!|\\?|\\.|$)*" first-pass) + (find-package :lisppaste) + channel + (> (length channel) 0) + (char= (elt channel 0) #\#) + (funcall (intern "SAY-HELP" :lisppaste) + channel)) + (return-from cliki-lookup nil)) + (or + (if (string-equal first-pass "help") *cliki-bot-help*) + (let ((strings (nth-value 1 (scan-to-strings "^(?i)memo\\s+(for|to)\\s+(\\S+)\\s+:*\\s*(.+)$" first-pass)))) + (when (and sender strings) + (add-memo + sender + (if (member (elt strings 1) '("self" "myself" "me") :test #'string-equal) + sender + (elt strings 1)) + (elt strings 2)) + (format nil "Remembered. I'll tell ~A when he/she/it next speaks." (elt strings 1)))) + (let ((to-forget (nth-value 1 (scan-to-strings "^forget\\s+([^.]+)\\.*$" first-pass)))) + (when to-forget + (forget (elt to-forget 0)) + (format nil "What's ~A? Never heard of it." (elt to-forget 0)))) + (if (scan "^(?i)hello(\\s|$)*" first-pass) "what's up?") + (if (scan "^(?i)hi(\\s|$)*" first-pass) "what's up?") + (if (scan "^(?i)yo(\\s|$)*" first-pass) "what's up?") + (if (scan "^(?i)thank(s| you)(\\s|!|\\?|\\.|$)*" first-pass) + (if sender + (format nil "~A: you failed the inverse turing test!" sender) + "you failed the inverse turing test!")) + (if (scan "^(?i)version(\\s|!|\\?|\\.|$)*" first-pass) + (format nil "This is the minion bot, running on a ~A (~A) and running under ~A ~A." (machine-type) (machine-version) (lisp-implementation-type) (lisp-implementation-version))) + (if (scan "^(?i)(?i)do my bidding!*$" first-pass) "Yes, my master.") + (aif (or (small-definition-lookup first-pass) + (cliki-first-sentence first-pass) + (alias-lookup first-pass)) (concatenate 'string first-pass ": " it)) + (if (or + (scan "(!|\\.|\\s.+\\?|\\)|\\()\\s*$" term-with-question) + (scan "^\\s*\\S+\\s+\\S+.*$" term-with-question)) + ;;(generate-text (+ 20 (random 6))) + (ignore-errors (eliza::eliza first-pass)) + ) + (format nil "Sorry, I couldn't find anything in the database for ``~A''.~A" first-pass (if (scan " " first-pass) " Maybe you meant to end with punctuation?" "")) + )))))))) + (defun valid-cliki-message (message) (scan *cliki-attention-prefix* (trailing-argument message))) @@ -227,11 +330,12 @@ (defun msg-hook (message) (let ((respond-to (if (string-equal (first (arguments message)) *cliki-nickname*) (source message) (first (arguments message))))) + (take-care-of-memos respond-to (source message)) (if (valid-cliki-message message) (let ((response (cliki-lookup (regex-replace *cliki-attention-prefix* (trailing-argument message) "") :sender (source message) :channel (first (irc:arguments message))))) (and response (privmsg *cliki-connection* respond-to response))) (if (string-equal (first (arguments message)) *cliki-nickname*) - (privmsg *cliki-connection* respond-to (cliki-lookup (trailing-argument message))) + (privmsg *cliki-connection* respond-to (cliki-lookup (trailing-argument message) :sender (source message))) (if (anybody-here (trailing-argument message)) (privmsg *cliki-connection* (first (arguments message)) (format nil "~A: hello." (source message))))))))

1 0

[Cl-irc-cvs] CVS update: cl-irc/command.lisp cl-irc/package.lisp cl-irc/protocol.lisp
by Brian Mastenbrook 22 Jun '04

22 Jun '04

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp.net:/tmp/cvs-serv10886 Modified Files: command.lisp package.lisp protocol.lisp Log Message: Armed Bear Common Lisp compatibility Date: Wed Jun 9 11:54:25 2004 Author: bmastenbrook Index: cl-irc/command.lisp diff -u cl-irc/command.lisp:1.4 cl-irc/command.lisp:1.5 --- cl-irc/command.lisp:1.4 Fri May 21 09:41:58 2004 +++ cl-irc/command.lisp Wed Jun 9 11:54:25 2004 @@ -1,4 +1,4 @@ -;;;; $Id: command.lisp,v 1.4 2004/05/21 16:41:58 bmastenbrook Exp $ +;;;; $Id: command.lisp,v 1.5 2004/06/09 18:54:25 bmastenbrook Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/command.lisp,v $ ;;;; See LICENSE for licensing information. @@ -245,8 +245,7 @@ (sb-bsd-sockets:socket-connect s (car (sb-bsd-sockets:host-ent-addresses (sb-bsd-sockets:get-host-by-name host))) port) s) - #+openmcl - (ccl:make-socket :remote-host host :remote-port port)) + ) (defun socket-stream (socket) #+sbcl @@ -258,6 +257,18 @@ #+openmcl socket) +(defun socket-connect (server port) + #+lispworks (comm:open-tcp-stream server port :errorp t) + #+cmu (sys:make-fd-stream (ext:connect-to-inet-socket server port) + :input t + :output t + :element-type 'character) + #+allegro (socket:make-socket :remote-host server :remote-port port) + #+sbcl (socket-stream (connect-to-server-socket server port)) + #+openmcl (ccl:make-socket :remote-host server :remote-port port) + #+armedbear (ext:get-socket-stream (ext:make-socket server port)) + ) + (defun connect (&key (nickname *default-nickname*) (username nil) (realname nil) @@ -266,20 +277,11 @@ (port *default-irc-server-port*) (logging-stream t)) "Connect to server and return a connection object." - (let* ((socket #+(or sbcl openmcl) (connect-to-server-socket server port)) - (stream #+lispworks (comm:open-tcp-stream server port :errorp t) - #+cmu (sys:make-fd-stream (ext:connect-to-inet-socket server port) - :input t - :output t - :element-type 'character) - #+allegro (socket:make-socket :remote-host server :remote-port port) - #+sbcl (socket-stream socket) - #+openmcl socket) + (let* ((stream (socket-connect server port)) (user (make-user :nickname nickname :username username :realname realname)) - (connection (make-connection :server-socket socket - :server-stream stream + (connection (make-connection :server-stream stream :client-stream logging-stream :user user :server-name server))) Index: cl-irc/package.lisp diff -u cl-irc/package.lisp:1.3 cl-irc/package.lisp:1.4 --- cl-irc/package.lisp:1.3 Tue Mar 9 10:45:10 2004 +++ cl-irc/package.lisp Wed Jun 9 11:54:25 2004 @@ -1,4 +1,4 @@ -;;;; $Id: package.lisp,v 1.3 2004/03/09 18:45:10 ehuelsmann Exp $ +;;;; $Id: package.lisp,v 1.4 2004/06/09 18:54:25 bmastenbrook Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/package.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -14,6 +14,7 @@ :read-message :start-background-message-handler :stop-background-message-handler + :socket-connect :send-message :server-name :no-such-reply Index: cl-irc/protocol.lisp diff -u cl-irc/protocol.lisp:1.7 cl-irc/protocol.lisp:1.8 --- cl-irc/protocol.lisp:1.7 Fri May 21 09:41:58 2004 +++ cl-irc/protocol.lisp Wed Jun 9 11:54:25 2004 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.7 2004/05/21 16:41:58 bmastenbrook Exp $ +;;;; $Id: protocol.lisp,v 1.8 2004/06/09 18:54:25 bmastenbrook Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/protocol.lisp,v $ ;;;; See LICENSE for licensing information. @@ -143,14 +143,15 @@ #+cmu (mp:make-process function :name name) #+lispworks (mp:process-run-function name nil function) #+sb-thread (sb-thread:make-thread function) - #+openmcl (ccl:process-run-function name function)) + #+openmcl (ccl:process-run-function name function) + #+armedbear (ext:make-thread function)) (defmethod start-background-message-handler ((connection connection)) "Read messages from the `connection', parse them and dispatch irc-message-event on them. Returns background process ID if available." (flet ((do-loop () (read-message-loop connection))) (let ((name (format nil "irc-hander-~D" (incf *process-count*)))) - #+(or allegro cmu lispworks sb-thread openmcl) + #+(or allegro cmu lispworks sb-thread openmcl armedbear) (start-process #'do-loop name) #+(and sbcl (not sb-thread)) (sb-sys:add-fd-handler (sb-bsd-sockets:socket-file-descriptor @@ -165,7 +166,8 @@ #+allegro (mp:process-kill process) #+sb-thread (sb-thread:destroy-thread process) #+lispworks (mp:process-kill process) - #+openmcl (ccl:process-kill process)) + #+openmcl (ccl:process-kill process) + #+armedbear (ext:destroy-thread process)) (defmethod read-message-loop ((connection connection)) (loop while (read-message connection))) @@ -633,7 +635,7 @@ :initarg :ctcp-command :accessor ctcp-command))) -(defclass standard-ctcp-message (ctcp-mixin message) ()) +(defclass standard-ctcp-message (ctcp-mixin irc-message) ()) (defgeneric find-ctcp-message-class (type))

2 1

[Cl-irc-cvs] CVS update: cl-irc/example/754.lisp-expr cl-irc/example/cliki.lisp cl-irc/example/specbot.lisp
by Brian Mastenbrook 17 Jun '04

17 Jun '04

Update of /project/cl-irc/cvsroot/cl-irc/example In directory common-lisp.net:/home/bmastenbrook/cl-irc/example Modified Files: cliki.lisp specbot.lisp Added Files: 754.lisp-expr Log Message: alist lookup example: IEEE754 Date: Thu Jun 17 10:40:36 2004 Author: bmastenbrook Index: cl-irc/example/cliki.lisp diff -u cl-irc/example/cliki.lisp:1.9 cl-irc/example/cliki.lisp:1.10 --- cl-irc/example/cliki.lisp:1.9 Wed Jun 9 11:54:25 2004 +++ cl-irc/example/cliki.lisp Thu Jun 17 10:40:35 2004 @@ -1,4 +1,4 @@ -;;;; $Id: cliki.lisp,v 1.9 2004/06/09 18:54:25 bmastenbrook Exp $ +;;;; $Id: cliki.lisp,v 1.10 2004/06/17 17:40:35 bmastenbrook Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/cliki.lisp,v $ ;;;; cliki.lisp - CLiki as an infobot; only works on SBCL. @@ -144,7 +144,7 @@ (return-from cliki-return first-line)))) (format nil "No definition was found in the first 5 lines of ~A" cliki-url))) (if stream (close stream))))) - (condition (c &rest whatever) (return-from cliki-return (format nil "An error was encountered in lookup."))))))) + (condition (c &rest whatever) (return-from cliki-return (regex-replace-all "\\n" (format nil "An error was encountered in lookup: ~A." c) " "))))))) (defvar *cliki-connection*) (defvar *cliki-nickname*) @@ -165,7 +165,7 @@ (defun make-cliki-attention-prefix (nick) (format nil "^~A[,:]\\s+" nick)) -(defparameter *cliki-attention-prefix* "") +(defvar *cliki-attention-prefix* "") (defparameter *cliki-bot-help* "The minion bot supplies small definitions and performs lookups on CLiki. To use it, try ``minion: term?''. To add a term for IRC, try saying ``minion: add \"term\" as: definition'' or ``minion: alias \"term\" as: term''; otherwise, edit the corresponding CLiki page.") Index: cl-irc/example/specbot.lisp diff -u cl-irc/example/specbot.lisp:1.2 cl-irc/example/specbot.lisp:1.3 --- cl-irc/example/specbot.lisp:1.2 Sat Jun 12 13:03:22 2004 +++ cl-irc/example/specbot.lisp Thu Jun 17 10:40:35 2004 @@ -1,4 +1,4 @@ -;;;; $Id: specbot.lisp,v 1.2 2004/06/12 20:03:22 bmastenbrook Exp $ +;;;; $Id: specbot.lisp,v 1.3 2004/06/17 17:40:35 bmastenbrook Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/specbot.lisp,v $ ;;;; specbot.lisp - an example IRC bot for cl-irc @@ -57,11 +57,26 @@ it (format nil "Nothing was found for: ~A" str))) -(defparameter *spec-providers* +(defvar *spec-providers* '((clhs-lookup "clhs" "The Common Lisp HyperSpec") (r5rs-lookup "r5rs" "The Revised 5th Ed. Report on the Algorithmic Language Scheme") (elisp-lookup "elisp" "GNU Emacs Lisp Reference Manual"))) +(defvar *alists* nil) + +(defun add-simple-alist-lookup (file designator prefix description) + (let ((alist (with-open-file (s file :direction :input) (read s)))) + (push (cons designator alist) *alists*) + (setf *spec-providers* + (nconc *spec-providers* + (list `((simple-alist-lookup ,designator) ,prefix ,description)))))) + +(defun simple-alist-lookup (designator string) + (let ((alist (cdr (assoc designator *alists*)))) + (aif (assoc string alist :test #'equalp) + (cdr it) + (format nil "Nothing was found for: ~A" string)))) + (defun valid-message (string prefix &key space-allowed) (if (eql (search prefix string :test #'char-equal) 0) (and (or space-allowed @@ -94,11 +109,16 @@ (format nil "The available databases are: ~{~{~*~S, ~A~}~^; ~}" *spec-providers*))) (loop for type in *spec-providers* + for actual-fun = (if (typep (first type) 'symbol) + (first type) + (lambda (lookup) (destructuring-bind (fun first-arg) (first type) + (funcall fun first-arg lookup)))) do (aif (strip-address to-lookup :address (second type) :final t) - (privmsg *connection* destination (funcall (first type) it))))))) + (privmsg *connection* destination (funcall actual-fun it))))))) (defun start-specbot (nick server &rest channels) + (add-simple-alist-lookup "754.lisp-expr" 'ieee754 "ieee754" "Section numbers of IEEE 754") (setf *nickname* nick) (setf *connection* (connect :nickname *nickname* :server server)) (mapcar #'(lambda (channel) (join *connection* channel)) channels)

1 0

[Cl-irc-cvs] CVS update: cl-irc/example/specbot.lisp
by Brian Mastenbrook 12 Jun '04

12 Jun '04

Update of /project/cl-irc/cvsroot/cl-irc/example In directory common-lisp.net:/home/bmastenbrook/cl-irc/example Modified Files: specbot.lisp Log Message: s/Comon/Common/g Date: Sat Jun 12 13:03:22 2004 Author: bmastenbrook Index: cl-irc/example/specbot.lisp diff -u cl-irc/example/specbot.lisp:1.1 cl-irc/example/specbot.lisp:1.2 --- cl-irc/example/specbot.lisp:1.1 Thu Jun 3 07:11:59 2004 +++ cl-irc/example/specbot.lisp Sat Jun 12 13:03:22 2004 @@ -1,4 +1,4 @@ -;;;; $Id: specbot.lisp,v 1.1 2004/06/03 14:11:59 bmastenbrook Exp $ +;;;; $Id: specbot.lisp,v 1.2 2004/06/12 20:03:22 bmastenbrook Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/specbot.lisp,v $ ;;;; specbot.lisp - an example IRC bot for cl-irc @@ -50,9 +50,17 @@ it (format nil "Nothing was found for: ~A" str))) +(defun elisp-lookup (str) + (aif (and (find-package :elisp-lookup) + (funcall (intern "SYMBOL-LOOKUP" :elisp-lookup) + str)) + it + (format nil "Nothing was found for: ~A" str))) + (defparameter *spec-providers* - '((clhs-lookup "clhs" "The Comon Lisp HyperSpec") - (r5rs-lookup "r5rs" "The Revised 5th Ed. Report on the Algorithmic Language Scheme"))) + '((clhs-lookup "clhs" "The Common Lisp HyperSpec") + (r5rs-lookup "r5rs" "The Revised 5th Ed. Report on the Algorithmic Language Scheme") + (elisp-lookup "elisp" "GNU Emacs Lisp Reference Manual"))) (defun valid-message (string prefix &key space-allowed) (if (eql (search prefix string :test #'char-equal) 0) @@ -75,7 +83,8 @@ (source message) (first (arguments message)))) (to-lookup (strip-address (trailing-argument message)))) - (if (member to-lookup '("help" "help?") :test #'string-equal) + (if (and (not (string= to-lookup (trailing-argument message))) + (member to-lookup '("help" "help?") :test #'string-equal)) (progn (privmsg *connection* destination (format nil "To use the ~A bot, say something like \"database term\", where database is one of (~{~S~^, ~}) and term is the desired lookup."

1 0

[Cl-irc-cvs] CVS update: cl-irc/example/cliki.lisp cl-irc/example/eliza-rules.lisp
by Brian Mastenbrook 09 Jun '04

09 Jun '04

Update of /project/cl-irc/cvsroot/cl-irc/example In directory common-lisp.net:/tmp/cvs-serv10886/example Modified Files: cliki.lisp eliza-rules.lisp Log Message: Armed Bear Common Lisp compatibility Date: Wed Jun 9 11:54:25 2004 Author: bmastenbrook Index: cl-irc/example/cliki.lisp diff -u cl-irc/example/cliki.lisp:1.8 cl-irc/example/cliki.lisp:1.9 --- cl-irc/example/cliki.lisp:1.8 Thu Jun 3 07:15:16 2004 +++ cl-irc/example/cliki.lisp Wed Jun 9 11:54:25 2004 @@ -1,4 +1,4 @@ -;;;; $Id: cliki.lisp,v 1.8 2004/06/03 14:15:16 bmastenbrook Exp $ +;;;; $Id: cliki.lisp,v 1.9 2004/06/09 18:54:25 bmastenbrook Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/cliki.lisp,v $ ;;;; cliki.lisp - CLiki as an infobot; only works on SBCL. @@ -51,27 +51,6 @@ (or port-start (length url))))) (subseq url 7 host-end))) -#+(or ccl allegro) -(defun socket-connect (host port) - (#+ccl ccl:make-socket - #+allegro socket:make-socket - :connect :active - :remote-host host - :remote-port port)) - -#+sbcl -(defun socket-connect (host port) - (let ((s (make-instance 'sb-bsd-sockets:inet-socket - :type :stream - :protocol :tcp))) - (sb-bsd-sockets:socket-connect s (car (sb-bsd-sockets:host-ent-addresses - (sb-bsd-sockets:get-host-by-name host))) port) - (sb-bsd-sockets:socket-make-stream s - :element-type 'character - :input t - :output t - :buffering :none))) - (defun url-connection (url) (let* ((host (url-host url)) (port (url-port url)) @@ -100,6 +79,11 @@ ;(format t "hi ~A~%" str) str) +#-(or sbcl ccl) +(defmacro host-with-timeout (timeout &body body) + (declare (ignore timeout)) + `(progn ,@body)) + #+sbcl (defmacro host-with-timeout (timeout &body body) `(sb-ext:with-timeout ,timeout ,@body)) @@ -178,7 +162,10 @@ (symbol-macrolet ((it ,test)) ,else)))) -(defparameter *cliki-attention-prefix* "^minion[,:]\\s+") +(defun make-cliki-attention-prefix (nick) + (format nil "^~A[,:]\\s+" nick)) + +(defparameter *cliki-attention-prefix* "") (defparameter *cliki-bot-help* "The minion bot supplies small definitions and performs lookups on CLiki. To use it, try ``minion: term?''. To add a term for IRC, try saying ``minion: add \"term\" as: definition'' or ``minion: alias \"term\" as: term''; otherwise, edit the corresponding CLiki page.") @@ -259,6 +246,7 @@ (read-small-definitions) (setf *cliki-nickname* nick) (setf *cliki-connection* (connect :nickname *cliki-nickname* :server server)) + (setf *cliki-attention-prefix* (make-cliki-attention-prefix nick)) (mapcar #'(lambda (channel) (join *cliki-connection* channel)) channels) (add-hook *cliki-connection* 'irc::irc-privmsg-message 'msg-hook) (add-hook *cliki-connection* 'irc::irc-notice-message 'notice-hook) Index: cl-irc/example/eliza-rules.lisp diff -u cl-irc/example/eliza-rules.lisp:1.3 cl-irc/example/eliza-rules.lisp:1.4 --- cl-irc/example/eliza-rules.lisp:1.3 Tue Jun 1 06:48:12 2004 +++ cl-irc/example/eliza-rules.lisp Wed Jun 9 11:54:25 2004 @@ -21,6 +21,7 @@ (((?* ?x) bot (?* ?y)) (|I'm| not a |bot.| I prefer the term |``electronically composed''.|)) + #-armedbear ((seen ?x) (?x was last seen 5y6m14d32h43m10s |ago,| saying |"minion: when are you going to support seen?"|)) @@ -44,14 +45,17 @@ ((not much) (good)) + #-armedbear (((?* ?x) linux (?* ?y)) (I run on Crux Linux - |http://www.crux.nu/|)) + #-armedbear (((?* ?x) crux (?* ?y)) (I like running on Crux Linux)) (((?* ?x) slackware (?* ?y)) (Slackware is nice but I like Crux)) + #-armedbear (((?* ?x) debian (?* ?y)) (|baah, use crux: http://www.crux.nu/|)) @@ -376,7 +380,7 @@ (superman) (bill clinton) (king kong) (me)) ((what (?* ?x)) - (a |man, a plan, a canal: panama|) + (a |man, a plan, a canal - panama|) (a banana) (42))

1 0

[Cl-irc-cvs] CVS update: cl-irc/example/cliki.lisp cl-irc/example/Mop_Sym.txt
by Brian Mastenbrook 03 Jun '04

03 Jun '04

Update of /project/cl-irc/cvsroot/cl-irc/example In directory common-lisp.net:/home/bmastenbrook/cl-irc/example Modified Files: cliki.lisp Removed Files: Mop_Sym.txt Log Message: CLiki: shut-up function; Mop_Sym removed Date: Thu Jun 3 07:15:16 2004 Author: bmastenbrook Index: cl-irc/example/cliki.lisp diff -u cl-irc/example/cliki.lisp:1.7 cl-irc/example/cliki.lisp:1.8 --- cl-irc/example/cliki.lisp:1.7 Tue Jun 1 08:39:15 2004 +++ cl-irc/example/cliki.lisp Thu Jun 3 07:15:16 2004 @@ -1,4 +1,4 @@ -;;;; $Id: cliki.lisp,v 1.7 2004/06/01 15:39:15 bmastenbrook Exp $ +;;;; $Id: cliki.lisp,v 1.8 2004/06/03 14:15:16 bmastenbrook Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/cliki.lisp,v $ ;;;; cliki.lisp - CLiki as an infobot; only works on SBCL. @@ -9,9 +9,10 @@ (defpackage :cliki (:use :common-lisp :irc :cl-ppcre) (:export :start-cliki-bot :*cliki-nickserv-password* - :*respond-to-general-hellos*)) + :*respond-to-general-hellos* :shut-up :un-shut-up)) (in-package :cliki) + (defvar *small-definitions* nil) (defun read-small-definitions () @@ -163,6 +164,13 @@ (defvar *cliki-connection*) (defvar *cliki-nickname*) + +(defun shut-up () + (setf (irc:client-stream *cliki-connection*) (make-broadcast-stream))) + +(defun un-shut-up () + (setf (irc:client-stream *cliki-connection*) *trace-output*)) + (defmacro aif (test conseq &optional (else nil)) `(let ((it ,test))

1 0

[Cl-irc-cvs] CVS update: cl-irc/example/specbot.lisp
by Brian Mastenbrook 03 Jun '04

03 Jun '04

Update of /project/cl-irc/cvsroot/cl-irc/example In directory common-lisp.net:/home/bmastenbrook/cl-irc/example Added Files: specbot.lisp Log Message: Long live specbot! Date: Thu Jun 3 07:11:59 2004 Author: bmastenbrook

1 0

[Cl-irc-cvs] CVS update: cl-irc/example/clhs.lisp
by Brian Mastenbrook 03 Jun '04

03 Jun '04

Update of /project/cl-irc/cvsroot/cl-irc/example In directory common-lisp.net:/home/bmastenbrook/cl-irc/example Removed Files: clhs.lisp Log Message: clhs is dead; long live specbot Date: Thu Jun 3 07:07:36 2004 Author: bmastenbrook

1 0

[Cl-irc-cvs] CVS update: cl-irc/example/cliki.lisp
by Brian Mastenbrook 01 Jun '04

01 Jun '04

Update of /project/cl-irc/cvsroot/cl-irc/example In directory common-lisp.net:/home/bmastenbrook/cl-irc/example Modified Files: cliki.lisp Log Message: slight change Date: Tue Jun 1 08:39:15 2004 Author: bmastenbrook Index: cl-irc/example/cliki.lisp diff -u cl-irc/example/cliki.lisp:1.6 cl-irc/example/cliki.lisp:1.7 --- cl-irc/example/cliki.lisp:1.6 Tue Jun 1 08:29:19 2004 +++ cl-irc/example/cliki.lisp Tue Jun 1 08:39:15 2004 @@ -1,4 +1,4 @@ -;;;; $Id: cliki.lisp,v 1.6 2004/06/01 15:29:19 bmastenbrook Exp $ +;;;; $Id: cliki.lisp,v 1.7 2004/06/01 15:39:15 bmastenbrook Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/cliki.lisp,v $ ;;;; cliki.lisp - CLiki as an infobot; only works on SBCL. @@ -194,9 +194,9 @@ (find-package :lisppaste) channel (> (length channel) 0) - (char= (elt channel 0) #\#)) - (funcall (intern "SAY-HELP" :lisppaste) - channel) + (char= (elt channel 0) #\#) + (funcall (intern "SAY-HELP" :lisppaste) + channel)) (return-from cliki-lookup nil)) (or (if (string-equal first-pass "help") *cliki-bot-help*)

1 0

[Cl-irc-cvs] CVS update: cl-irc/example/clhs.lisp cl-irc/example/cliki.lisp
by Brian Mastenbrook 01 Jun '04

01 Jun '04

Update of /project/cl-irc/cvsroot/cl-irc/example In directory common-lisp.net:/home/bmastenbrook/cl-irc/example Modified Files: clhs.lisp cliki.lisp Log Message: wootage! minion talks to lisppaste, if it can Date: Tue Jun 1 08:29:19 2004 Author: bmastenbrook Index: cl-irc/example/clhs.lisp diff -u cl-irc/example/clhs.lisp:1.5 cl-irc/example/clhs.lisp:1.6 --- cl-irc/example/clhs.lisp:1.5 Tue Jun 1 06:48:12 2004 +++ cl-irc/example/clhs.lisp Tue Jun 1 08:29:19 2004 @@ -1,4 +1,4 @@ -;;;; $Id: clhs.lisp,v 1.5 2004/06/01 13:48:12 bmastenbrook Exp $ +;;;; $Id: clhs.lisp,v 1.6 2004/06/01 15:29:19 bmastenbrook Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/clhs.lisp,v $ ;;;; clhs.lisp - an example IRC bot for cl-irc @@ -20,7 +20,7 @@ (in-package :clhs) ;;; CLHS. This will be the default lookup. -(defparameter *hyperspec-pathname* #p"/Users/chandler/HyperSpec/") +(defparameter *hyperspec-pathname* #p"/home/bmastenbrook/HyperSpec/") (defparameter *hyperspec-map-file* (merge-pathnames "Data/Map_Sym.txt" *hyperspec-pathname*)) @@ -77,7 +77,7 @@ do (add-clhs-section-to-table section s1 s2 s3 s4 s5)))))))) ;; format directives (loop for code from 32 to 127 - do (setf (gethash (format nil "format:~A" (code-char code)) *table*) + do (setf (gethash (format nil "~~~A" (code-char code)) *table*) (concatenate 'string *hyperspec-root* (case (code-char code) Index: cl-irc/example/cliki.lisp diff -u cl-irc/example/cliki.lisp:1.5 cl-irc/example/cliki.lisp:1.6 --- cl-irc/example/cliki.lisp:1.5 Tue Jun 1 06:48:12 2004 +++ cl-irc/example/cliki.lisp Tue Jun 1 08:29:19 2004 @@ -1,4 +1,4 @@ -;;;; $Id: cliki.lisp,v 1.5 2004/06/01 13:48:12 bmastenbrook Exp $ +;;;; $Id: cliki.lisp,v 1.6 2004/06/01 15:29:19 bmastenbrook Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/cliki.lisp,v $ ;;;; cliki.lisp - CLiki as an infobot; only works on SBCL. @@ -174,7 +174,7 @@ (defparameter *cliki-bot-help* "The minion bot supplies small definitions and performs lookups on CLiki. To use it, try ``minion: term?''. To add a term for IRC, try saying ``minion: add \"term\" as: definition'' or ``minion: alias \"term\" as: term''; otherwise, edit the corresponding CLiki page.") -(defun cliki-lookup (term-with-question &optional sender) +(defun cliki-lookup (term-with-question &key sender channel) (let ((first-pass (regex-replace-all "^(\\s*)([^?]+)(\\?*)$" term-with-question "\\2"))) (setf first-pass (regex-replace-all "\\s\\s+" first-pass "")) (setf first-pass (regex-replace-all "\\s*$" first-pass "")) @@ -190,6 +190,14 @@ "OK, done.") (progn (setf first-pass (regex-replace-all "(:|/|\\\\|\\#)" first-pass "")) + (when (and (scan "^(?i)lisppaste(\\s|!|\\?|\\.|$)*" first-pass) + (find-package :lisppaste) + channel + (> (length channel) 0) + (char= (elt channel 0) #\#)) + (funcall (intern "SAY-HELP" :lisppaste) + channel) + (return-from cliki-lookup nil)) (or (if (string-equal first-pass "help") *cliki-bot-help*) (if (scan "^(?i)hello(\\s|$)*" first-pass) "what's up?") @@ -225,7 +233,8 @@ (defun msg-hook (message) (let ((respond-to (if (string-equal (first (arguments message)) *cliki-nickname*) (source message) (first (arguments message))))) (if (valid-cliki-message message) - (privmsg *cliki-connection* respond-to (cliki-lookup (regex-replace *cliki-attention-prefix* (trailing-argument message) "") (source message))) + (let ((response (cliki-lookup (regex-replace *cliki-attention-prefix* (trailing-argument message) "") :sender (source message) :channel (first (irc:arguments message))))) + (and response (privmsg *cliki-connection* respond-to response))) (if (string-equal (first (arguments message)) *cliki-nickname*) (privmsg *cliki-connection* respond-to (cliki-lookup (trailing-argument message))) (if (anybody-here (trailing-argument message))

1 0

[Cl-irc-cvs] CVS update: cl-irc/example/clhs.lisp cl-irc/example/cliki-bot.asd cl-irc/example/cliki.lisp cl-irc/example/eliza-rules.lisp
by Brian Mastenbrook 01 Jun '04

01 Jun '04

Update of /project/cl-irc/cvsroot/cl-irc/example In directory common-lisp.net:/tmp/cvs-serv12457/example Modified Files: clhs.lisp cliki-bot.asd cliki.lisp eliza-rules.lisp Log Message: Portability fixes Date: Tue Jun 1 06:48:12 2004 Author: bmastenbrook Index: cl-irc/example/clhs.lisp diff -u cl-irc/example/clhs.lisp:1.4 cl-irc/example/clhs.lisp:1.5 --- cl-irc/example/clhs.lisp:1.4 Sun Feb 1 06:11:56 2004 +++ cl-irc/example/clhs.lisp Tue Jun 1 06:48:12 2004 @@ -1,4 +1,4 @@ -;;;; $Id: clhs.lisp,v 1.4 2004/02/01 14:11:56 bmastenbrook Exp $ +;;;; $Id: clhs.lisp,v 1.5 2004/06/01 13:48:12 bmastenbrook Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/clhs.lisp,v $ ;;;; clhs.lisp - an example IRC bot for cl-irc @@ -20,7 +20,7 @@ (in-package :clhs) ;;; CLHS. This will be the default lookup. -(defparameter *hyperspec-pathname* #p"/home/bmastenbrook/HyperSpec/") +(defparameter *hyperspec-pathname* #p"/Users/chandler/HyperSpec/") (defparameter *hyperspec-map-file* (merge-pathnames "Data/Map_Sym.txt" *hyperspec-pathname*)) @@ -167,8 +167,12 @@ (setf *clhs-connection* (connect :nickname *clhs-nickname* :server server)) (mapcar #'(lambda (channel) (join *clhs-connection* channel)) channels) (add-hook *clhs-connection* 'irc::irc-privmsg-message 'msg-hook) - #+sbcl (start-background-message-handler *clhs-connection*) - #-sbcl (read-message-loop *clhs-connection*)) + #+(or sbcl + openmcl) + (start-background-message-handler *clhs-connection*) + #-(or sbcl + openmcl) + (read-message-loop *clhs-connection*)) (defun shuffle-hooks () (irc::remove-hooks *clhs-connection* 'irc::irc-privmsg-message) Index: cl-irc/example/cliki-bot.asd diff -u cl-irc/example/cliki-bot.asd:1.1 cl-irc/example/cliki-bot.asd:1.2 --- cl-irc/example/cliki-bot.asd:1.1 Sat Jan 17 11:19:55 2004 +++ cl-irc/example/cliki-bot.asd Tue Jun 1 06:48:12 2004 @@ -1,4 +1,4 @@ -;;;; $Id: cliki-bot.asd,v 1.1 2004/01/17 19:19:55 bmastenbrook Exp $ +;;;; $Id: cliki-bot.asd,v 1.2 2004/06/01 13:48:12 bmastenbrook Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/cliki-bot.asd,v $ ;;;; See the LICENSE file for licensing information. @@ -17,10 +17,9 @@ :licence "MIT" :description "IRC bot for SBCL" :depends-on - #+sbcl (:cl-irc :cl-ppcre) - #-sbcl (:sbcl) + (:cl-irc :cl-ppcre) :properties ((#:author-email . "cl-irc-devel(a)common-lisp.net") - (#:date . "$Date: 2004/01/17 19:19:55 $") + (#:date . "$Date: 2004/06/01 13:48:12 $") ((#:albert #:output-dir) . "doc/api-doc/") ((#:albert #:formats) . ("docbook")) ((#:albert #:docbook #:template) . "book") @@ -30,4 +29,4 @@ (:file "eliza-rules" :depends-on ("mp2eliza")) (:file "cliki" - :depends-on ("mp2eliza")))) \ No newline at end of file + :depends-on ("mp2eliza")))) Index: cl-irc/example/cliki.lisp diff -u cl-irc/example/cliki.lisp:1.4 cl-irc/example/cliki.lisp:1.5 --- cl-irc/example/cliki.lisp:1.4 Sun Feb 1 06:11:56 2004 +++ cl-irc/example/cliki.lisp Tue Jun 1 06:48:12 2004 @@ -1,4 +1,4 @@ -;;;; $Id: cliki.lisp,v 1.4 2004/02/01 14:11:56 bmastenbrook Exp $ +;;;; $Id: cliki.lisp,v 1.5 2004/06/01 13:48:12 bmastenbrook Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/cliki.lisp,v $ ;;;; cliki.lisp - CLiki as an infobot; only works on SBCL. @@ -7,7 +7,7 @@ ;;; cliki.lisp, and invoke (cliki::start-cliki-bot "desirednickname" ;;; "desiredserver" "#channel1" "#channel2" "#channel3" ...) -(defpackage :cliki (:use :common-lisp :irc :sb-bsd-sockets :cl-ppcre) +(defpackage :cliki (:use :common-lisp :irc :cl-ppcre) (:export :start-cliki-bot :*cliki-nickserv-password* :*respond-to-general-hellos*)) (in-package :cliki) @@ -50,31 +50,47 @@ (or port-start (length url))))) (subseq url 7 host-end))) +#+(or ccl allegro) +(defun socket-connect (host port) + (#+ccl ccl:make-socket + #+allegro socket:make-socket + :connect :active + :remote-host host + :remote-port port)) + +#+sbcl +(defun socket-connect (host port) + (let ((s (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (sb-bsd-sockets:socket-connect s (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name host))) port) + (sb-bsd-sockets:socket-make-stream s + :element-type 'character + :input t + :output t + :buffering :none))) + (defun url-connection (url) - (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp)) - (host (url-host url)) - (port (url-port url))) - (declare (ignore port)) - (socket-connect - s (car (host-ent-addresses (get-host-by-name (url-host url)))) - (url-port url)) - (let ((stream (socket-make-stream s :input t :output t :buffering :full))) - ;; we are exceedingly unportable about proper line-endings here. - ;; Anyone wishing to run this under non-SBCL should take especial care - (format stream "GET ~A HTTP/1.0~%Host: ~A~%User-Agent: CLiki Bot~%~%" url host) - (force-output stream) - (list - (let* ((l (read-line stream)) - (space (position #\Space l))) - (parse-integer l :start (1+ space) :junk-allowed t)) - (loop for line = (read-line stream nil nil) - until (or (null line) (eql (elt line 0) (code-char 13))) - collect - (let ((colon (position #\: line))) - (cons (intern (string-upcase (subseq line 0 colon)) :keyword) - (string-trim (list #\Space (code-char 13)) - (subseq line (1+ colon)))))) - stream)))) + (let* ((host (url-host url)) + (port (url-port url)) + (stream (socket-connect host port))) + ;; we are exceedingly unportable about proper line-endings here. + ;; Anyone wishing to run this under non-SBCL should take especial care + (format stream "GET ~A HTTP/1.0~%Host: ~A~%User-Agent: CLiki Bot~%~%" url host) + (force-output stream) + (list + (let* ((l (read-line stream)) + (space (position #\Space l))) + (parse-integer l :start (1+ space) :junk-allowed t)) + (loop for line = (read-line stream nil nil) + until (or (null line) (eql (elt line 0) (code-char 13))) + collect + (let ((colon (position #\: line))) + (cons (intern (string-upcase (subseq line 0 colon)) :keyword) + (string-trim (list #\Space (code-char 13)) + (subseq line (1+ colon)))))) + stream))) (defun encode-for-url (str) (setf str (regex-replace-all " " str "%20")) @@ -83,13 +99,33 @@ ;(format t "hi ~A~%" str) str) +#+sbcl +(defmacro host-with-timeout (timeout &body body) + `(sb-ext:with-timeout ,timeout ,@body)) + +#+ccl +(defmacro host-with-timeout (timeout &body body) + `(let ((interrupt-thread nil)) + (setf interrupt-thread + (ccl:process-run-function 'timeout + (let ((process ccl:*current-process*)) + (lambda () + (sleep ,timeout) + (ccl:process-interrupt process + (lambda () + (signal 'openmcl-timeout))))))) + (unwind-protect + (progn ,@body) + (if interrupt-thread + (ccl:process-kill interrupt-thread))))) + (defun cliki-first-sentence (term) (let* ((cliki-url (format nil "http://www.cliki.net/~A" (encode-for-url term))) (url (concatenate 'string cliki-url "?source"))) (block cliki-return (handler-case - (sb-ext:with-timeout 5 + (host-with-timeout 5 (destructuring-bind (response headers stream) (block got (loop @@ -138,7 +174,7 @@ (defparameter *cliki-bot-help* "The minion bot supplies small definitions and performs lookups on CLiki. To use it, try ``minion: term?''. To add a term for IRC, try saying ``minion: add \"term\" as: definition'' or ``minion: alias \"term\" as: term''; otherwise, edit the corresponding CLiki page.") -(defun cliki-lookup (term-with-question) +(defun cliki-lookup (term-with-question &optional sender) (let ((first-pass (regex-replace-all "^(\\s*)([^?]+)(\\?*)$" term-with-question "\\2"))) (setf first-pass (regex-replace-all "\\s\\s+" first-pass "")) (setf first-pass (regex-replace-all "\\s*$" first-pass "")) @@ -156,9 +192,15 @@ (setf first-pass (regex-replace-all "(:|/|\\\\|\\#)" first-pass "")) (or (if (string-equal first-pass "help") *cliki-bot-help*) - (if (scan "^(?i)hello(\\s|$)" first-pass) "what's up?") - (if (scan "^(?i)hi(\\s|$)" first-pass) "what's up?") - (if (scan "^(?i)yo(\\s|$)" first-pass) "what's up?") + (if (scan "^(?i)hello(\\s|$)*" first-pass) "what's up?") + (if (scan "^(?i)hi(\\s|$)*" first-pass) "what's up?") + (if (scan "^(?i)yo(\\s|$)*" first-pass) "what's up?") + (if (scan "^(?i)thank(s| you)(\\s|!|\\?|\\.|$)*" first-pass) + (if sender + (format nil "~A: you failed the inverse turing test!" sender) + "you failed the inverse turing test!")) + (if (scan "^(?i)version(\\s|!|\\?|\\.|$)*" first-pass) + (format nil "This is the minion bot, running on a ~A (~A) and running under ~A ~A." (machine-type) (machine-version) (lisp-implementation-type) (lisp-implementation-version))) (if (scan "^(?i)(?i)do my bidding!*$" first-pass) "Yes, my master.") (aif (or (let ((term (cdr (assoc first-pass *small-definitions* :test #'string-equal)))) (if term (if (stringp term) term (cliki-lookup (car term))))) @@ -183,7 +225,7 @@ (defun msg-hook (message) (let ((respond-to (if (string-equal (first (arguments message)) *cliki-nickname*) (source message) (first (arguments message))))) (if (valid-cliki-message message) - (privmsg *cliki-connection* respond-to (cliki-lookup (regex-replace *cliki-attention-prefix* (trailing-argument message) ""))) + (privmsg *cliki-connection* respond-to (cliki-lookup (regex-replace *cliki-attention-prefix* (trailing-argument message) "") (source message))) (if (string-equal (first (arguments message)) *cliki-nickname*) (privmsg *cliki-connection* respond-to (cliki-lookup (trailing-argument message))) (if (anybody-here (trailing-argument message)) @@ -203,8 +245,7 @@ (mapcar #'(lambda (channel) (join *cliki-connection* channel)) channels) (add-hook *cliki-connection* 'irc::irc-privmsg-message 'msg-hook) (add-hook *cliki-connection* 'irc::irc-notice-message 'notice-hook) - #+sbcl (start-background-message-handler *cliki-connection*) - #-sbcl (read-message-loop *cliki-connection*)) + (start-background-message-handler *cliki-connection*)) (defun shuffle-hooks () (irc::remove-hooks *cliki-connection* 'irc::irc-privmsg-message) Index: cl-irc/example/eliza-rules.lisp diff -u cl-irc/example/eliza-rules.lisp:1.2 cl-irc/example/eliza-rules.lisp:1.3 --- cl-irc/example/eliza-rules.lisp:1.2 Sun Feb 1 06:11:56 2004 +++ cl-irc/example/eliza-rules.lisp Tue Jun 1 06:48:12 2004 @@ -21,6 +21,9 @@ (((?* ?x) bot (?* ?y)) (|I'm| not a |bot.| I prefer the term |``electronically composed''.|)) + ((seen ?x) + (?x was last seen 5y6m14d32h43m10s |ago,| saying |"minion: when are you going to support seen?"|)) + (((?* ?x) did you (?* ?y)) (|no, I didn't| ?y) (|yes, I| ?y)) @@ -34,6 +37,9 @@ (Thanks!)) ((bot snack) + (Thanks!)) + + ((welcome (?* ?y)) (Thanks!)) ((not much) (good))

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

cl-irc-cvs June 2004