August 2004 - cl-irc-cvs@common-lisp.net - mailman3.common-lisp.net

[Cl-irc-cvs] CVS update: cl-irc/debian/changelog cl-irc/debian/control
by Kevin Rosenberg 13 Aug '04

13 Aug '04

Update of /project/cl-irc/cvsroot/cl-irc/debian In directory common-lisp.net:/tmp/cvs-serv28611 Modified Files: changelog control Log Message: Automated commit for debian_version_0_6_0 Date: Thu Aug 12 19:47:48 2004 Author: krosenberg Index: cl-irc/debian/changelog diff -u cl-irc/debian/changelog:1.5 cl-irc/debian/changelog:1.6 --- cl-irc/debian/changelog:1.5 Mon Mar 29 11:08:36 2004 +++ cl-irc/debian/changelog Thu Aug 12 19:47:48 2004 @@ -1,3 +1,9 @@ +cl-irc (0.6.0) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 12 Aug 2004 20:47:34 -0600 + cl-irc (0.5.2) unstable; urgency=low * New upstream Index: cl-irc/debian/control diff -u cl-irc/debian/control:1.2 cl-irc/debian/control:1.3 --- cl-irc/debian/control:1.2 Sat Jan 31 11:06:32 2004 +++ cl-irc/debian/control Thu Aug 12 19:47:48 2004 @@ -3,7 +3,7 @@ Priority: optional Maintainer: Kevin M. Rosenberg <kmr(a)debian.org> Build-Depends-Indep: debhelper (>> 4.0.0) -Standards-Version: 3.6.1.0 +Standards-Version: 3.6.1.1 Package: cl-irc Architecture: all

1 0

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

