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

[Cl-irc-cvs] CVS update: cl-irc/example/advice
by lisppaste＠common-lisp.net 19 Aug '05

19 Aug '05

Update of /project/cl-irc/cvsroot/cl-irc/example In directory common-lisp.net:/home/lisppaste/cl-irc/example Modified Files: advice Log Message: Added a new advice. Date: Fri Aug 19 14:15:01 2005 Author: lisppaste Index: cl-irc/example/advice diff -u cl-irc/example/advice:1.2 cl-irc/example/advice:1.3 --- cl-irc/example/advice:1.2 Thu Aug 5 18:54:09 2004 +++ cl-irc/example/advice Fri Aug 19 14:15:01 2005 @@ -96,4 +96,5 @@ (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.") - (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.")) + (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.") + (12017 . "It doesn't need to be portable, it just needs to work on your system."))

1 0

[Cl-irc-cvs] CVS update: cl-irc/example/cliki.lisp cl-irc/example/specbot.lisp
by lisppaste＠common-lisp.net 09 Aug '05

09 Aug '05

Update of /project/cl-irc/cvsroot/cl-irc/example In directory common-lisp.net:/home/lisppaste/cl-irc/example Modified Files: cliki.lisp specbot.lisp Log Message: Latest bugfixes Date: Tue Aug 9 03:26:15 2005 Author: lisppaste Index: cl-irc/example/cliki.lisp diff -u cl-irc/example/cliki.lisp:1.30 cl-irc/example/cliki.lisp:1.31 --- cl-irc/example/cliki.lisp:1.30 Thu Jul 28 20:31:08 2005 +++ cl-irc/example/cliki.lisp Tue Aug 9 03:26:14 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cliki.lisp,v 1.30 2005/07/28 18:31:08 lisppaste Exp $ +;;;; $Id: cliki.lisp,v 1.31 2005/08/09 01:26:14 lisppaste Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/cliki.lisp,v $ ;;;; cliki.lisp - CLiki as an infobot; only works on SBCL. @@ -227,7 +227,9 @@ (push e max-score-items))))) (advice-db)) (if (zerop max-score) - "You can't expect automated advice for everything." + (progn + (signal 'lookup-failure) + "You can't expect automated advice for everything.") (let ((item (random-element max-score-items))) (format nil "#~A: ~A" (car item) (cdr item)))))) @@ -284,6 +286,8 @@ (http-get-recursively (cdr (assoc :location headers)))) (list status headers stream)))) +(define-condition lookup-failure (condition) ()) + (defun cliki-first-sentence (term) (let* ((cliki-url (format nil "http://www.cliki.net/~A" (encode-for-url term))) @@ -320,9 +324,15 @@ (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))) + (progn + (signal 'lookup-failure) + (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) " "))))) + #+sbcl + (sb-ext:timeout (c) + (return-from cliki-return (progn (signal 'lookup-failure) + "I can't be expected to work when CLiki doesn't respond to me, can I?"))) + (serious-condition (c &rest whatever) (return-from cliki-return (progn (signal 'lookup-failure) (regex-replace-all "\\n" (format nil "An error was encountered in lookup: ~A." c) " ")))))) )) (defun shorten (url) @@ -494,7 +504,7 @@ ))))))))) (defun cliki-lookup (term-with-question &key sender channel) - (let ((first-pass (regex-replace-all "^(\\s*)([^?]+)([?.!,;]*)$" term-with-question "\\2")) + (let ((first-pass (regex-replace-all "^(\\s*)(.*[^?.!,;])([?.!,;]*)$" term-with-question "\\2")) (should-send-cant-find t)) (setf first-pass (regex-replace-all "\\s\\s+" first-pass " ")) (setf first-pass (regex-replace-all "\\s*$" first-pass "")) @@ -586,7 +596,7 @@ (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)) + (nth-value 1 (scan-to-strings "^(?i)(look\\s+up\\s+|say|)\\s*(.+)\\s+(for|to|at)\\s+(\\S+)$" first-pass)) (cons :backward it)) ))) (if strings @@ -599,30 +609,39 @@ (person (if (string-equal person "me") (or sender channel "you") person)) - (about (cliki-lookup term :sender sender - :channel channel))) + (do-concatenate t) + (about + (handler-bind + ((lookup-failure + #'(lambda (c) + (setf do-concatenate nil)))) + (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) + (if do-concatenate + (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) + 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?") (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!")) + (random-element + '("you're welcome" + "no problem" + "np"))) (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.") @@ -675,6 +694,7 @@ (do-eliza first-pass)) ) (when should-send-cant-find + (signal 'lookup-failure) (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?" ""))) )))))))) Index: cl-irc/example/specbot.lisp diff -u cl-irc/example/specbot.lisp:1.13 cl-irc/example/specbot.lisp:1.14 --- cl-irc/example/specbot.lisp:1.13 Tue May 10 02:36:26 2005 +++ cl-irc/example/specbot.lisp Tue Aug 9 03:26:14 2005 @@ -1,4 +1,4 @@ -;;;; $Id: specbot.lisp,v 1.13 2005/05/10 00:36:26 lisppaste Exp $ +;;;; $Id: specbot.lisp,v 1.14 2005/08/09 01:26:14 lisppaste Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/specbot.lisp,v $ ;;;; specbot.lisp - an example IRC bot for cl-irc @@ -68,6 +68,9 @@ (elisp-lookup "elisp" "GNU Emacs Lisp Reference Manual") (clim-lookup "clim" "Common Lisp Interface Manager II Specification"))) +(defvar *spaces-allowed* + '(clim-lookup)) + (defvar *alists* nil) (defun add-simple-alist-lookup (file designator prefix description) @@ -130,7 +133,8 @@ do (aif (strip-address to-lookup :address (second type) :final t) (let ((looked-up (funcall actual-fun it))) - (if (and (<= 0 (count #\space it) 1) + (if (and (<= 0 (count #\space it) + (if (member actual-fun *spaces-allowed*) 1 0)1) (not looked-up)) (setf looked-up (format nil "Sorry, I couldn't find anything for ~A." it))) (and looked-up

1 0

[Cl-irc-cvs] CVS update: cl-irc/example/cliki.lisp
by lisppaste＠common-lisp.net 28 Jul '05

28 Jul '05

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: No idea... Date: Thu Jul 28 20:31:09 2005 Author: lisppaste Index: cl-irc/example/cliki.lisp diff -u cl-irc/example/cliki.lisp:1.29 cl-irc/example/cliki.lisp:1.30 --- cl-irc/example/cliki.lisp:1.29 Tue May 10 02:36:26 2005 +++ cl-irc/example/cliki.lisp Thu Jul 28 20:31:08 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cliki.lisp,v 1.29 2005/05/10 00:36:26 lisppaste Exp $ +;;;; $Id: cliki.lisp,v 1.30 2005/07/28 18:31:08 lisppaste Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/cliki.lisp,v $ ;;;; cliki.lisp - CLiki as an infobot; only works on SBCL. @@ -182,16 +182,19 @@ (defvar *advice-db* nil) +(defun advice-db () + (when (not *advice-db*) + (with-open-file (ad *advice-file* :direction :input) + (setf *advice-db* (read ad)))) + *advice-db*) + (defun lookup-advice (num-str) (let ((num (parse-integer num-str :junk-allowed t))) - (when (not *advice-db*) - (with-open-file (ad *advice-file* :direction :input) - (setf *advice-db* (read ad)))) - (or (cdr (assoc num *advice-db*)) + (or (cdr (assoc num (advice-db))) "You can't just make up advice numbers and expect a response."))) (defun random-advice () - (let ((item (random-element *advice-db*))) + (let ((item (random-element (advice-db)))) (format nil "#~A: ~A" (car item) (cdr item)))) (defun search-advice (str) @@ -222,7 +225,7 @@ (if (and (not (zerop score)) (eql score max-score)) (push e max-score-items))))) - *advice-db*) + (advice-db)) (if (zerop max-score) "You can't expect automated advice for everything." (let ((item (random-element max-score-items))) @@ -271,47 +274,60 @@ (if interrupt-thread (ccl:process-kill interrupt-thread))))) +(defun http-get-recursively (url) + (destructuring-bind (status headers stream) + (trivial-http:http-get url) + (if (and (eql status 302) + (assoc :location headers)) + (progn + (close stream) + (http-get-recursively (cdr (assoc :location headers)))) + (list status headers stream)))) + (defun cliki-first-sentence (term) - (host-with-timeout - 5 - (let* ((cliki-url (format nil "http://www.cliki.net/~A" + (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 - (let ((stream (third (trivial-http: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)))) + (host-with-timeout + 5 + (destructuring-bind (status headers stream) + (http-get-recursively url) + (declare (ignore headers)) + ;; Please don't hack on this when tired; it's easy to make it leak fds. + (unwind-protect + (if (or (not (eql status 200)) (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)))) + (let ((stream (trivial-http:http-get (format nil "http://shorl.com/create.php?url=~A" url)))) (finish-output t) (unwind-protect (when stream @@ -478,7 +494,7 @@ ))))))))) (defun cliki-lookup (term-with-question &key sender channel) - (let ((first-pass (regex-replace-all "^(\\s*)([^?]+)(\\?*)$" term-with-question "\\2")) + (let ((first-pass (regex-replace-all "^(\\s*)([^?]+)([?.!,;]*)$" term-with-question "\\2")) (should-send-cant-find t)) (setf first-pass (regex-replace-all "\\s\\s+" first-pass " ")) (setf first-pass (regex-replace-all "\\s*$" first-pass "")) @@ -675,22 +691,25 @@ (scan "^(?i)\\s*(hello|hi|yo)\\s*(channel|room|people|ppl|all|peeps|)\\s*$" string)))) (defun msg-hook (message) - (handler-case - (progn - (scan-for-more (trailing-argument message)) - (let ((respond-to (if (string-equal (first (arguments message)) *cliki-nickname*) (source message) (first (arguments 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*) - (aif (cliki-lookup (trailing-argument message) :sender (source message)) - (privmsg *cliki-connection* respond-to it)) - (if (anybody-here (trailing-argument message)) - (privmsg *cliki-connection* (first (arguments message)) (format nil "~A: hello." (source message)))))) - (take-care-of-memos respond-to (source message)))) - (serious-condition (c) - (format *trace-output* "Caught error: ~A~%" c) - #+sbcl (sb-debug:backtrace 5 *trace-output*)))) + (handler-bind + ((serious-condition (lambda (c) + (format *trace-output* "Caught error: ~A~%" c) + #+nil (sb-debug:backtrace 10 *trace-output*) + (format *trace-output* "~A~%" + (nthcdr 10 (sb-debug:backtrace-as-list))) + (return-from msg-hook)))) + (progn + (scan-for-more (trailing-argument message)) + (let ((respond-to (if (string-equal (first (arguments message)) *cliki-nickname*) (source message) (first (arguments 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*) + (aif (cliki-lookup (trailing-argument message) :sender (source message)) + (privmsg *cliki-connection* respond-to it)) + (if (anybody-here (trailing-argument message)) + (privmsg *cliki-connection* (first (arguments message)) (format nil "~A: hello." (source message)))))) + (take-care-of-memos respond-to (source message)))))) (defvar *cliki-nickserv-password* "")

1 0

[Cl-irc-cvs] CVS update: cl-irc/debian/changelog cl-irc/debian/control
by pvaneynde＠common-lisp.net 02 Jul '05

02 Jul '05

Update of /project/cl-irc/cvsroot/cl-irc/debian In directory common-lisp.net:/tmp/cvs-serv15122/debian Modified Files: changelog control Log Message: note new version, use darcs-buildpackage Date: Sat Jul 2 22:58:13 2005 Author: pvaneynde Index: cl-irc/debian/changelog diff -u cl-irc/debian/changelog:1.7 cl-irc/debian/changelog:1.8 --- cl-irc/debian/changelog:1.7 Thu Mar 3 10:23:00 2005 +++ cl-irc/debian/changelog Sat Jul 2 22:58:13 2005 @@ -1,3 +1,12 @@ +cl-irc (20050321-1) unstable; urgency=low + + * New upstream + * New versioning scheme, now no longer a native package + * Updated policy version + * Now uses darcs-buildpackage + + -- Peter Van Eynde <pvaneynd(a)debian.org> Sat, 2 Jul 2005 22:52:51 +0200 + cl-irc (0.6.2) unstable; urgency=low * Updated package to current CVS (2005-03-03) Index: cl-irc/debian/control diff -u cl-irc/debian/control:1.4 cl-irc/debian/control:1.5 --- cl-irc/debian/control:1.4 Thu Mar 3 10:23:00 2005 +++ cl-irc/debian/control Sat Jul 2 22:58:13 2005 @@ -3,11 +3,11 @@ Priority: optional Maintainer: Peter Van Eynde <pvaneynd(a)debian.org> Build-Depends-Indep: debhelper (>> 4.0.0) -Standards-Version: 3.6.1.1 +Standards-Version: 3.6.2.1 Package: cl-irc Architecture: all -Depends: ${shlibs:Depends}, common-lisp-controller (>= 3.37), cl-split-sequence +Depends: common-lisp-controller (>= 3.37), cl-split-sequence Description: Common Lisp Internet Relay Chat Library cl-irc provides a library for Common Lisp programs to interact with IRC servers. This library has been most tested with SBCL.

1 0

[Cl-irc-cvs] CVS update: cl-irc/example/cliki-bot.asd cl-irc/example/cliki.lisp cl-irc/example/specbot.lisp
by lisppaste＠common-lisp.net 10 May '05

10 May '05

Update of /project/cl-irc/cvsroot/cl-irc/example In directory common-lisp.net:/home/lisppaste/cl-irc/example Modified Files: cliki-bot.asd cliki.lisp specbot.lisp Log Message: Whee! leak fewer fds by using trivial-http Date: Tue May 10 02:36:26 2005 Author: lisppaste Index: cl-irc/example/cliki-bot.asd diff -u cl-irc/example/cliki-bot.asd:1.3 cl-irc/example/cliki-bot.asd:1.4 --- cl-irc/example/cliki-bot.asd:1.3 Tue Jul 27 22:39:42 2004 +++ cl-irc/example/cliki-bot.asd Tue May 10 02:36:26 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cliki-bot.asd,v 1.3 2004/07/27 20:39:42 bmastenbrook Exp $ +;;;; $Id: cliki-bot.asd,v 1.4 2005/05/10 00:36:26 lisppaste Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/cliki-bot.asd,v $ ;;;; See the LICENSE file for licensing information. @@ -17,9 +17,9 @@ :licence "MIT" :description "IRC bot for SBCL" :depends-on - (:cl-irc :cl-ppcre :split-sequence) + (:cl-irc :cl-ppcre :split-sequence :trivial-http) :properties ((#:author-email . "cl-irc-devel(a)common-lisp.net") - (#:date . "$Date: 2004/07/27 20:39:42 $") + (#:date . "$Date: 2005/05/10 00:36:26 $") ((#:albert #:output-dir) . "doc/api-doc/") ((#:albert #:formats) . ("docbook")) ((#:albert #:docbook #:template) . "book") Index: cl-irc/example/cliki.lisp diff -u cl-irc/example/cliki.lisp:1.28 cl-irc/example/cliki.lisp:1.29 --- cl-irc/example/cliki.lisp:1.28 Tue Nov 23 03:54:08 2004 +++ cl-irc/example/cliki.lisp Tue May 10 02:36:26 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cliki.lisp,v 1.28 2004/11/23 02:54:08 bmastenbrook Exp $ +;;;; $Id: cliki.lisp,v 1.29 2005/05/10 00:36:26 lisppaste Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/cliki.lisp,v $ ;;;; cliki.lisp - CLiki as an infobot; only works on SBCL. @@ -239,41 +239,6 @@ (funcall (intern "PASTE-CHANNEL" :lisppaste) paste) (funcall (intern "PASTE-DISPLAY-URL" :lisppaste) paste)))))) -(defun url-port (url) - (assert (string-equal url "http://" :end1 7)) - (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)) - (let* ((port-start (position #\: url :start 7)) - (host-end (min (or (position #\/ url :start 7) (length url)) - (or port-start (length url))))) - (subseq url 7 host-end))) - -(defun url-connection (url) - (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")) (setf str (regex-replace-all "," str "%2C")) @@ -306,35 +271,21 @@ (if interrupt-thread (ccl:process-kill interrupt-thread))))) -(defun http-get (url) +(defun cliki-first-sentence (term) (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 - (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 + (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 + (let ((stream (third (trivial-http: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) @@ -353,10 +304,10 @@ (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) " "))))) - )) + (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 @@ -529,7 +480,7 @@ (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)) - (setf first-pass (regex-replace-all "\\s\\s+" first-pass "")) + (setf first-pass (regex-replace-all "\\s\\s+" first-pass " ")) (setf first-pass (regex-replace-all "\\s*$" first-pass "")) (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))))) Index: cl-irc/example/specbot.lisp diff -u cl-irc/example/specbot.lisp:1.12 cl-irc/example/specbot.lisp:1.13 --- cl-irc/example/specbot.lisp:1.12 Tue Nov 23 03:54:08 2004 +++ cl-irc/example/specbot.lisp Tue May 10 02:36:26 2005 @@ -1,4 +1,4 @@ -;;;; $Id: specbot.lisp,v 1.12 2004/11/23 02:54:08 bmastenbrook Exp $ +;;;; $Id: specbot.lisp,v 1.13 2005/05/10 00:36:26 lisppaste Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/specbot.lisp,v $ ;;;; specbot.lisp - an example IRC bot for cl-irc @@ -160,10 +160,19 @@ (or *load-truename* *default-pathname-defaults*))))) +(defparameter *man-file* + (merge-pathnames "man.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") (add-simple-alist-lookup *sus-file* 'sus "posix" "Single UNIX Specification") + (add-simple-alist-lookup *man-file* 'man "man" "Mac OS X Man Pages") (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/protocol.lisp
by ehuelsmann＠common-lisp.net 17 Apr '05

17 Apr '05

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp.net:/tmp/cvs-serv9455 Modified Files: protocol.lisp Log Message: Remove *all* references to 'socket'. Close the stream the same way 'quit' does. Date: Sun Apr 17 23:14:30 2005 Author: ehuelsmann Index: cl-irc/protocol.lisp diff -u cl-irc/protocol.lisp:1.23 cl-irc/protocol.lisp:1.24 --- cl-irc/protocol.lisp:1.23 Sun Apr 17 21:45:41 2005 +++ cl-irc/protocol.lisp Sun Apr 17 23:14:30 2005 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.23 2005/04/17 19:45:41 ehuelsmann Exp $ +;;;; $Id: protocol.lisp,v 1.24 2005/04/17 21:14:30 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/protocol.lisp,v $ ;;;; See LICENSE for licensing information. @@ -432,10 +432,11 @@ ;; argh. I want to name this quit but that gives me issues with ;; generic functions. need to resolve. (defmethod dcc-close ((connection dcc-connection)) + #+(and sbcl (not sb-thread)) + (sb-sys:invalidate-descriptor (sb-sys:fd-stream-fd (stream connection))) (close (dcc-stream connection)) (setf (user connection) nil) (setf *dcc-connections* (remove connection *dcc-connections*)) - #+sbcl (sb-bsd-sockets:socket-close (socket connection)) ) (defmethod connectedp ((connection dcc-connection))

1 0

[Cl-irc-cvs] CVS update: cl-irc/protocol.lisp cl-irc/command.lisp cl-irc/utility.lisp
by ehuelsmann＠common-lisp.net 17 Apr '05

17 Apr '05

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp.net:/tmp/cvs-serv5039 Modified Files: protocol.lisp command.lisp utility.lisp Log Message: Share connecting code between normal and dcc connections. Also remove 'socket' slot from 'dcc-connection' as it has been removed from 'connection'. Date: Sun Apr 17 21:45:43 2005 Author: ehuelsmann Index: cl-irc/protocol.lisp diff -u cl-irc/protocol.lisp:1.22 cl-irc/protocol.lisp:1.23 --- cl-irc/protocol.lisp:1.22 Sun Mar 27 23:40:30 2005 +++ cl-irc/protocol.lisp Sun Apr 17 21:45:41 2005 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.22 2005/03/27 21:40:30 ehuelsmann Exp $ +;;;; $Id: protocol.lisp,v 1.23 2005/04/17 19:45:41 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/protocol.lisp,v $ ;;;; See LICENSE for licensing information. @@ -394,12 +394,7 @@ (output-stream :initarg :output-stream :accessor output-stream - :initform t) - (socket - :initarg :socket - :accessor socket - :documentation "The actual socket object for the connection -between the two users."))) + :initform t))) (defmethod print-object ((object dcc-connection) stream) "Print the object for the Lisp reader." @@ -414,23 +409,10 @@ (remote-address nil) (remote-port nil) (output-stream t)) - #+sbcl - (let ((socket (sb-bsd-sockets:make-inet-socket :stream :tcp))) - (sb-bsd-sockets:socket-connect socket remote-address remote-port) - (make-instance 'dcc-connection - :user user - :stream (sb-bsd-sockets:socket-make-stream socket :input t :output t :buffering :none) - :socket socket - :output-stream output-stream)) - #+openmcl - (let ((socket-stream (ccl:make-socket :remote-host remote-address - :remote-port remote-port))) - (make-instance 'dcc-connection - :user user - :stream socket-stream - :output-stream output-stream)) - #-(or openmcl sbcl) - (warn "make-dcc-connection not supported for this implementation.")) + (make-instance 'dcc-connection + :user user + :stream (socket-stream remote-address remote-port) + :output-stream output-stream)) (defgeneric dcc-close (connection)) (defgeneric send-dcc-message (connection message)) Index: cl-irc/command.lisp diff -u cl-irc/command.lisp:1.9 cl-irc/command.lisp:1.10 --- cl-irc/command.lisp:1.9 Sat Mar 19 17:53:38 2005 +++ cl-irc/command.lisp Sun Apr 17 21:45:42 2005 @@ -1,4 +1,4 @@ -;;;; $Id: command.lisp,v 1.9 2005/03/19 16:53:38 ehuelsmann Exp $ +;;;; $Id: command.lisp,v 1.10 2005/04/17 19:45:42 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/command.lisp,v $ ;;;; See LICENSE for licensing information. @@ -230,7 +230,7 @@ (defmethod stats ((connection connection) &optional (query "") (target "")) (send-irc-message connection :stats nil query target)) - + (defmethod links ((connection connection) &optional (remote-server "") (server-mask "")) (send-irc-message connection :links nil remote-server server-mask)) @@ -238,38 +238,6 @@ (defmethod time- ((connection connection) &optional (target "")) (send-irc-message connection :time nil target)) -(defun connect-to-server-socket (host port) - #+sbcl - (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) - s) - ) - -(defun socket-stream (socket) - #+sbcl - (sb-bsd-sockets:socket-make-stream socket - :element-type 'character - :input t - :output t - :buffering :none) - #+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) Index: cl-irc/utility.lisp diff -u cl-irc/utility.lisp:1.6 cl-irc/utility.lisp:1.7 --- cl-irc/utility.lisp:1.6 Mon Mar 21 19:14:32 2005 +++ cl-irc/utility.lisp Sun Apr 17 21:45:42 2005 @@ -1,4 +1,4 @@ -;;;; $Id: utility.lisp,v 1.6 2005/03/21 18:14:32 ehuelsmann Exp $ +;;;; $Id: utility.lisp,v 1.7 2005/04/17 19:45:42 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/utility.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -105,6 +105,41 @@ (third (ldb (byte 8 8) integer)) (fourth (ldb (byte 8 0) integer))) (vector first second third fourth))) + +(defun connect-to-server-socket (host port) + #+sbcl + (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) + s) + ) + +(defun socket-stream (socket) + #+sbcl + (sb-bsd-sockets:socket-make-stream socket + :element-type 'character + :input t + :output t + :buffering :none) + ) + +(defun socket-connect (server port) + "Create a socket connected to `server':`port' and return stream for it." + #+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)) + #-(or lispworks cmu allegro sbcl openmcl armedbear) + (warn "socket-connect not supported for this implementation.") + ) + (defun cut-between (string start-char end-chars &key (start 0) (cut-extra t)) "If `start-char' is not nil, cut string between `start-char' and any

1 0

[Cl-irc-cvs] CVS update: cl-irc/package.lisp
by ehuelsmann＠common-lisp.net 15 Apr '05

15 Apr '05

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp.net:/tmp/cvs-serv27599 Modified Files: package.lisp Log Message: Export forgotten symbol for mode-tracking class. Date: Fri Apr 15 18:01:23 2005 Author: ehuelsmann Index: cl-irc/package.lisp diff -u cl-irc/package.lisp:1.7 cl-irc/package.lisp:1.8 --- cl-irc/package.lisp:1.7 Mon Mar 21 23:32:35 2005 +++ cl-irc/package.lisp Fri Apr 15 18:01:22 2005 @@ -1,4 +1,4 @@ -;;;; $Id: package.lisp,v 1.7 2005/03/21 22:32:35 ehuelsmann Exp $ +;;;; $Id: package.lisp,v 1.8 2005/04/15 16:01:22 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/package.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -18,6 +18,7 @@ :server-name :no-such-reply :irc-mode + :boolean-value-mode :single-value-mode :list-value-mode :add-mode

1 0

[Cl-irc-cvs] CVS update: cl-irc/protocol.lisp cl-irc/event.lisp
by ehuelsmann＠common-lisp.net 27 Mar '05

27 Mar '05

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp.net:/tmp/cvs-serv25096 Modified Files: protocol.lisp event.lisp Log Message: Extend mode tracking: Handle response to a MODE request on a channel Date: Sun Mar 27 23:40:31 2005 Author: ehuelsmann Index: cl-irc/protocol.lisp diff -u cl-irc/protocol.lisp:1.21 cl-irc/protocol.lisp:1.22 --- cl-irc/protocol.lisp:1.21 Sun Mar 27 22:27:18 2005 +++ cl-irc/protocol.lisp Sun Mar 27 23:40:30 2005 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.21 2005/03/27 20:27:18 ehuelsmann Exp $ +;;;; $Id: protocol.lisp,v 1.22 2005/03/27 21:40:30 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/protocol.lisp,v $ ;;;; See LICENSE for licensing information. @@ -220,6 +220,7 @@ irc-kick-message irc-nick-message irc-mode-message + irc-rpl_channelmodeis-message ctcp-time-message ctcp-source-message ctcp-finger-message Index: cl-irc/event.lisp diff -u cl-irc/event.lisp:1.8 cl-irc/event.lisp:1.9 --- cl-irc/event.lisp:1.8 Sun Mar 27 22:27:18 2005 +++ cl-irc/event.lisp Sun Mar 27 23:40:30 2005 @@ -1,4 +1,4 @@ -;;;; $Id: event.lisp,v 1.8 2005/03/27 20:27:18 ehuelsmann Exp $ +;;;; $Id: event.lisp,v 1.9 2005/03/27 21:40:30 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/event.lisp,v $ ;;;; See LICENSE for licensing information. @@ -185,6 +185,27 @@ (defmethod default-hook ((message irc-quit-message)) (let ((connection (connection message))) (remove-user-everywhere connection (find-user connection (source message))))) + +(defmethod default-hook ((message irc-rpl_channelmodeis-message)) + (destructuring-bind + (target &rest arguments) + ;; ignore the my own nick which is the first message argument + (rest (arguments message)) + (let* ((connection (connection message)) + (target (find-channel connection target)) + (mode-changes + (when target + (parse-mode-arguments connection target arguments + :server-p (user connection))))) + (dolist (change mode-changes) + (destructuring-bind + (op mode-name value) + change + (unless (has-mode-p target mode-name) + (add-mode target mode-name + (make-mode connection target mode-name))) + (funcall (if (char= #\+ op) #'set-mode #'unset-mode) + target mode-name value)))))) (defmethod default-hook ((message irc-mode-message)) (destructuring-bind

1 0

[Cl-irc-cvs] CVS update: cl-irc/protocol.lisp cl-irc/event.lisp
by ehuelsmann＠common-lisp.net 27 Mar '05

27 Mar '05

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp.net:/tmp/cvs-serv20592 Modified Files: protocol.lisp event.lisp Log Message: Extend mode tracking: set absolute mode values for ban, except and invite lists. * event.lisp (generate-maskmode-hooks): New. Macro to define hooks for ban, except and invitelist messages and their endlist companions. (): Use generate-maskmode-hooks to generate hooks for ban, except and invite list messages. (default-hook [irc-rpl_namreply-message]): Register which users were sent in the namreply list. (default-hook [irc-rpl_endofnames-message]): Remove users which were not in the namreply-list. Before, only missing users were added, now spurious ones will be deleted too. * protocol.lisp (add-default-hooks): Add hooks for new messages. Date: Sun Mar 27 22:27:18 2005 Author: ehuelsmann Index: cl-irc/protocol.lisp diff -u cl-irc/protocol.lisp:1.20 cl-irc/protocol.lisp:1.21 --- cl-irc/protocol.lisp:1.20 Mon Mar 21 23:32:35 2005 +++ cl-irc/protocol.lisp Sun Mar 27 22:27:18 2005 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.20 2005/03/21 22:32:35 ehuelsmann Exp $ +;;;; $Id: protocol.lisp,v 1.21 2005/03/27 20:27:18 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/protocol.lisp,v $ ;;;; See LICENSE for licensing information. @@ -202,9 +202,16 @@ (defmethod add-default-hooks ((connection connection)) (dolist (message '(irc-rpl_isupport-message irc-rpl_whoisuser-message + irc-rpl_banlist-message + irc-rpl_endofbanlist-message + irc-rpl_exceptlist-message + irc-rpl_endofexceptlist-message + irc-rpl_invitelist-message + irc-rpl_endofinvitelist-message irc-rpl_list-message irc-rpl_topic-message irc-rpl_namreply-message + irc-rpl_endofnames-message irc-ping-message irc-join-message irc-topic-message Index: cl-irc/event.lisp diff -u cl-irc/event.lisp:1.7 cl-irc/event.lisp:1.8 --- cl-irc/event.lisp:1.7 Sun Mar 20 17:55:36 2005 +++ cl-irc/event.lisp Sun Mar 27 22:27:18 2005 @@ -1,4 +1,4 @@ -;;;; $Id: event.lisp,v 1.7 2005/03/20 16:55:36 ehuelsmann Exp $ +;;;; $Id: event.lisp,v 1.8 2005/03/27 20:27:18 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/event.lisp,v $ ;;;; See LICENSE for licensing information. @@ -20,6 +20,47 @@ of the IRC message to keep the connection, channel and user objects in sync.")) +(defmacro generate-maskmode-hooks (listmsg-class endmsg-class + tmp-symbol mode-symbol) + `(progn + (defmethod default-hook ((message ,listmsg-class)) + (destructuring-bind + (target channel-name mask set-by time-set) + (arguments message) + (declare (ignore target set-by time-set)) + ;; note: the structure currently does not allow for logging + ;; set-by and time-set: the MODE message handling currently + ;; does not allow that. + (let ((channel (find-channel (connection message) channel-name))) + (when channel + (unless (has-mode-p channel ',tmp-symbol) + ;; start with a new list, replacing the old value later + (add-mode channel ',tmp-symbol + (make-instance 'list-value-mode + :value-type :non-user))) + ;; use package-local symbol to prevent conflicts + (set-mode channel ',tmp-symbol mask))))) + + (defmethod default-hook ((message ,endmsg-class)) + (let ((channel (find-channel (connection message) + (car (arguments message))))) + (when channel + (let ((mode (has-mode-p channel ',tmp-symbol))) + (when mode + ;; replace list + (add-mode channel ',mode-symbol mode) + (remove-mode channel ',tmp-symbol)))))))) + +(generate-maskmode-hooks irc-rpl_banlist-message + irc-rpl_endofbanlist-message + banlist-in-progress :ban) +(generate-maskmode-hooks irc-rpl_exceptlist-message + irc-rpl_endofexceptlist-message + exceptlist-in-progress :except) +(generate-maskmode-hooks irc-rpl_invitelist-message + irc-rpl_endofinvitelist-message + invitelist-in-progress :invite) + (defmethod default-hook ((message irc-rpl_isupport-message)) (let* ((capabilities (cdr (arguments message))) (connection (connection message)) @@ -72,13 +113,17 @@ (defmethod default-hook ((message irc-rpl_namreply-message)) (let* ((connection (connection message)) (channel (find-channel connection (car (last (arguments message)))))) + (unless (has-mode-p channel 'namreply-in-progress) + (add-mode channel 'namreply-in-progress + (make-instance 'list-value-mode :value-type :user))) (dolist (nickname (tokenize-string (trailing-argument message))) (let ((user (find-or-make-user connection (canonicalize-nickname connection nickname)))) (unless (equal user (user connection)) (add-user connection user) - (add-user channel user)) + (add-user channel user) + (set-mode channel 'namreply-in-progress user)) (let* ((mode-char (getf (nick-prefixes connection) (elt nickname 0))) (mode-name (when mode-char @@ -91,6 +136,19 @@ (make-mode connection channel mode-name)) user)))))))) + +(defmethod default-hook ((message irc-rpl_endofnames-message)) + (let* ((channel (find-channel (connection message) + (second (arguments message)))) + (mode (get-mode channel 'namreply-in-progress)) + (channel-users)) + (remove-mode channel 'namreply-in-progress) + (maphash #'(lambda (nick user-obj) + (declare (ignore nick)) + (pushnew user-obj channel-users)) (users channel)) + (dolist (user (remove-if #'(lambda (x) + (member x mode)) channel-users)) + (remove-user channel user)))) (defmethod default-hook ((message irc-ping-message)) (pong (connection message) (trailing-argument message)))

1 0