cl-irc-cvs

Download

cl-irc-cvs@common-lisp.net

July 2005

2 participants
2 discussions

[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