- net-nittin-irc-cvs@lists.common-lisp.net

[net-nittin-irc-cvs] CVS update: net-nittin-irc/example/irclogs.css net-nittin-irc/example/logger.lisp
by Kevin Rosenberg 14 Dec '03

14 Dec '03

Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv9229 Modified Files: irclogs.css logger.lisp Log Message: add multi-directory output and user-address info Date: Sun Dec 14 06:53:42 2003 Author: krosenberg Index: net-nittin-irc/example/irclogs.css diff -u net-nittin-irc/example/irclogs.css:1.1 net-nittin-irc/example/irclogs.css:1.2 --- net-nittin-irc/example/irclogs.css:1.1 Sun Dec 14 05:40:08 2003 +++ net-nittin-irc/example/irclogs.css Sun Dec 14 06:53:41 2003 @@ -21,6 +21,10 @@ .action-msg { color:#000; } +.user-address { color:#444; } + +.info-brack { color:#CCC; } + .info-msg { color:#000; } .object { color:#822; } Index: net-nittin-irc/example/logger.lisp diff -u net-nittin-irc/example/logger.lisp:1.3 net-nittin-irc/example/logger.lisp:1.4 --- net-nittin-irc/example/logger.lisp:1.3 Sun Dec 14 05:40:08 2003 +++ net-nittin-irc/example/logger.lisp Sun Dec 14 06:53:41 2003 @@ -1,5 +1,5 @@ ;;;; -*- Mode: Lisp -*- -;;;; $Id: logger.lisp,v 1.3 2003/12/14 10:40:08 krosenberg Exp $ +;;;; $Id: logger.lisp,v 1.4 2003/12/14 11:53:41 krosenberg Exp $ ;;;; ;;;; Purpose: A logging bot ;;;; Author: Kevin Rosenberg @@ -29,6 +29,7 @@ :documentation "Name of channel.") (streams :initarg :streams :reader streams :documentation "List of output streams.") + (default-pathname :initarg :default-pathname :reader default-pathname) (base-name :initarg :base-name :reader base-name :documentation "Base file name for channel") (current-output-names :initarg :current-output-names :accessor current-output-names))) @@ -46,14 +47,12 @@ (user-output :initarg :user-output :reader user-output :documentation "Output parameter from user, maybe stream or pathname.") - (base-name :initarg :base-name :reader base-name - :documentation "Base name of log files.") (formats :initarg :formats :reader formats :documentation "A list of output formats."))) (defvar *loggers* nil "List of active loggers.") -(defparameter *uri-scanner* +(defvar *uri-scanner* (create-scanner '(:register (:alternation @@ -68,6 +67,13 @@ (:greedy-repetition 1 nil :non-whitespace-char-class)))) :case-insensitive-mode t)) +(defparameter *user-address-scanner* + (create-scanner + '(:sequence #\! + (:register + (:greedy-repetition 1 nil :non-whitespace-char-class))) + :case-insensitive-mode t)) + (defun find-logger-with-nick (nick) (find nick (the list *loggers*) :test #'string-equal :key #'nickname)) @@ -76,14 +82,14 @@ (second minute hour day-of-month month year day-of-week daylight-p zone) (decode-universal-time utime) (declare (ignore second minute hour day-of-week daylight-p zone)) - (format nil "~A~4,'0D-~2,'0D-~2,'0D" base-name year month day-of-month))) + (format nil "~A~4,'0D.~2,'0D.~2,'0D" base-name year month day-of-month))) (defun output-file-header (logger channel istream) (case (elt (formats logger) istream) (:html (format (elt (streams channel) istream) "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">~%") - (format (elt (streams channel) istream) "<html><head><link rel="stylesheet" href="irclogs.css" type="text/css" /></head><body>~%")))) + (format (elt (streams channel) istream) "<html><head><link rel='stylesheet' href='/irclogs.css' type='text/css' /></head><body>~%")))) (defun output-file-footer (logger channel istream) (case (elt (formats logger) istream) @@ -97,12 +103,13 @@ (output-file-footer logger channel istream) (close (elt (streams channel) istream))) (setf (elt (current-output-names channel) istream) name) - (let ((path (make-pathname :defaults (user-output logger) :name name + (let ((path (make-pathname :defaults (default-pathname channel) :name name :type (case (elt (formats logger) istream) (:html "html") (:sexp "sexp") (t "txt"))))) (unless (probe-file path) + (ensure-directories-exist path) (setf (elt (streams channel) istream) (open path :direction :output :if-exists :error :if-does-not-exist :create)) @@ -152,6 +159,12 @@ (format stream "<a href='~A'>~A</a>" item item) (write-string item stream))))))) +(defun user-address (msg) + (let ((split (split *user-address-scanner* (raw-message-string msg) :with-registers-p t))) + (if (second split) + (second split) + ""))) + (defun output-event-for-a-stream (msg type text object logger channel istream) (ensure-output-stream (received-time msg) logger channel istream) (let ((source (source msg)) @@ -176,14 +189,16 @@ "*~A* ~A" source (activate-uris text))) (t - (format stream "~A ~A" - source text) + (format stream "~A [~A] ~A" + source (user-address msg) text) (when object (format stream " ~A" object)))) (format stream "</div>~%")) (:sexp - (format stream "(~W ~W ~W ~W ~W)~%" (received-time msg) - type source text object)) + (format stream "(~W ~W ~W ~W ~W ~W)~%" (received-time msg) + type source text object + (unless (or (eq :privmsg type) (eq :action type)) + (user-address msg)))) (t (format stream "~A " (format-time (received-time msg))) (case type @@ -192,7 +207,7 @@ (:action (format stream "*~A* ~A" source text)) (t - (format stream "[info] ~A ~A" source text) + (format stream "[info] ~A [~A] ~A" source (user-address msg) text) (when object (format stream " ~A" object)))) (write-char #\Newline stream))) @@ -200,11 +215,13 @@ (defun output-event (msg type text &optional object) (dolist (logger *loggers*) - (let* ((channel-name (car (last (arguments msg)))) + (let* ((channel-name (case type + (:join + (trailing-argument msg)) + (t + (car (last (arguments msg)))))) (channel (find channel-name (the list (channels logger)) :test #'string-equal :key #'name))) - (print channel-name) - (print channel) (when channel (dotimes (i (length (formats logger))) (output-event-for-a-stream msg type text object logger channel i)))))) @@ -239,7 +256,6 @@ (first (arguments msg)))) (defun create-logger (nick server &key channels output - (base-name "log-") (logging-stream t) (async t) (formats '(:text))) @@ -247,7 +263,6 @@ ;; check arguments (assert channels) (assert formats) - (assert (stringp base-name)) (if (atom channels) (setq channels (list channels))) (if (atom formats) @@ -266,9 +281,18 @@ collect (make-instance 'channel :name (nth i channels) :streams (make-list (length formats)) + :default-pathname + (when (and (pathnamep output) + (null (pathname-name output))) + (merge-pathnames + (make-pathname :directory + (list :relative + (string-left-trim + '(#\#) + (nth i channels)))) + output)) :base-name (concatenate 'string - base-name (string-left-trim '(#\#) (nth i channels)) @@ -276,7 +300,6 @@ :current-output-names (make-list (length formats)))) :user-output output - :base-name base-name :formats formats))) (mapc #'(lambda (channel) (join conn channel)) channels) @@ -314,7 +337,6 @@ t)))) (defun add-logger (nick server &key channels output - (base-name "log-") (logging-stream t) (async t) (formats '(:text))) @@ -323,7 +345,7 @@ (quit-logger nick)) (let ((logger (create-logger nick server :channels channels :output output - :base-name base-name :logging-stream logging-stream + :logging-stream logging-stream :async async :formats formats))) (push logger *loggers*) logger))

1 0

[net-nittin-irc-cvs] CVS update: net-nittin-irc/example/irclogs.css net-nittin-irc/example/logger.lisp
by Kevin Rosenberg 14 Dec '03

14 Dec '03

Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv3113 Modified Files: logger.lisp Added Files: irclogs.css Log Message: add multiple,simultaneous loggers, channels, and formats. add html and sexp formats. Date: Sun Dec 14 05:40:09 2003 Author: krosenberg Index: net-nittin-irc/example/logger.lisp diff -u net-nittin-irc/example/logger.lisp:1.2 net-nittin-irc/example/logger.lisp:1.3 --- net-nittin-irc/example/logger.lisp:1.2 Sat Dec 13 23:22:24 2003 +++ net-nittin-irc/example/logger.lisp Sun Dec 14 05:40:08 2003 @@ -1,54 +1,132 @@ ;;;; -*- Mode: Lisp -*- -;;;; $Id: logger.lisp,v 1.2 2003/12/14 04:22:24 krosenberg Exp $ +;;;; $Id: logger.lisp,v 1.3 2003/12/14 10:40:08 krosenberg Exp $ ;;;; ;;;; Purpose: A logging bot ;;;; Author: Kevin Rosenberg ;;;; License: net-nittin-irc license ;;; Quickstart: -;;; - load net-nittin-irc asdf system +;;; - have net-nittin-irc, cl-ppcre paths on your asdf:*central-registry* ;;; - load this file: logger.lisp ;;; - (logger:start-logger-bot <nickname> <server> &keys channels output) +(unless (find-package 'net-nittin-irc) + (asdf:operate 'asdf:load-op 'net-nittin-irc)) +(unless (find-package 'cl-ppcre) + (asdf:operate 'asdf:load-op 'cl-ppcre)) +#+ignore +(unless (find-package 'puri) + (asdf:operate 'asdf:load-op 'puri)) + (in-package cl-user) (defpackage logger - (:use :common-lisp :irc) + (:use :common-lisp :irc :cl-ppcre) (:export #:start-logger-bot)) (in-package logger) -(defvar *bot-nickname* nil) -(defvar *connection* nil) -(defvar *output* nil "User output parametet to start-logger-bot.") -(defvar *current-output-name* "Name of current output file.") -(defvar *base-name* nil "Base name for output files.") -(defvar *output-stream* nil "Current output stream.") +(defclass channel () + ((name :initarg :name :reader name + :documentation "Name of channel.") + (streams :initarg :streams :reader streams + :documentation "List of output streams.") + (base-name :initarg :base-name :reader base-name + :documentation "Base file name for channel") + (current-output-names :initarg :current-output-names :accessor current-output-names))) + + +(defclass logger () + ((connection :initarg :connection :reader connection + :documentation "IRC connection object.") + (nick :initarg :nick :reader nickname + :documentation "Nickname of the bot.") + (server :initarg :server :reader server + :documentation "Connected IRC server.") + (channels :initarg :channels :reader channels + :documentation "List of channels.") + (user-output :initarg :user-output :reader user-output + :documentation + "Output parameter from user, maybe stream or pathname.") + (base-name :initarg :base-name :reader base-name + :documentation "Base name of log files.") + (formats :initarg :formats :reader formats + :documentation + "A list of output formats."))) + +(defvar *loggers* nil "List of active loggers.") +(defparameter *uri-scanner* + (create-scanner + '(:register + (:alternation + (:sequence :word-boundary "http://" + (:char-class (:range #\a #\z) (:range #\a #\z) (:range #\0 #\9)) + (:greedy-repetition 1 nil :non-whitespace-char-class)) + (:sequence :word-boundary "ftp://" + (:char-class (:range #\a #\z) (:range #\a #\z) (:range #\0 #\9)) + (:greedy-repetition 1 nil :non-whitespace-char-class)) + (:sequence :word-boundary "mailto:" + (:char-class (:range #\a #\z) (:range #\a #\z) (:range #\0 #\9)) + (:greedy-repetition 1 nil :non-whitespace-char-class)))) + :case-insensitive-mode t)) + +(defun find-logger-with-nick (nick) + (find nick (the list *loggers*) :test #'string-equal :key #'nickname)) -(defun make-output-name (utime) +(defun make-output-name (base-name utime) (multiple-value-bind (second minute hour day-of-month month year day-of-week daylight-p zone) (decode-universal-time utime) (declare (ignore second minute hour day-of-week daylight-p zone)) - (format nil "~A~4,'0D-~2,'0D-~2,'0D" *base-name* year month day-of-month))) + (format nil "~A~4,'0D-~2,'0D-~2,'0D" base-name year month day-of-month))) + +(defun output-file-header (logger channel istream) + (case (elt (formats logger) istream) + (:html + (format (elt (streams channel) istream) + "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">~%") + (format (elt (streams channel) istream) "<html><head><link rel="stylesheet" href="irclogs.css" type="text/css" /></head><body>~%")))) + +(defun output-file-footer (logger channel istream) + (case (elt (formats logger) istream) + (:html + (format (elt (streams channel) istream) "</body></html>~%")))) + +(defun ensure-output-stream-for-user-directory (utime logger channel istream) + (let ((name (make-output-name (base-name channel) utime))) + (unless (string= name (elt (current-output-names channel) istream)) + (when (elt (streams channel) istream) + (output-file-footer logger channel istream) + (close (elt (streams channel) istream))) + (setf (elt (current-output-names channel) istream) name) + (let ((path (make-pathname :defaults (user-output logger) :name name + :type (case (elt (formats logger) istream) + (:html "html") + (:sexp "sexp") + (t "txt"))))) + (unless (probe-file path) + (setf (elt (streams channel) istream) + (open path :direction :output :if-exists :error + :if-does-not-exist :create)) + (output-file-header logger channel istream) + (close (elt (streams channel) istream))) + (setf (elt (streams channel) istream) + (open path :direction :output :if-exists :append + :if-does-not-exist :error)))))) -(defun ensure-output-stream (utime) +(defun ensure-output-stream (utime logger channel istream) "Ensures that *output-stream* is correct." (cond - ((streamp *output*) - (unless *output-stream* - (setq *output-stream* *output*))) - ((pathnamep *output*) - (let ((name (make-output-name utime))) - (unless (string= name *current-output-name*) - (when *output-stream* - (close *output-stream*)) - (setq *current-output-name* name) - (setq *output-stream* - (open (make-pathname :defaults *output* :name name - :type "txt") - :direction :output - :if-exists :append - :if-does-not-exist :create))))))) - + ((streamp (user-output logger)) + (unless (elt (streams channel) istream) + (setf (elt (streams channel) istream) (user-output logger)))) + ((pathnamep (user-output logger)) + (cond + ((pathname-name (user-output logger)) + ;; a file is named for output + (setf (elt (streams channel) istream) + (open (user-output logger) :direction :output :if-exists :append))) + (t + (ensure-output-stream-for-user-directory utime logger channel istream)))))) + (defun format-time (utime) (multiple-value-bind (second minute hour day-of-month month year day-of-week daylight-p zone) @@ -56,94 +134,198 @@ (declare (ignore second day-of-month month year day-of-week daylight-p zone)) (format nil "~2,'0D:~2,'0D" hour minute))) -(defun output-event (msg text) - (ensure-output-stream (received-time msg)) - (assert (streamp *output-stream*)) - (format *output-stream* "~A ~A~%" - (format-time (received-time msg)) - text) - (force-output *output-stream*)) - -(defmethod irc::irc-message-event ((msg irc::irc-privmsg-message)) - (output-event msg - (format nil "<~A> ~A" - (source msg) - (trailing-argument msg)))) - - -(defmethod irc::irc-message-event ((msg irc::irc-nick-message)) - (output-event msg - (format nil "[info] ~A is now known as ~A" - (source msg) - (trailing-argument msg)))) - -(defmethod irc::irc-message-event ((msg irc::irc-part-message)) - (output-event msg - (format nil "[info] ~A has left ~A" - (source msg) - (first (arguments msg))))) - -(defmethod irc::irc-message-event ((msg irc::irc-quit-message)) - (output-event msg - (format nil "[info] ~A has quit ~A" - (source msg) - (trailing-argument msg)))) - -(defmethod irc::irc-message-event ((msg irc::irc-join-message)) - (output-event msg - (format nil "[info] ~A has joined ~A" - (source msg) - (trailing-argument msg)))) - -(defmethod irc::irc-message-event ((msg irc::irc-kick-message)) - (output-event msg - (format nil "[info] ~A has been kicked from ~A" - (source msg) - (first (arguments msg))))) - -(defmethod irc::irc-message-event ((msg irc::ctcp-action-message)) - (output-event msg - (format nil "*~A* ~A" - (source msg) - (subseq (trailing-argument msg) - 8 - (- (length (trailing-argument msg)) 1))))) - - -(defun start-logger-bot (nick server &key channels output - (base-name "log-") - (logging-stream t) - (async t)) + +(defun activate-uris (str) + "Find any URI's in a string and make them HTML clickable." + (let ((split (split *uri-scanner* str :with-registers-p t))) + (if (= 1 (length split)) + str + (with-output-to-string (stream) + (dolist (item split) + (if (and (> (length item) 6) + (or + (string-equal "http://" (subseq item 0 7)) + (string-equal "ftp://" (subseq item 0 6)) + (string-equal "mailto:" (subseq item 0 7))) + ;; (ignore-errors (puri:parse-uri item)) + t) + (format stream "<a href='~A'>~A</a>" item item) + (write-string item stream))))))) + +(defun output-event-for-a-stream (msg type text object logger channel istream) + (ensure-output-stream (received-time msg) logger channel istream) + (let ((source (source msg)) + (stream (elt (streams channel) istream))) + (assert (streamp stream)) + (case (elt (formats logger) istream) + (:html + (format stream + "<div class='~A'>" + (case type + (:privmsg "privmsg") + (:action "action") + (t "info"))) + (write-string (format-time (received-time msg)) stream) + (format stream " ") + (case type + (:privmsg + (format stream "<~A> ~A" + source (activate-uris text))) + (:action + (format stream + "*~A* ~A" + source (activate-uris text))) + (t + (format stream "~A ~A" + source text) + (when object + (format stream " ~A" object)))) + (format stream "</div>~%")) + (:sexp + (format stream "(~W ~W ~W ~W ~W)~%" (received-time msg) + type source text object)) + (t + (format stream "~A " (format-time (received-time msg))) + (case type + (:privmsg + (format stream "<~A> ~A" source text)) + (:action + (format stream "*~A* ~A" source text)) + (t + (format stream "[info] ~A ~A" source text) + (when object + (format stream " ~A" object)))) + (write-char #\Newline stream))) + (force-output stream)))/ + +(defun output-event (msg type text &optional object) + (dolist (logger *loggers*) + (let* ((channel-name (car (last (arguments msg)))) + (channel (find channel-name (the list (channels logger)) + :test #'string-equal :key #'name))) + (print channel-name) + (print channel) + (when channel + (dotimes (i (length (formats logger))) + (output-event-for-a-stream msg type text object logger channel i)))))) + +(defun privmsg-hook (msg) + (output-event msg :privmsg (trailing-argument msg))) + +(defun action-hook (msg) + (output-event msg :action + (subseq (trailing-argument msg) + 8 + (- (length (trailing-argument msg)) 1)))) + +(defun nick-hook (msg) + (output-event msg :nick "is now known as" + (trailing-argument msg))) + +(defun part-hook (msg) + (output-event msg :part "has left" + (first (arguments msg)))) + +(defun quit-hook (msg) + (output-event msg :quit "has quit" + (concatenate 'string "[" (trailing-argument msg) "]"))) + +(defun join-hook (msg) + (output-event msg :join "has joined" + (trailing-argument msg))) + +(defun kick-hook (msg) + (output-event msg :kick "has been kicked from" + (first (arguments msg)))) + +(defun create-logger (nick server &key channels output + (base-name "log-") + (logging-stream t) + (async t) + (formats '(:text))) "OUTPUT may be a pathname or a stream" ;; check arguments (assert channels) + (assert formats) (assert (stringp base-name)) - (if (stringp channels) + (if (atom channels) (setq channels (list channels))) + (if (atom formats) + (setq formats (list formats))) (if (stringp output) (setq output (parse-namestring output))) - (setq *bot-nickname* nick) - (setq *base-name* base-name) - (setq *output* output) - (when *connection* - (warn "Closing open logger connection.") - (quit *connection*) - (sleep 2)) ;; give the server a chance to close out connection - - (setq *connection* - (connect :nickname *bot-nickname* :server server - :logging-stream logging-stream)) - (mapc #'(lambda (channel) (join *connection* channel)) channels) - - (reset-hooks) - (cond - (async - #+sbcl (add-asynchronous-message-handler *connection*) - #-sbcl (read-message-loop *connection*)) - (t - (read-message-loop *connection*)))) - - -(defun reset-hooks () - (irc::remove-all-hooks *connection*)) + (let* ((conn (connect :nickname nick :server server + :logging-stream logging-stream)) + (logger (make-instance + 'logger + :connection conn + :nick nick + :server server + :channels + (loop for i from 0 to (1- (length channels)) + collect (make-instance 'channel + :name (nth i channels) + :streams (make-list (length formats)) + :base-name + (concatenate 'string + base-name + (string-left-trim + '(#\#) + (nth i channels)) + "-") + :current-output-names + (make-list (length formats)))) + :user-output output + :base-name base-name + :formats formats))) + (mapc #'(lambda (channel) (join conn channel)) channels) + + (add-hook conn 'irc::irc-privmsg-message 'privmsg-hook) + (add-hook conn 'irc::ctcp-action-message 'action-hook) + (add-hook conn 'irc::irc-nick-message 'nick-hook) + (add-hook conn 'irc::irc-part-message 'part-hook) + (add-hook conn 'irc::irc-quit-message 'quit-hook) + (add-hook conn 'irc::irc-join-message 'join-hook) + (add-hook conn 'irc::irc-kick-message 'kick-hook) + (cond + (async + #+sbcl (add-asynchronous-message-handler conn) + #-sbcl (read-message-loop conn)) + (t + (read-message-loop conn))) + logger)) + +(defun quit-logger (nick) + "Quit the active connection with nick and remove from active list." + (let ((logger (find-logger-with-nick nick))) + (cond + ((null logger) + (warn "No active connection found with nick ~A." nick) + nil) + (t + (irc:quit (connection logger)) + (sleep 1) + (dolist (channel (channels logger)) + (dotimes (i (length (streams channel))) + (when (streamp (elt (streams channel) i)) + (close (elt (streams channel) i)) + (setf (elt (streams channel) i) nil)))) + (setq *loggers* (delete nick *loggers* :test #'string-equal :key #'nickname)) + t)))) + +(defun add-logger (nick server &key channels output + (base-name "log-") + (logging-stream t) + (async t) + (formats '(:text))) + (when (find-logger-with-nick nick) + (warn "Closing previously active connection.") + (quit-logger nick)) + (let ((logger + (create-logger nick server :channels channels :output output + :base-name base-name :logging-stream logging-stream + :async async :formats formats))) + (push logger *loggers*) + logger)) +

1 0

[net-nittin-irc-cvs] CVS update: net-nittin-irc/example/logger.lisp
by Kevin Rosenberg 14 Dec '03

14 Dec '03

Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv11098 Modified Files: logger.lisp Log Message: convert completely to irc-message-event Date: Sat Dec 13 23:22:24 2003 Author: krosenberg Index: net-nittin-irc/example/logger.lisp diff -u net-nittin-irc/example/logger.lisp:1.1 net-nittin-irc/example/logger.lisp:1.2 --- net-nittin-irc/example/logger.lisp:1.1 Sat Dec 13 22:54:12 2003 +++ net-nittin-irc/example/logger.lisp Sat Dec 13 23:22:24 2003 @@ -1,5 +1,5 @@ ;;;; -*- Mode: Lisp -*- -;;;; $Id: logger.lisp,v 1.1 2003/12/14 03:54:12 krosenberg Exp $ +;;;; $Id: logger.lisp,v 1.2 2003/12/14 04:22:24 krosenberg Exp $ ;;;; ;;;; Purpose: A logging bot ;;;; Author: Kevin Rosenberg @@ -64,7 +64,7 @@ text) (force-output *output-stream*)) -(defun priv-msg-hook (msg) +(defmethod irc::irc-message-event ((msg irc::irc-privmsg-message)) (output-event msg (format nil "<~A> ~A" (source msg) @@ -101,7 +101,7 @@ (source msg) (first (arguments msg))))) -(defun ctcp-action-hook (msg) +(defmethod irc::irc-message-event ((msg irc::ctcp-action-message)) (output-event msg (format nil "*~A* ~A" (source msg) @@ -145,7 +145,5 @@ (defun reset-hooks () - (irc::remove-all-hooks *connection*) - (add-hook *connection* 'irc::irc-privmsg-message 'priv-msg-hook) - (add-hook *connection* 'irc::ctcp-action-message 'ctcp-action-hook) - (add-hook *connection* 'irc::irc-privmsg-message 'msg-hook)) + (irc::remove-all-hooks *connection*)) +

1 0

[net-nittin-irc-cvs] CVS update: net-nittin-irc/example/logger.lisp
by Kevin Rosenberg 14 Dec '03

14 Dec '03

Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv671 Added Files: logger.lisp Log Message: initial upload Date: Sat Dec 13 22:54:12 2003 Author: krosenberg

1 0

[net-nittin-irc-cvs] CVS update: net-nittin-irc/LICENSE
by Brian Mastenbrook 13 Dec '03

13 Dec '03

Update of /project/net-nittin-irc/cvsroot/net-nittin-irc In directory common-lisp.net:/tmp/cvs-serv25758 Modified Files: LICENSE Log Message: Add myself (so people know who this guy is who wrote the example programs) Date: Sat Dec 13 18:51:23 2003 Author: bmastenbrook Index: net-nittin-irc/LICENSE diff -u net-nittin-irc/LICENSE:1.3 net-nittin-irc/LICENSE:1.4 --- net-nittin-irc/LICENSE:1.3 Sat Nov 22 13:41:03 2003 +++ net-nittin-irc/LICENSE Sat Dec 13 18:51:23 2003 @@ -1,5 +1,5 @@ Copyright (c) 2002 Jochen Schmidt -Copyright (c) 2003 Erik Enge +Copyright (c) 2003 Erik Enge and Brian Mastenbrook Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions @@ -22,4 +22,5 @@ For further details contact the authors of this software. - Erik Enge, erik(a)nittin.net \ No newline at end of file + Erik Enge, erik(a)nittin.net + Brian Mastenbrook, bmastenb(a)indiana.edu \ No newline at end of file

1 0

[net-nittin-irc-cvs] CVS update: net-nittin-irc/example/cliki.lisp
by Brian Mastenbrook 13 Dec '03

13 Dec '03

Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv23428 Modified Files: cliki.lisp Log Message: Minor fixes Date: Sat Dec 13 18:44:34 2003 Author: bmastenbrook Index: net-nittin-irc/example/cliki.lisp diff -u net-nittin-irc/example/cliki.lisp:1.4 net-nittin-irc/example/cliki.lisp:1.5 --- net-nittin-irc/example/cliki.lisp:1.4 Sat Dec 13 18:08:26 2003 +++ net-nittin-irc/example/cliki.lisp Sat Dec 13 18:44:33 2003 @@ -1,4 +1,4 @@ -;;;; $Id: cliki.lisp,v 1.4 2003/12/13 23:08:26 bmastenbrook Exp $ +;;;; $Id: cliki.lisp,v 1.5 2003/12/13 23:44:33 bmastenbrook Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/example/cliki.lisp,v $ ;;;; cliki.lisp - CLiki as an infobot; only works on SBCL. @@ -24,11 +24,13 @@ (defun write-small-definitions () (with-open-file (sd-file "sd.lisp-expr" :direction :output :if-exists :supersede) (mapc #'(lambda (defn) - (prin1 defn sd-file)) *small-definitions*))) + (prin1 defn sd-file) + (format sd-file "~%")) *small-definitions*))) (defun write-top-definition () (with-open-file (sd-file "sd.lisp-expr" :direction :output :if-exists :append) - (prin1 (car *small-definitions*) sd-file))) + (prin1 (car *small-definitions*) sd-file) + (format sd-file "~%"))) (defun add-small-definition (term defn) (push (cons term defn) *small-definitions*) @@ -131,7 +133,7 @@ (defparameter *cliki-attention-prefix* "cliki: ") -(defparameter *cliki-bot-help* "The CLiki bot supplies small definitions and performs lookups on CLiki. To add a term for IRC, try saying ``cliki: add \"term\" as: definition''.") +(defparameter *cliki-bot-help* "The CLiki bot supplies small definitions and performs lookups on CLiki. To use it, try ``cliki: term?''. To add a term for IRC, try saying ``cliki: add \"term\" as: definition''; otherwise, edit the corresponding CLiki page.") (defun cliki-lookup (term-with-question) (let ((first-pass (regex-replace-all "^(\\s*)([^?]+)(\\?*)$" term-with-question "\\2")))

1 0

[net-nittin-irc-cvs] CVS update: net-nittin-irc/example/cliki.lisp
by Brian Mastenbrook 13 Dec '03

13 Dec '03

Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv4884 Modified Files: cliki.lisp Log Message: Add small definitions functionality. Date: Sat Dec 13 18:08:28 2003 Author: bmastenbrook Index: net-nittin-irc/example/cliki.lisp diff -u net-nittin-irc/example/cliki.lisp:1.3 net-nittin-irc/example/cliki.lisp:1.4 --- net-nittin-irc/example/cliki.lisp:1.3 Sat Dec 13 09:03:39 2003 +++ net-nittin-irc/example/cliki.lisp Sat Dec 13 18:08:26 2003 @@ -1,4 +1,4 @@ -;;;; $Id: cliki.lisp,v 1.3 2003/12/13 14:03:39 bmastenbrook Exp $ +;;;; $Id: cliki.lisp,v 1.4 2003/12/13 23:08:26 bmastenbrook Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/example/cliki.lisp,v $ ;;;; cliki.lisp - CLiki as an infobot; only works on SBCL. @@ -10,6 +10,30 @@ (defpackage :cliki (:use :common-lisp :irc :sb-bsd-sockets :cl-ppcre)) (in-package :cliki) +(defvar *small-definitions* nil) + +(defun read-small-definitions () + (setf *small-definitions* 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*)))))))))) + +(defun write-small-definitions () + (with-open-file (sd-file "sd.lisp-expr" :direction :output :if-exists :supersede) + (mapc #'(lambda (defn) + (prin1 defn sd-file)) *small-definitions*))) + +(defun write-top-definition () + (with-open-file (sd-file "sd.lisp-expr" :direction :output :if-exists :append) + (prin1 (car *small-definitions*) sd-file))) + +(defun add-small-definition (term defn) + (push (cons term defn) *small-definitions*) + (write-small-definitions)) + (defun url-port (url) (assert (string-equal url "http://" :end1 7)) (let ((port-start (position #\: url :start 7))) @@ -107,11 +131,22 @@ (defparameter *cliki-attention-prefix* "cliki: ") +(defparameter *cliki-bot-help* "The CLiki bot supplies small definitions and performs lookups on CLiki. To add a term for IRC, try saying ``cliki: add \"term\" as: definition''.") + (defun cliki-lookup (term-with-question) (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 "")) - (concatenate 'string first-pass ": " (cliki-first-sentence 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.") + (concatenate 'string first-pass ": " + (or + (if (string-equal first-pass "help") *cliki-bot-help*) + (cdr (assoc first-pass *small-definitions* :test #'string-equal)) + (cliki-first-sentence first-pass)))))) (defun valid-cliki-message (message) (eql (search *cliki-attention-prefix* (trailing-argument message) :test #'char-equal) 0))

1 0

[net-nittin-irc-cvs] CVS update: net-nittin-irc/example/cliki.lisp
by Brian Mastenbrook 13 Dec '03

13 Dec '03

Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv9160 Modified Files: cliki.lisp Log Message: Fixed handling in the case of an end-of-file. Date: Sat Dec 13 09:03:40 2003 Author: bmastenbrook Index: net-nittin-irc/example/cliki.lisp diff -u net-nittin-irc/example/cliki.lisp:1.2 net-nittin-irc/example/cliki.lisp:1.3 --- net-nittin-irc/example/cliki.lisp:1.2 Sat Dec 13 08:11:34 2003 +++ net-nittin-irc/example/cliki.lisp Sat Dec 13 09:03:39 2003 @@ -1,4 +1,4 @@ -;;;; $Id: cliki.lisp,v 1.2 2003/12/13 13:11:34 bmastenbrook Exp $ +;;;; $Id: cliki.lisp,v 1.3 2003/12/13 14:03:39 bmastenbrook Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/example/cliki.lisp,v $ ;;;; cliki.lisp - CLiki as an infobot; only works on SBCL. @@ -33,7 +33,7 @@ (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~%~%" url host) + (format stream "GET ~A HTTP/1.0~%Host: ~A~%User-Agent: CLiki Bot~%~%" url host) (force-output stream) (list (let* ((l (read-line stream)) @@ -52,7 +52,7 @@ (setf str (regex-replace-all " " str "%20")) (setf str (regex-replace-all "," str "%2C")) (setf str (regex-replace-all "`" str "%60")) - (format t "hi ~A~%" str) + ;(format t "hi ~A~%" str) str) (defun cliki-first-sentence (term) @@ -76,19 +76,23 @@ (let ((first-line "")) (loop for i from 1 to 5 do ;; scan the first 5 lines (progn - (setf first-line (concatenate 'string first-line (read-line stream))) + (multiple-value-bind (next-line missing-newline-p) + (read-line stream nil) + (if next-line + (setf first-line (concatenate 'string first-line next-line (string #\newline))) + (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 "\\*\$([^)]*)\$" first-line "\\1")) (setf first-line (regex-replace-all "<[^>]+>" first-line "")) - (setf first-line (regex-replace-all "^([^.]+)\\..*$" first-line "\\1.")) + (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 "^[^.]+\\.$" first-line) + (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))) + (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.")))))))

1 0

[net-nittin-irc-cvs] CVS update: net-nittin-irc/example/cliki.lisp
by Brian Mastenbrook 13 Dec '03

13 Dec '03

Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv23336 Modified Files: cliki.lisp Log Message: Fixed a string parsing bug. Date: Sat Dec 13 08:11:34 2003 Author: bmastenbrook Index: net-nittin-irc/example/cliki.lisp diff -u net-nittin-irc/example/cliki.lisp:1.1 net-nittin-irc/example/cliki.lisp:1.2 --- net-nittin-irc/example/cliki.lisp:1.1 Sat Dec 13 00:38:42 2003 +++ net-nittin-irc/example/cliki.lisp Sat Dec 13 08:11:34 2003 @@ -1,4 +1,4 @@ -;;;; $Id: cliki.lisp,v 1.1 2003/12/13 05:38:42 bmastenbrook Exp $ +;;;; $Id: cliki.lisp,v 1.2 2003/12/13 13:11:34 bmastenbrook Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/example/cliki.lisp,v $ ;;;; cliki.lisp - CLiki as an infobot; only works on SBCL. @@ -82,7 +82,7 @@ (setf first-line (regex-replace-all "_\$([^)]*)\$" 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*.*$" first-line "\\1.")) + (setf first-line (regex-replace-all "^([^.]+)\\..*$" 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 "^[^.]+\\.$" first-line)

1 0

[net-nittin-irc-cvs] CVS update: net-nittin-irc/example/cliki.lisp
by Brian Mastenbrook 13 Dec '03

13 Dec '03

Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv26017 Added Files: cliki.lisp Log Message: Code to use cliki as an infobot (very cool, requires SBCL for the HTTP stuff, which was shamelessly stolen from asdf-install). Date: Sat Dec 13 00:38:42 2003 Author: bmastenbrook

1 0