12 Aug '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: shortening! Date: Thu Aug 12 09:24:54 2004 Author: bmastenbrook Index: cl-irc/example/cliki.lisp diff -u cl-irc/example/cliki.lisp:1.25 cl-irc/example/cliki.lisp:1.26 --- cl-irc/example/cliki.lisp:1.25 Thu Aug 12 08:50:46 2004 +++ cl-irc/example/cliki.lisp Thu Aug 12 09:24:54 2004 @@ -1,4 +1,4 @@ - ;;;; $Id: cliki.lisp,v 1.25 2004/08/12 15:50:46 bmastenbrook Exp $ + ;;;; $Id: cliki.lisp,v 1.26 2004/08/12 16:24:54 bmastenbrook Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/cliki.lisp,v $ ;;;; cliki.lisp - CLiki as an infobot; only works on SBCL. @@ -233,8 +233,9 @@ (defun url-port (url) (assert (string-equal url "http://" :end1 7)) - (let ((port-start (position #\: url :start 7))) - (if port-start (parse-integer url :start (1+ port-start) :junk-allowed t) 80))) + (let ((path-start (position #\/ url :start 7))) + (let ((port-start (position #\: url :start 7 :end path-start))) + (if port-start (parse-integer url :start (1+ port-start) :junk-allowed t) 80)))) (defun url-host (url) (assert (string-equal url "http://" :end1 7)) @@ -249,6 +250,7 @@ (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 @@ -296,50 +298,75 @@ (if interrupt-thread (ccl:process-kill interrupt-thread))))) +(defun http-get (url) + (host-with-timeout + 5 + (destructuring-bind (response headers stream) + (block got + (loop + (destructuring-bind (response headers stream) (url-connection url) + (unless (member response '(301 302)) + (return-from got (list response headers stream))) + (close stream) + (setf stream nil) + (setf url (cdr (assoc :location headers)))))) + (if (not (eql response 200)) + nil + stream)))) + (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 - (host-with-timeout 5 - (destructuring-bind (response headers stream) - (block got - (loop - (destructuring-bind (response headers stream) (url-connection url) - (unless (member response '(301 302)) - (return-from got (list response headers stream))) - (close stream) - (setf url (cdr (assoc :location headers)))))) - (unwind-protect - (if (not (eql response 200)) - nil - ;;(format nil "The term ~A was not found in CLiki." term) - (let ((first-line "")) - (loop for i from 1 to 5 do ;; scan the first 5 lines - (progn - (multiple-value-bind (next-line missing-newline-p) - (read-line stream nil) - (if next-line - (setf first-line (concatenate 'string first-line (string #\newline) next-line)) - (return-from cliki-return (format nil "The end of the page was reached before a definition was found in ~A" cliki-url)))) - (setf first-line (regex-replace-all "\\r" first-line " ")) - (setf first-line (regex-replace-all "\\n" first-line " ")) - (setf first-line (regex-replace-all "_\$([^)]*)\$" first-line "\\1")) - (setf first-line (regex-replace-all "#H\$([^)]*)\$" first-line "\\1")) - (setf first-line (regex-replace-all "\\*\$([^)]*)\$" first-line "\\1")) - (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*(.+\\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))) - (if stream (close stream))))) + (let ((stream (http-get url))) + (unwind-protect + (if (not stream) + nil + ;;(format nil "The term ~A was not found in CLiki." term) + (let ((first-line "")) + (loop for i from 1 to 5 do ;; scan the first 5 lines + (progn + (multiple-value-bind (next-line missing-newline-p) + (read-line stream nil) + (if next-line + (setf first-line (concatenate 'string first-line (string #\newline) next-line)) + (return-from cliki-return (format nil "The end of the page was reached before a definition was found in ~A" cliki-url)))) + (setf first-line (regex-replace-all "\\r" first-line " ")) + (setf first-line (regex-replace-all "\\n" first-line " ")) + (setf first-line (regex-replace-all "_\$([^)]*)\$" first-line "\\1")) + (setf first-line (regex-replace-all "#H\$([^)]*)\$" first-line "\\1")) + (setf first-line (regex-replace-all "\\*\$([^)]*)\$" first-line "\\1")) + (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*(.+\\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))) + (if stream (close stream)))) (condition (c &rest whatever) (return-from cliki-return (regex-replace-all "\\n" (format nil "An error was encountered in lookup: ~A." c) " "))))) )) +(defun shorten (url) + (handler-case + (let ((stream (http-get (format nil "http://shorl.com/create.php?url=~A" url)))) + (finish-output t) + (unwind-protect + (when stream + (prog1 + (loop for line = (read-line stream nil nil) + while line + if (scan "http://shorl\\.com/[a-z]+" line) + return (regex-replace-all "^.*(http://shorl\\.com/[a-z]+).*$" line "\\1")) + (close stream) + (setf stream nil))) + (if stream (close stream)))) + (condition (c) + (return-from shorten (regex-replace-all "\\n" (format nil "An error was encountered in shorten: ~A." c) " "))))) + (defvar *cliki-connection*) (defvar *cliki-nickname*) @@ -645,6 +672,9 @@ (let ((str (nth-value 1 (scan-to-strings "^(?i)advice\\W+(\\d+)$" first-pass)))) (and str (lookup-advice (elt str 0)))) + (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 "")) (aif (or (small-definition-lookup first-pass) (cliki-first-sentence first-pass)

1 0

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

12 Aug '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: case-insensitive address Date: Thu Aug 12 08:50:46 2004 Author: bmastenbrook Index: cl-irc/example/cliki.lisp diff -u cl-irc/example/cliki.lisp:1.24 cl-irc/example/cliki.lisp:1.25 --- cl-irc/example/cliki.lisp:1.24 Tue Aug 10 06:29:30 2004 +++ cl-irc/example/cliki.lisp Thu Aug 12 08:50:46 2004 @@ -1,4 +1,4 @@ - ;;;; $Id: cliki.lisp,v 1.24 2004/08/10 13:29:30 bmastenbrook Exp $ + ;;;; $Id: cliki.lisp,v 1.25 2004/08/12 15:50:46 bmastenbrook Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/cliki.lisp,v $ ;;;; cliki.lisp - CLiki as an infobot; only works on SBCL. @@ -352,7 +352,7 @@ (defun make-cliki-attention-prefix (nick) - (format nil "^~A[,:]\\s+" nick)) + (format nil "^(?i)~A[,:]\\s+" nick)) (defvar *cliki-attention-prefix* "")

1 0

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

10 Aug '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: Detect MORE in all caps Date: Tue Aug 10 06:29:30 2004 Author: bmastenbrook Index: cl-irc/example/cliki.lisp diff -u cl-irc/example/cliki.lisp:1.23 cl-irc/example/cliki.lisp:1.24 --- cl-irc/example/cliki.lisp:1.23 Sat Aug 7 13:07:16 2004 +++ cl-irc/example/cliki.lisp Tue Aug 10 06:29:30 2004 @@ -1,4 +1,4 @@ -;;;; $Id: cliki.lisp,v 1.23 2004/08/07 20:07:16 bmastenbrook Exp $ + ;;;; $Id: cliki.lisp,v 1.24 2004/08/10 13:29:30 bmastenbrook Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/cliki.lisp,v $ ;;;; cliki.lisp - CLiki as an infobot; only works on SBCL. @@ -459,31 +459,35 @@ '("an" "a" "the")) (defun scan-for-more (s) - (let ((str (nth-value 1 (scan-to-strings "(?i)more\\W+(\\w+)\\W+(\\w+)\\W+(\\w+)" s)))) + (let ((str (nth-value 1 (scan-to-strings "MORE\\W+((\\W|[A-Z0-9])+)([A-Z0-9])($|[^A-Z0-9])" s)))) (or (and str - (or (member (elt str 0) *prepositions* :test #'string-equal) - (member (elt str 0) *conjunctions* :test #'string-equal) - (member (elt str 0) *articles* :test #'string-equal)) - (or (member (elt str 1) *prepositions* :test #'string-equal) - (member (elt str 1) *conjunctions* :test #'string-equal) - (member (elt str 1) *articles* :test #'string-equal)) - (setf *more* (string-upcase - (concatenate 'string (elt str 0) " " (elt str 1) - " " (elt str 2))))) - (let ((str (nth-value 1 (scan-to-strings "(?i)more\\W+(\\w+)\\W+(\\w+)" s)))) + (setf *more* (concatenate 'string (elt str 0) (elt str 2)))) + (let ((str (nth-value 1 (scan-to-strings "(?i)more\\W+(\\w+)\\W+(\\w+)\\W+(\\w+)" s)))) (or (and str (or (member (elt str 0) *prepositions* :test #'string-equal) (member (elt str 0) *conjunctions* :test #'string-equal) (member (elt str 0) *articles* :test #'string-equal)) + (or (member (elt str 1) *prepositions* :test #'string-equal) + (member (elt str 1) *conjunctions* :test #'string-equal) + (member (elt str 1) *articles* :test #'string-equal)) (setf *more* (string-upcase - (concatenate 'string (elt str 0) " " (elt str 1))))) - (let ((str (nth-value 1 (scan-to-strings "(?i)more\\W+(\\w+)" s)))) + (concatenate 'string (elt str 0) " " (elt str 1) + " " (elt str 2))))) + (let ((str (nth-value 1 (scan-to-strings "(?i)more\\W+(\\w+)\\W+(\\w+)" s)))) (or - (and str (setf *more* (string-upcase (elt str 0)))) - ))))))) - + (and str + (or (member (elt str 0) *prepositions* :test #'string-equal) + (member (elt str 0) *conjunctions* :test #'string-equal) + (member (elt str 0) *articles* :test #'string-equal)) + (setf *more* (string-upcase + (concatenate 'string (elt str 0) " " (elt str 1))))) + (let ((str (nth-value 1 (scan-to-strings "(?i)more\\W+(\\w+)" s)))) + (or + (and str (setf *more* (string-upcase (elt str 0)))) + ))))))))) + (defun cliki-lookup (term-with-question &key sender channel) (let ((first-pass (regex-replace-all "^(\\s*)([^?]+)(\\?*)$" term-with-question "\\2")) (should-send-cant-find t)) @@ -617,7 +621,7 @@ (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.") - (if (scan "^(?i)chant$" first-pass) + (if (scan "^(?i)chant(\\s|!|\\?|\\.|$)*" first-pass) (format nil "MORE ~A" *more*)) (if (scan "^(?i)advice$" first-pass) (random-advice))

1 0

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

07 Aug '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: MORE OF ENGLISH Date: Sat Aug 7 13:07:16 2004 Author: bmastenbrook Index: cl-irc/example/cliki.lisp diff -u cl-irc/example/cliki.lisp:1.22 cl-irc/example/cliki.lisp:1.23 --- cl-irc/example/cliki.lisp:1.22 Thu Aug 5 09:54:09 2004 +++ cl-irc/example/cliki.lisp Sat Aug 7 13:07:16 2004 @@ -1,4 +1,4 @@ -;;;; $Id: cliki.lisp,v 1.22 2004/08/05 16:54:09 bmastenbrook Exp $ +;;;; $Id: cliki.lisp,v 1.23 2004/08/07 20:07:16 bmastenbrook Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/cliki.lisp,v $ ;;;; cliki.lisp - CLiki as an infobot; only works on SBCL. @@ -449,9 +449,40 @@ (defvar *more* "CODE") +(defvar *prepositions* + '("aboard" "about" "above" "across" "after" "against" "along" "among" "around" "as" "at" "before" "behind" "below" "beneath" "beside" "between" "beyond" "but" "except" "by" "concerning" "despite" "down" "during" "except" "for" "from" "in" "into" "like" "near" "of" "off" "on" "onto" "out" "outside" "over" "past" "per" "regarding" "since" "through" "throughout" "till" "to" "toward" "under" "underneath" "until" "up" "upon" "with" "within" "without")) + +(defvar *conjunctions* + '("for" "and" "nor" "but" "or" "yet" "so")) + +(defvar *articles* + '("an" "a" "the")) + (defun scan-for-more (s) - (let ((str (nth-value 1 (scan-to-strings "(?i)more\\W+(\\w+)" s)))) - (and str (setf *more* (string-upcase (elt str 0)))))) + (let ((str (nth-value 1 (scan-to-strings "(?i)more\\W+(\\w+)\\W+(\\w+)\\W+(\\w+)" s)))) + (or + (and str + (or (member (elt str 0) *prepositions* :test #'string-equal) + (member (elt str 0) *conjunctions* :test #'string-equal) + (member (elt str 0) *articles* :test #'string-equal)) + (or (member (elt str 1) *prepositions* :test #'string-equal) + (member (elt str 1) *conjunctions* :test #'string-equal) + (member (elt str 1) *articles* :test #'string-equal)) + (setf *more* (string-upcase + (concatenate 'string (elt str 0) " " (elt str 1) + " " (elt str 2))))) + (let ((str (nth-value 1 (scan-to-strings "(?i)more\\W+(\\w+)\\W+(\\w+)" s)))) + (or + (and str + (or (member (elt str 0) *prepositions* :test #'string-equal) + (member (elt str 0) *conjunctions* :test #'string-equal) + (member (elt str 0) *articles* :test #'string-equal)) + (setf *more* (string-upcase + (concatenate 'string (elt str 0) " " (elt str 1))))) + (let ((str (nth-value 1 (scan-to-strings "(?i)more\\W+(\\w+)" s)))) + (or + (and str (setf *more* (string-upcase (elt str 0)))) + ))))))) (defun cliki-lookup (term-with-question &key sender channel) (let ((first-pass (regex-replace-all "^(\\s*)([^?]+)(\\?*)$" term-with-question "\\2"))

1 0

[Cl-irc-cvs] CVS update: cl-irc/protocol.lisp
by Brian Mastenbrook 06 Aug '04

06 Aug '04

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp.net:/home/bmastenbrook/cl-irc Modified Files: protocol.lisp Log Message: speedup from Maddas Date: Fri Aug 6 06:08:10 2004 Author: bmastenbrook Index: cl-irc/protocol.lisp diff -u cl-irc/protocol.lisp:1.10 cl-irc/protocol.lisp:1.11 --- cl-irc/protocol.lisp:1.10 Fri Aug 6 06:00:52 2004 +++ cl-irc/protocol.lisp Fri Aug 6 06:08:09 2004 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.10 2004/08/06 13:00:52 bmastenbrook Exp $ +;;;; $Id: protocol.lisp,v 1.11 2004/08/06 13:08:09 bmastenbrook Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/protocol.lisp,v $ ;;;; See LICENSE for licensing information. @@ -592,34 +592,32 @@ (defclass irc-error-reply (irc-message) ()) -(defun intern-message-symbol (prefix name) - "Intern based on symbol-name to support case-sensitive mlisp" - (intern - (concatenate 'string - (symbol-name prefix) - "-" - (symbol-name name) - "-" - (symbol-name '#:message)))) - -(defmacro define-irc-message (command) - (let ((name (intern-message-symbol :irc command))) - `(progn - (defmethod find-irc-message-class ((type (eql ,command))) - (find-class ',name)) - (export ',name) - (defclass ,name (irc-message) ())))) - -(defun create-irc-message-classes (class-list) - (dolist (class class-list) - (eval (list 'define-irc-message class)))) ; argh. eval. +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun intern-message-symbol (prefix name) + "Intern based on symbol-name to support case-sensitive mlisp" + (intern + (concatenate 'string + (symbol-name prefix) + "-" + (symbol-name name) + "-" + (symbol-name '#:message)))) + + (defun define-irc-message (command) + (let ((name (intern-message-symbol :irc command))) + `(progn + (defmethod find-irc-message-class ((type (eql ,command))) + (find-class ',name)) + (export ',name) + (defclass ,name (irc-message) ()))))) + +(defmacro create-irc-message-classes (class-list) + `(progn ,@(mapcar #'define-irc-message class-list))) ;; should perhaps wrap this in an eval-when? -(create-irc-message-classes (remove-duplicates - (mapcar #'second *reply-names*))) -(create-irc-message-classes '(:privmsg :notice :kick :topic :error - :mode :ping :nick :join :part :quit :kill - :pong :invite)) +(create-irc-message-classes #.(remove-duplicates (mapcar #'second *reply-names*))) +(create-irc-message-classes (:privmsg :notice :kick :topic :error :mode :ping + :nick :join :part :quit :kill :pong :invite)) (defmethod find-irc-message-class (type) (declare (ignore type)) @@ -654,20 +652,20 @@ (defgeneric find-ctcp-message-class (type)) -(defmacro define-ctcp-message (ctcp-command) - (let ((name (intern-message-symbol :ctcp ctcp-command))) - `(progn - (defmethod find-ctcp-message-class ((type (eql ,ctcp-command))) - (find-class ',name)) - (export ',name) - (defclass ,name (ctcp-mixin irc-message) ())))) - -(defun create-ctcp-message-classes (class-list) - (dolist (class class-list) - (eval (list 'define-ctcp-message class)))) ; argh. eval. must go away. +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun define-ctcp-message (ctcp-command) + (let ((name (intern-message-symbol :ctcp ctcp-command))) + `(progn + (defmethod find-ctcp-message-class ((type (eql ,ctcp-command))) + (find-class ',name)) + (export ',name) + (defclass ,name (ctcp-mixin irc-message) ()))))) + +(defmacro create-ctcp-message-classes (class-list) + `(progn ,@(mapcar #'define-ctcp-message class-list))) ;; should perhaps wrap this in an eval-when? -(create-ctcp-message-classes '(:action :source :finger :ping +(create-ctcp-message-classes (:action :source :finger :ping :version :userinfo :time :dcc-chat-request :dcc-send-request))

1 0

[Cl-irc-cvs] CVS update: cl-irc/protocol.lisp
by Brian Mastenbrook 06 Aug '04

06 Aug '04

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp.net:/home/bmastenbrook/cl-irc Modified Files: protocol.lisp Log Message: change re sbcl start-background-message-handler Date: Fri Aug 6 06:00:52 2004 Author: bmastenbrook Index: cl-irc/protocol.lisp diff -u cl-irc/protocol.lisp:1.9 cl-irc/protocol.lisp:1.10 --- cl-irc/protocol.lisp:1.9 Tue Jun 22 11:47:08 2004 +++ cl-irc/protocol.lisp Fri Aug 6 06:00:52 2004 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.9 2004/06/22 18:47:08 ehuelsmann Exp $ +;;;; $Id: protocol.lisp,v 1.10 2004/08/06 13:00:52 bmastenbrook Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/protocol.lisp,v $ ;;;; See LICENSE for licensing information. @@ -33,6 +33,10 @@ :initarg :server-stream :accessor server-stream :documentation "Stream used to talk to the IRC server.") + (server-socket + :initarg :server-socket + :accessor server-socket + :initform nil) (client-stream :initarg :client-stream :accessor client-stream @@ -76,12 +80,14 @@ (defun make-connection (&key (user nil) (server-name "") (server-stream nil) + (server-socket nil) (client-stream t) (hooks nil)) (let ((connection (make-instance 'connection :user user :server-name server-name :server-stream server-stream + :server-socket server-socket :client-stream client-stream))) (dolist (hook hooks) (add-hook connection (car hook) (cadr hook))) @@ -118,6 +124,12 @@ (and (streamp stream) (open-stream-p stream)))) +(define-condition invalidate-me (condition) + ((socket :initarg :socket + :reader invalidate-me-socket) + (condition :initarg :condition + :reader invalidate-me-condition))) + (defmethod read-message ((connection connection)) (let ((read-more-p t)) (handler-case @@ -128,7 +140,10 @@ (format *debug-stream* "~A" (describe message))) (irc-message-event message) message))) ; needed because of the "loop while" in read-message-loop - (stream-error () (setf read-more-p nil))))) + (stream-error (c) (setf read-more-p nil) + (signal 'invalidate-me :socket + (server-socket connection) + :condition c))))) (defvar *process-count* 0) @@ -152,7 +167,13 @@ (server-stream connection)) :input (lambda (fd) (declare (ignore fd)) - (read-message connection)))))) + (handler-case + (read-message connection) + (invalidate-me (c) + (sb-sys:invalidate-descriptor + (invalidate-me-socket c)) + (format t "Socket closed: ~A~%" + (invalidate-me-condition c))))))))) (defun stop-background-message-handler (process) "Stops a background message handler process returned by the start function."

1 0

[Cl-irc-cvs] CVS update: cl-irc/example/advice cl-irc/example/cliki.lisp cl-irc/example/specbot.lisp
by Brian Mastenbrook 05 Aug '04

05 Aug '04

Update of /project/cl-irc/cvsroot/cl-irc/example In directory common-lisp.net:/home/bmastenbrook/cl-irc/example Modified Files: advice cliki.lisp specbot.lisp Log Message: um, not sure Date: Thu Aug 5 09:54:09 2004 Author: bmastenbrook Index: cl-irc/example/advice diff -u cl-irc/example/advice:1.1 cl-irc/example/advice:1.2 --- cl-irc/example/advice:1.1 Tue Jul 27 13:39:42 2004 +++ cl-irc/example/advice Thu Aug 5 09:54:09 2004 @@ -95,4 +95,5 @@ (11963 . "It's easy to get the *wrong* answer in O(1) time.") (11964 . "I guess this just goes to show that you can lead a horse to water, but you can't make him drink it.") - (11999 . "You are a stupid asshole. Shut the fuck up.")) \ No newline at end of file + (11999 . "You are a stupid asshole. Shut the fuck up.") + (12000 . "Looking for a compiler bug is the second-to-last resort. The last resort is blaming bad RAM. It's never the correct hypothesis.")) Index: cl-irc/example/cliki.lisp diff -u cl-irc/example/cliki.lisp:1.21 cl-irc/example/cliki.lisp:1.22 --- cl-irc/example/cliki.lisp:1.21 Wed Jul 28 08:45:42 2004 +++ cl-irc/example/cliki.lisp Thu Aug 5 09:54:09 2004 @@ -1,4 +1,4 @@ -;;;; $Id: cliki.lisp,v 1.21 2004/07/28 15:45:42 bmastenbrook Exp $ +;;;; $Id: cliki.lisp,v 1.22 2004/08/05 16:54:09 bmastenbrook Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/cliki.lisp,v $ ;;;; cliki.lisp - CLiki as an infobot; only works on SBCL. @@ -487,42 +487,7 @@ channel)) (return-from cliki-lookup nil)) (or - (let ((strings - (or - (aif - (nth-value 1 (scan-to-strings "^(?i)(direct|tell|show|inform|teach|give)\\s+(\\S+)\\s+(about|on|in|to|through|for|some|)\\s*(.+)$" first-pass)) - (cons :forward it)) - (aif - (nth-value 1 (scan-to-strings "^(?i)(look\\s+up\\s+|)\\s*(.+)\\s+(for|to|at)\\s+(\\S+)$" first-pass)) - (cons :backward it)) - ))) - (if strings - (let* ((term (case (car strings) - (:forward (elt (cdr strings) 3)) - (:backward (elt (cdr strings) 1)))) - (person (case (car strings) - (:forward (elt (cdr strings) 1)) - (:backward (elt (cdr strings) 3)))) - (person (if (string-equal person "me") - (or sender channel "you") - person)) - (about (cliki-lookup term :sender sender - :channel channel))) - (if about - (format nil "~A: ~A~A" - person - (if (scan "http:" about) - (concatenate 'string - (random-element - '("have a look at" - "please look at" - "please see" - "direct your attention towards" - "look at")) - " ") - "") - about) - (setf should-send-cant-find nil))))) + (if (string-equal first-pass "help") (if (should-do-lookup first-pass (or channel sender "")) (progn @@ -575,7 +540,42 @@ (let ((strs (nth-value 1 (scan-to-strings "^(?i)paste\\s+(\\d+)$" first-pass)))) (and strs (lookup-paste (parse-integer (elt strs 0))))) - + (let ((strings + (or + (aif + (nth-value 1 (scan-to-strings "^(?i)(direct|tell|show|inform|teach|give)\\s+(\\S+)\\s+(about|on|in|to|through|for|some|)\\s*(.+)$" first-pass)) + (cons :forward it)) + (aif + (nth-value 1 (scan-to-strings "^(?i)(look\\s+up\\s+|)\\s*(.+)\\s+(for|to|at)\\s+(\\S+)$" first-pass)) + (cons :backward it)) + ))) + (if strings + (let* ((term (case (car strings) + (:forward (elt (cdr strings) 3)) + (:backward (elt (cdr strings) 1)))) + (person (case (car strings) + (:forward (elt (cdr strings) 1)) + (:backward (elt (cdr strings) 3)))) + (person (if (string-equal person "me") + (or sender channel "you") + person)) + (about (cliki-lookup term :sender sender + :channel channel))) + (if about + (format nil "~A: ~A~A" + person + (if (scan "http:" about) + (concatenate 'string + (random-element + '("have a look at" + "please look at" + "please see" + "direct your attention towards" + "look at")) + " ") + "") + about) + (setf should-send-cant-find nil))))) (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?") Index: cl-irc/example/specbot.lisp diff -u cl-irc/example/specbot.lisp:1.6 cl-irc/example/specbot.lisp:1.7 --- cl-irc/example/specbot.lisp:1.6 Tue Jul 27 11:47:00 2004 +++ cl-irc/example/specbot.lisp Thu Aug 5 09:54:09 2004 @@ -1,4 +1,4 @@ -;;;; $Id: specbot.lisp,v 1.6 2004/07/27 18:47:00 bmastenbrook Exp $ +;;;; $Id: specbot.lisp,v 1.7 2004/08/05 16:54:09 bmastenbrook Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/specbot.lisp,v $ ;;;; specbot.lisp - an example IRC bot for cl-irc @@ -129,8 +129,17 @@ (or *load-truename* *default-pathname-defaults*))))) +(defparameter *ppc-file* + (merge-pathnames "ppc-assem.lisp-expr" + (make-pathname + :directory + (pathname-directory + (or *load-truename* + *default-pathname-defaults*))))) + (defun start-specbot (nick server &rest channels) (add-simple-alist-lookup *754-file* 'ieee754 "ieee754" "Section numbers of IEEE 754") + (add-simple-alist-lookup *ppc-file* 'ppc "ppc" "PowerPC assembly mnemonics") (setf *nickname* nick) (setf *connection* (connect :nickname *nickname* :server server)) (mapcar #'(lambda (channel) (join *connection* channel)) channels)

1 0