From eenge at common-lisp.net Mon Dec 1 14:49:34 2003 From: eenge at common-lisp.net (Erik Enge) Date: Mon, 01 Dec 2003 09:49:34 -0500 Subject: [net-nittin-irc-cvs] CVS update: public_html/index.html Message-ID: Update of /project/net-nittin-irc/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv10419 Modified Files: index.html Log Message: s/setf/defvar Date: Mon Dec 1 09:49:34 2003 Author: eenge Index: public_html/index.html diff -u public_html/index.html:1.8 public_html/index.html:1.9 --- public_html/index.html:1.8 Wed Nov 26 07:38:23 2003 +++ public_html/index.html Mon Dec 1 09:49:34 2003 @@ -75,8 +75,8 @@ * (in-package :irc) - * (setf connection (connect :nickname "mynick" - :server "irc.somewhere.org")) + * (defvar connection (connect :nickname "mynick" + :server "irc.somewhere.org")) * (read-message-loop connection) From bmastenbrook at common-lisp.net Sat Dec 13 05:38:42 2003 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Sat, 13 Dec 2003 00:38:42 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/example/cliki.lisp Message-ID: 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 From bmastenbrook at common-lisp.net Sat Dec 13 13:11:34 2003 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Sat, 13 Dec 2003 08:11:34 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/example/cliki.lisp Message-ID: 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) From bmastenbrook at common-lisp.net Sat Dec 13 14:03:40 2003 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Sat, 13 Dec 2003 09:03:40 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/example/cliki.lisp Message-ID: 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."))))))) From bmastenbrook at common-lisp.net Sat Dec 13 23:08:29 2003 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Sat, 13 Dec 2003 18:08:29 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/example/cliki.lisp Message-ID: 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)) From bmastenbrook at common-lisp.net Sat Dec 13 23:44:34 2003 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Sat, 13 Dec 2003 18:44:34 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/example/cliki.lisp Message-ID: 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"))) From bmastenbrook at common-lisp.net Sat Dec 13 23:51:24 2003 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Sat, 13 Dec 2003 18:51:24 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/LICENSE Message-ID: 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 at nittin.net \ No newline at end of file + Erik Enge, erik at nittin.net + Brian Mastenbrook, bmastenb at indiana.edu \ No newline at end of file From krosenberg at common-lisp.net Sun Dec 14 03:54:12 2003 From: krosenberg at common-lisp.net (Kevin Rosenberg) Date: Sat, 13 Dec 2003 22:54:12 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/example/logger.lisp Message-ID: 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 From krosenberg at common-lisp.net Sun Dec 14 04:22:24 2003 From: krosenberg at common-lisp.net (Kevin Rosenberg) Date: Sat, 13 Dec 2003 23:22:24 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/example/logger.lisp Message-ID: 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*)) + From krosenberg at common-lisp.net Sun Dec 14 10:40:09 2003 From: krosenberg at common-lisp.net (Kevin Rosenberg) Date: Sun, 14 Dec 2003 05:40:09 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/example/irclogs.css net-nittin-irc/example/logger.lisp Message-ID: 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 &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) + "~%") + (format (elt (streams channel) istream) "~%")))) + +(defun output-file-footer (logger channel istream) + (case (elt (formats logger) istream) + (:html + (format (elt (streams channel) istream) "~%")))) + +(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" 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 + "
" + (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 "
~%")) + (: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)) + From krosenberg at common-lisp.net Sun Dec 14 11:53:42 2003 From: krosenberg at common-lisp.net (Kevin Rosenberg) Date: Sun, 14 Dec 2003 06:53:42 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/example/irclogs.css net-nittin-irc/example/logger.lisp Message-ID: 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) "~%") - (format (elt (streams channel) istream) "~%")))) + (format (elt (streams channel) istream) "~%")))) (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" 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 "~%")) (: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)) From krosenberg at common-lisp.net Sun Dec 14 13:01:51 2003 From: krosenberg at common-lisp.net (Kevin Rosenberg) Date: Sun, 14 Dec 2003 08:01:51 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/example/irclogs.css net-nittin-irc/example/logger.lisp Message-ID: Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv11495 Modified Files: irclogs.css logger.lisp Log Message: use css style names rather than hard coding the colors, weights, and sizes Date: Sun Dec 14 08:01:51 2003 Author: krosenberg Index: net-nittin-irc/example/irclogs.css diff -u net-nittin-irc/example/irclogs.css:1.2 net-nittin-irc/example/irclogs.css:1.3 --- net-nittin-irc/example/irclogs.css:1.2 Sun Dec 14 06:53:41 2003 +++ net-nittin-irc/example/irclogs.css Sun Dec 14 08:01:50 2003 @@ -1,16 +1,17 @@ /* -*- Mode: CSS -*- */ /* Cascading stylesheet for logger.lisp */ +#body { font-family: fixed; + font-size: 10px; + background: #FFFFFF; + color: #000000; + margin: 0px 0px 10px 0px; + } + .time { color:#888; } .privmsg { } -.action { } - -.info { font-size:85%; font-style:italic; } - -.brack ( color:#CCC; ) - .subject { color:#22C; font-weight: bold; } .msg ( color:#000; ) @@ -23,8 +24,10 @@ .user-address { color:#444; } -.info-brack { color:#CCC; } +.info-subject { color:#22C; font-weight: bold; font-size:80% } + +.info-brack { color:#CCC; font-size:80%} -.info-msg { color:#000; } +.info-msg { color:#000; font-size:80%} -.object { color:#822; } +.info-object { color:#822; font-size:80%; } Index: net-nittin-irc/example/logger.lisp diff -u net-nittin-irc/example/logger.lisp:1.4 net-nittin-irc/example/logger.lisp:1.5 --- net-nittin-irc/example/logger.lisp:1.4 Sun Dec 14 06:53:41 2003 +++ net-nittin-irc/example/logger.lisp Sun Dec 14 08:01:50 2003 @@ -1,5 +1,5 @@ ;;;; -*- Mode: Lisp -*- -;;;; $Id: logger.lisp,v 1.4 2003/12/14 11:53:41 krosenberg Exp $ +;;;; $Id: logger.lisp,v 1.5 2003/12/14 13:01:50 krosenberg Exp $ ;;;; ;;;; Purpose: A logging bot ;;;; Author: Kevin Rosenberg @@ -14,9 +14,6 @@ (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 @@ -84,12 +81,21 @@ (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))) +(defun html-title (channel) + (multiple-value-bind + (second minute hour day-of-month month year day-of-week daylight-p zone) + (decode-universal-time (get-universal-time)) + (declare (ignore second minute hour day-of-week daylight-p zone)) + (format nil "~A IRC Log ~4,'0D/~2,'0D/~2,'0D" + (string-left-trim '(#\#) (name channel)) year month day-of-month))) + (defun output-file-header (logger channel istream) (case (elt (formats logger) istream) (:html (format (elt (streams channel) istream) - "~%") - (format (elt (streams channel) istream) "~%")))) + "~%~%") + (format (elt (streams channel) istream) "~%~%~A~%~%~%~%" + (html-title channel))))) (defun output-file-footer (logger channel istream) (case (elt (formats logger) istream) @@ -172,14 +178,9 @@ (assert (streamp stream)) (case (elt (formats logger) istream) (:html - (format stream - "
" - (case type - (:privmsg "privmsg") - (:action "action") - (t "info"))) + (write-string "
" stream) (write-string (format-time (received-time msg)) stream) - (format stream " ") + (write-string " " stream) (case type (:privmsg (format stream "<~A> ~A" @@ -189,10 +190,10 @@ "*~A* ~A" source (activate-uris text))) (t - (format stream "~A [~A] ~A" + (format stream "~A [~A] ~A" source (user-address msg) text) (when object - (format stream " ~A" object)))) + (format stream " ~A" object)))) (format stream "
~%")) (:sexp (format stream "(~W ~W ~W ~W ~W ~W)~%" (received-time msg) @@ -215,16 +216,22 @@ (defun output-event (msg type text &optional object) (dolist (logger *loggers*) - (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))) - (when channel - (dotimes (i (length (formats logger))) - (output-event-for-a-stream msg type text object logger channel i)))))) + (case type + (:quit + (dolist (channel (channels logger)) + (dotimes (i (length (formats logger))) + (output-event-for-a-stream msg type text object logger channel i)))) + (t + (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))) + (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))) From krosenberg at common-lisp.net Sun Dec 14 13:50:07 2003 From: krosenberg at common-lisp.net (Kevin Rosenberg) Date: Sun, 14 Dec 2003 08:50:07 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/example/irclogs.css net-nittin-irc/example/logger.lisp Message-ID: Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv2906 Modified Files: irclogs.css logger.lisp Log Message: css fixes Date: Sun Dec 14 08:50:05 2003 Author: krosenberg Index: net-nittin-irc/example/irclogs.css diff -u net-nittin-irc/example/irclogs.css:1.3 net-nittin-irc/example/irclogs.css:1.4 --- net-nittin-irc/example/irclogs.css:1.3 Sun Dec 14 08:01:50 2003 +++ net-nittin-irc/example/irclogs.css Sun Dec 14 08:50:04 2003 @@ -1,22 +1,21 @@ /* -*- Mode: CSS -*- */ /* Cascading stylesheet for logger.lisp */ -#body { font-family: fixed; - font-size: 10px; +#body { font-family: courier, fixed; background: #FFFFFF; color: #000000; margin: 0px 0px 10px 0px; } -.time { color:#888; } - -.privmsg { } +.time { color:#666; } .subject { color:#22C; font-weight: bold; } -.msg ( color:#000; ) +.msg { color:#000; } + +.brack { color:#777; } -.action-brack { color:#500; } +.action-brack { color:#511; } .action-name { color:#A22; font-weight:bold; } @@ -26,7 +25,7 @@ .info-subject { color:#22C; font-weight: bold; font-size:80% } -.info-brack { color:#CCC; font-size:80%} +.info-brack { color:#AAA; font-size:80%} .info-msg { color:#000; font-size:80%} Index: net-nittin-irc/example/logger.lisp diff -u net-nittin-irc/example/logger.lisp:1.5 net-nittin-irc/example/logger.lisp:1.6 --- net-nittin-irc/example/logger.lisp:1.5 Sun Dec 14 08:01:50 2003 +++ net-nittin-irc/example/logger.lisp Sun Dec 14 08:50:04 2003 @@ -1,5 +1,5 @@ ;;;; -*- Mode: Lisp -*- -;;;; $Id: logger.lisp,v 1.5 2003/12/14 13:01:50 krosenberg Exp $ +;;;; $Id: logger.lisp,v 1.6 2003/12/14 13:50:04 krosenberg Exp $ ;;;; ;;;; Purpose: A logging bot ;;;; Author: Kevin Rosenberg @@ -94,7 +94,7 @@ (:html (format (elt (streams channel) istream) "~%~%") - (format (elt (streams channel) istream) "~%~%~A~%~%~%~%" + (format (elt (streams channel) istream) "~%~%~A~%~%~%~%" (html-title channel))))) (defun output-file-footer (logger channel istream) @@ -193,7 +193,12 @@ (format stream "~A [~A] ~A" source (user-address msg) text) (when object - (format stream " ~A" object)))) + (case type + (:quit + (format stream " [~A]" + object)) + (t + (format stream " ~A" object)))))) (format stream "
~%")) (:sexp (format stream "(~W ~W ~W ~W ~W ~W)~%" (received-time msg) @@ -210,9 +215,12 @@ (t (format stream "[info] ~A [~A] ~A" source (user-address msg) text) (when object - (format stream " ~A" object)))) + (format stream (case type + (:quit " [~A]") + (t " ~A")) + object)))) (write-char #\Newline stream))) - (force-output stream)))/ + (force-output stream))) (defun output-event (msg type text &optional object) (dolist (logger *loggers*) @@ -251,8 +259,7 @@ (first (arguments msg)))) (defun quit-hook (msg) - (output-event msg :quit "has quit" - (concatenate 'string "[" (trailing-argument msg) "]"))) + (output-event msg :quit "has quit" (trailing-argument msg))) (defun join-hook (msg) (output-event msg :join "has joined" From krosenberg at common-lisp.net Sun Dec 14 14:29:24 2003 From: krosenberg at common-lisp.net (Kevin Rosenberg) Date: Sun, 14 Dec 2003 09:29:24 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/example/irclogs.css Message-ID: Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv21507 Modified Files: irclogs.css Log Message: better font-family Date: Sun Dec 14 09:29:24 2003 Author: krosenberg Index: net-nittin-irc/example/irclogs.css diff -u net-nittin-irc/example/irclogs.css:1.4 net-nittin-irc/example/irclogs.css:1.5 --- net-nittin-irc/example/irclogs.css:1.4 Sun Dec 14 08:50:04 2003 +++ net-nittin-irc/example/irclogs.css Sun Dec 14 09:29:24 2003 @@ -1,7 +1,7 @@ /* -*- Mode: CSS -*- */ /* Cascading stylesheet for logger.lisp */ -#body { font-family: courier, fixed; +#body { font-family: fixed; background: #FFFFFF; color: #000000; margin: 0px 0px 10px 0px; From krosenberg at common-lisp.net Sun Dec 14 16:10:30 2003 From: krosenberg at common-lisp.net (Kevin Rosenberg) Date: Sun, 14 Dec 2003 11:10:30 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/example/irc-logger.asd net-nittin-irc/example/irclogs.css net-nittin-irc/example/logger.lisp Message-ID: Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv24784 Modified Files: irclogs.css logger.lisp Added Files: irc-logger.asd Log Message: add asdf system Date: Sun Dec 14 11:10:29 2003 Author: krosenberg Index: net-nittin-irc/example/irclogs.css diff -u net-nittin-irc/example/irclogs.css:1.5 net-nittin-irc/example/irclogs.css:1.6 --- net-nittin-irc/example/irclogs.css:1.5 Sun Dec 14 09:29:24 2003 +++ net-nittin-irc/example/irclogs.css Sun Dec 14 11:10:29 2003 @@ -4,7 +4,7 @@ #body { font-family: fixed; background: #FFFFFF; color: #000000; - margin: 0px 0px 10px 0px; + /* margin: 10px 10px 10px 1px;*/ } .time { color:#666; } Index: net-nittin-irc/example/logger.lisp diff -u net-nittin-irc/example/logger.lisp:1.6 net-nittin-irc/example/logger.lisp:1.7 --- net-nittin-irc/example/logger.lisp:1.6 Sun Dec 14 08:50:04 2003 +++ net-nittin-irc/example/logger.lisp Sun Dec 14 11:10:29 2003 @@ -1,19 +1,9 @@ ;;;; -*- Mode: Lisp -*- -;;;; $Id: logger.lisp,v 1.6 2003/12/14 13:50:04 krosenberg Exp $ +;;;; $Id: logger.lisp,v 1.7 2003/12/14 16:10:29 krosenberg Exp $ ;;;; ;;;; Purpose: A logging bot ;;;; Author: Kevin Rosenberg ;;;; License: net-nittin-irc license - -;;; Quickstart: -;;; - have net-nittin-irc, cl-ppcre paths on your asdf:*central-registry* -;;; - load this file: logger.lisp -;;; - (logger:start-logger-bot &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)) (in-package cl-user) (defpackage logger From krosenberg at common-lisp.net Sun Dec 14 17:13:19 2003 From: krosenberg at common-lisp.net (Kevin Rosenberg) Date: Sun, 14 Dec 2003 12:13:19 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/example/logger.lisp Message-ID: Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv14934 Modified Files: logger.lisp Log Message: store in year-month directories Date: Sun Dec 14 12:13:19 2003 Author: krosenberg Index: net-nittin-irc/example/logger.lisp diff -u net-nittin-irc/example/logger.lisp:1.7 net-nittin-irc/example/logger.lisp:1.8 --- net-nittin-irc/example/logger.lisp:1.7 Sun Dec 14 11:10:29 2003 +++ net-nittin-irc/example/logger.lisp Sun Dec 14 12:13:19 2003 @@ -1,15 +1,16 @@ ;;;; -*- Mode: Lisp -*- -;;;; $Id: logger.lisp,v 1.7 2003/12/14 16:10:29 krosenberg Exp $ +;;;; $Id: logger.lisp,v 1.8 2003/12/14 17:13:19 krosenberg Exp $ ;;;; ;;;; Purpose: A logging bot ;;;; Author: Kevin Rosenberg ;;;; License: net-nittin-irc license (in-package cl-user) -(defpackage logger +(defpackage irc-logger (:use :common-lisp :irc :cl-ppcre) - (:export #:start-logger-bot)) -(in-package logger) + (:export #:add-logger + #:quit-logger)) +(in-package irc-logger) (defclass channel () ((name :initarg :name :reader name @@ -92,6 +93,15 @@ (:html (format (elt (streams channel) istream) "~%")))) +(defun log-file-directory (utime pathname) + (append (pathname-directory pathname) + (list + (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 day-of-month hour day-of-week daylight-p zone)) + (format nil "~4,'0D-~2,'0D" year month))))) + (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)) @@ -99,7 +109,8 @@ (output-file-footer logger channel istream) (close (elt (streams channel) istream))) (setf (elt (current-output-names channel) istream) name) - (let ((path (make-pathname :defaults (default-pathname channel) :name name + (let ((path (make-pathname :directory (log-file-directory utime (default-pathname channel)) + :name name :type (case (elt (formats logger) istream) (:html "html") (:sexp "sexp") From krosenberg at common-lisp.net Sun Dec 14 19:30:47 2003 From: krosenberg at common-lisp.net (Kevin Rosenberg) Date: Sun, 14 Dec 2003 14:30:47 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/example/irclogs.css net-nittin-irc/example/logger.lisp Message-ID: Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv2371 Modified Files: irclogs.css logger.lisp Log Message: refactoring for simplicity Date: Sun Dec 14 14:30:46 2003 Author: krosenberg Index: net-nittin-irc/example/irclogs.css diff -u net-nittin-irc/example/irclogs.css:1.6 net-nittin-irc/example/irclogs.css:1.7 --- net-nittin-irc/example/irclogs.css:1.6 Sun Dec 14 11:10:29 2003 +++ net-nittin-irc/example/irclogs.css Sun Dec 14 14:30:46 2003 @@ -9,7 +9,7 @@ .time { color:#666; } -.subject { color:#22C; font-weight: bold; } +.source { color:#22C; font-weight: bold; } .msg { color:#000; } @@ -23,7 +23,7 @@ .user-address { color:#444; } -.info-subject { color:#22C; font-weight: bold; font-size:80% } +.info-source { color:#22C; font-weight: bold; font-size:80% } .info-brack { color:#AAA; font-size:80%} Index: net-nittin-irc/example/logger.lisp diff -u net-nittin-irc/example/logger.lisp:1.8 net-nittin-irc/example/logger.lisp:1.9 --- net-nittin-irc/example/logger.lisp:1.8 Sun Dec 14 12:13:19 2003 +++ net-nittin-irc/example/logger.lisp Sun Dec 14 14:30:46 2003 @@ -1,5 +1,5 @@ ;;;; -*- Mode: Lisp -*- -;;;; $Id: logger.lisp,v 1.8 2003/12/14 17:13:19 krosenberg Exp $ +;;;; $Id: logger.lisp,v 1.9 2003/12/14 19:30:46 krosenberg Exp $ ;;;; ;;;; Purpose: A logging bot ;;;; Author: Kevin Rosenberg @@ -9,7 +9,8 @@ (defpackage irc-logger (:use :common-lisp :irc :cl-ppcre) (:export #:add-logger - #:quit-logger)) + #:quit-logger + #:log-file-path)) (in-package irc-logger) (defclass channel () @@ -17,9 +18,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") + (output-root :initarg :output-root :reader output-root) (current-output-names :initarg :current-output-names :accessor current-output-names))) @@ -65,12 +64,16 @@ (defun find-logger-with-nick (nick) (find nick (the list *loggers*) :test #'string-equal :key #'nickname)) -(defun make-output-name (base-name utime) +(defun make-output-name (name year month day) + (format nil "~A-~4,'0D.~2,'0D.~2,'0D" + (string-left-trim '(#\#) name) year month day)) + +(defun make-output-name-utime (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))) + (make-output-name name year month day-of-month))) (defun html-title (channel) (multiple-value-bind @@ -93,28 +96,36 @@ (:html (format (elt (streams channel) istream) "~%")))) -(defun log-file-directory (utime pathname) - (append (pathname-directory pathname) - (list - (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 day-of-month hour day-of-week daylight-p zone)) - (format nil "~4,'0D-~2,'0D" year month))))) +(defun log-file-path (output-root channel-name year month day format) + (make-pathname + :defaults output-root + :directory (append (pathname-directory output-root) + (list + (string-left-trim '(#\#) channel-name) + (format nil "~4,'0D-~2,'0D" year month))) + :name (make-output-name channel-name year month day) + :type (case format + (:html "html") + (:sexp "sexp") + (t "txt")))) + + +(defun log-file-path-utime (utime output-root channel-name format) + (multiple-value-bind + (second minute hour day month year day-of-week daylight-p zone) + (decode-universal-time utime) + (declare (ignore second minute hour day-of-week daylight-p zone)) + (log-file-name output-root channel-name year month day format))) (defun ensure-output-stream-for-user-directory (utime logger channel istream) - (let ((name (make-output-name (base-name channel) utime))) + (let ((name (make-output-name-utime (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 :directory (log-file-directory utime (default-pathname channel)) - :name name - :type (case (elt (formats logger) istream) - (:html "html") - (:sexp "sexp") - (t "txt"))))) + (let ((path (log-file-path-utime (output-root channel) (name channel) + (elt (formats logger) istream) utime))) (unless (probe-file path) (ensure-directories-exist path) (setf (elt (streams channel) istream) @@ -141,7 +152,14 @@ (t (ensure-output-stream-for-user-directory utime logger channel istream)))))) -(defun format-time (utime) +(defun format-utime (utime) + (multiple-value-bind + (second minute hour day-of-month month year day-of-week daylight-p zone) + (decode-universal-time utime) + (declare (ignore day-of-month month year day-of-week daylight-p zone)) + (format nil "~2,'0D:~2,'0D:~2,'0D" hour minute second))) + +(defun format-utime-short(utime) (multiple-value-bind (second minute hour day-of-month month year day-of-week daylight-p zone) (decode-universal-time utime) @@ -172,56 +190,58 @@ (second split) ""))) +(defun %output-event (stream format utime type source text object user-address) + (case format + (:html + (write-string "
" stream) + (write-string (format-utime utime) stream) + (write-string " " 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] ~A" + source user-address text) + (when object + (case type + (:quit + (format stream " [~A]" + object)) + (t + (format stream " ~A" object)))))) + (format stream "
~%")) + (:sexp + (format stream "(~W ~W ~W ~W ~W ~W)~%" utime type source text object user-address)) + (t + (format stream "~A " (format-utime utime)) + (case type + (:privmsg + (format stream "<~A> ~A" source text)) + (:action + (format stream "*~A* ~A" source text)) + (t + (format stream "[info] ~A [~A] ~A" source user-address text) + (when object + (format stream (case type + (:quit " [~A]") + (t " ~A")) + object)))) + (write-char #\Newline stream)))) + +(defun is-info-type (type) + (not (or (eq :action type) (eq :privmsg type)))) + (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 - (write-string "
" stream) - (write-string (format-time (received-time msg)) stream) - (write-string " " 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] ~A" - source (user-address msg) text) - (when object - (case type - (:quit - (format stream " [~A]" - object)) - (t - (format stream " ~A" object)))))) - (format stream "
~%")) - (:sexp - (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 - (:privmsg - (format stream "<~A> ~A" source text)) - (:action - (format stream "*~A* ~A" source text)) - (t - (format stream "[info] ~A [~A] ~A" source (user-address msg) text) - (when object - (format stream (case type - (:quit " [~A]") - (t " ~A")) - object)))) - (write-char #\Newline stream))) - (force-output stream))) + (%output-event stream (elt (streams channel) istream) (elt (formats logger) istream) + (received-time sg) (source msg) text object + (when (is-info-type type) (user-address msg))) + (force-output stream)) (defun output-event (msg type text &optional object) (dolist (logger *loggers*) @@ -296,22 +316,10 @@ collect (make-instance 'channel :name (nth i channels) :streams (make-list (length formats)) - :default-pathname + :output-root (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 - (string-left-trim - '(#\#) - (nth i channels)) - "-") + output) :current-output-names (make-list (length formats)))) :user-output output From krosenberg at common-lisp.net Mon Dec 15 18:16:40 2003 From: krosenberg at common-lisp.net (Kevin Rosenberg) Date: Mon, 15 Dec 2003 13:16:40 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/example/logger.lisp Message-ID: Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv3001 Modified Files: logger.lisp Log Message: refactor accessors Date: Mon Dec 15 13:16:40 2003 Author: krosenberg Index: net-nittin-irc/example/logger.lisp diff -u net-nittin-irc/example/logger.lisp:1.9 net-nittin-irc/example/logger.lisp:1.10 --- net-nittin-irc/example/logger.lisp:1.9 Sun Dec 14 14:30:46 2003 +++ net-nittin-irc/example/logger.lisp Mon Dec 15 13:16:40 2003 @@ -1,10 +1,12 @@ ;;;; -*- Mode: Lisp -*- -;;;; $Id: logger.lisp,v 1.9 2003/12/14 19:30:46 krosenberg Exp $ +;;;; $Id: logger.lisp,v 1.10 2003/12/15 18:16:40 krosenberg Exp $ ;;;; ;;;; Purpose: A logging bot ;;;; Author: Kevin Rosenberg ;;;; License: net-nittin-irc license +;;;; TODO: mode, topic + (in-package cl-user) (defpackage irc-logger (:use :common-lisp :irc :cl-ppcre) @@ -75,26 +77,27 @@ (declare (ignore second minute hour day-of-week daylight-p zone)) (make-output-name name year month day-of-month))) -(defun html-title (channel) +(defun html-title (channel-name) (multiple-value-bind - (second minute hour day-of-month month year day-of-week daylight-p zone) + (second minute hour day-of-month month year dow daylight-p zone) (decode-universal-time (get-universal-time)) - (declare (ignore second minute hour day-of-week daylight-p zone)) + (declare (ignore second minute hour dow daylight-p zone)) (format nil "~A IRC Log ~4,'0D/~2,'0D/~2,'0D" - (string-left-trim '(#\#) (name channel)) year month day-of-month))) + (string-left-trim '(#\#) channel-name) year month day-of-month))) -(defun output-file-header (logger channel istream) - (case (elt (formats logger) istream) +(defun write-file-header (format channel-name stream) + (case format (:html - (format (elt (streams channel) istream) + (format stream "~%~%") - (format (elt (streams channel) istream) "~%~%~A~%~%~%~%" - (html-title channel))))) + (format stream + "~%~%~A~%~%~%~%~%" + (html-title channel-name))))) -(defun output-file-footer (logger channel istream) - (case (elt (formats logger) istream) +(defun write-file-footer (format stream) + (case format (:html - (format (elt (streams channel) istream) "~%")))) + (format stream "
~%")))) (defun log-file-path (output-root channel-name year month day format) (make-pathname @@ -110,30 +113,48 @@ (t "txt")))) -(defun log-file-path-utime (utime output-root channel-name format) +(defun log-file-path-utime (output-root channel-name format utime) (multiple-value-bind (second minute hour day month year day-of-week daylight-p zone) (decode-universal-time utime) (declare (ignore second minute hour day-of-week daylight-p zone)) - (log-file-name output-root channel-name year month day format))) + (log-file-path output-root channel-name year month day format))) + +(defun get-stream (channel istream) + (elt (streams channel) istream)) + +(defun (setf get-stream) (value channel istream) + (setf (elt (streams channel) istream) value)) -(defun ensure-output-stream-for-user-directory (utime logger channel istream) +(defun get-format (logger istream) + (elt (formats logger) istream)) + +(defun get-output-name (channel istream) + (elt (current-output-names channel) istream)) + +(defun (setf get-output-name) (value channel istream) + (setf (elt (current-output-names channel) istream) value)) + +(defun ensure-output-stream-for-directory-output (utime logger channel istream) (let ((name (make-output-name-utime (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) + (unless (string= name (get-output-name channel istream)) + (when (get-stream channel istream) + (write-file-footer (get-format logger istream) + (get-stream channel istream)) + (close (get-stream channel istream))) + (setf (get-output-name channel istream) name) (let ((path (log-file-path-utime (output-root channel) (name channel) - (elt (formats logger) istream) utime))) + (get-format logger istream) utime))) (unless (probe-file path) (ensure-directories-exist path) - (setf (elt (streams channel) istream) + (setf (get-stream 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) + (write-file-header (get-format logger istream) + (name channel) + (get-stream channel istream)) + (close (get-stream channel istream))) + (setf (get-stream channel istream) (open path :direction :output :if-exists :append :if-does-not-exist :error)))))) @@ -141,16 +162,17 @@ "Ensures that *output-stream* is correct." (cond ((streamp (user-output logger)) - (unless (elt (streams channel) istream) - (setf (elt (streams channel) istream) (user-output logger)))) + (unless (get-stream channel istream) + (setf (get-stream channel istream) (user-output logger)))) ((pathnamep (user-output logger)) (cond + ;; user specified a named file for output ((pathname-name (user-output logger)) - ;; a file is named for output - (setf (elt (streams channel) istream) + (setf (get-stream channel istream) (open (user-output logger) :direction :output :if-exists :append))) + ;; user specified a directory for output files (t - (ensure-output-stream-for-user-directory utime logger channel istream)))))) + (ensure-output-stream-for-directory-output utime logger channel istream)))))) (defun format-utime (utime) (multiple-value-bind @@ -166,7 +188,6 @@ (declare (ignore second day-of-month month year day-of-week daylight-p zone)) (format nil "~2,'0D:~2,'0D" hour minute))) - (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))) @@ -185,7 +206,8 @@ (write-string item stream))))))) (defun user-address (msg) - (let ((split (split *user-address-scanner* (raw-message-string msg) :with-registers-p t))) + (let ((split (split *user-address-scanner* (raw-message-string msg) + :with-registers-p t))) (if (second split) (second split) ""))) @@ -193,19 +215,19 @@ (defun %output-event (stream format utime type source text object user-address) (case format (:html - (write-string "
" stream) + (write-string "" stream) (write-string (format-utime utime) stream) - (write-string " " stream) + (write-string " " stream) (case type (:privmsg - (format stream "<~A> ~A" + (format stream "<~A>~A" source (activate-uris text))) (:action (format stream - "*~A* ~A" + "*~A* ~A" source (activate-uris text))) (t - (format stream "~A [~A] ~A" + (format stream "~A [~A] ~A" source user-address text) (when object (case type @@ -213,8 +235,11 @@ (format stream " [~A]" object)) (t - (format stream " ~A" object)))))) - (format stream "
~%")) + (format stream " ~A" object)))) + (write-string "" stream) + )) + (write-string "" stream) + (write-char #\Newline stream)) (:sexp (format stream "(~W ~W ~W ~W ~W ~W)~%" utime type source text object user-address)) (t @@ -238,10 +263,10 @@ (defun output-event-for-a-stream (msg type text object logger channel istream) (ensure-output-stream (received-time msg) logger channel istream) - (%output-event stream (elt (streams channel) istream) (elt (formats logger) istream) - (received-time sg) (source msg) text object + (%output-event (get-stream channel istream) (get-format logger istream) + (received-time msg) type (source msg) text object (when (is-info-type type) (user-address msg))) - (force-output stream)) + (force-output (get-stream channel istream))) (defun output-event (msg type text &optional object) (dolist (logger *loggers*) @@ -290,6 +315,18 @@ (output-event msg :kick "has been kicked from" (first (arguments msg)))) +(defun make-channels (names formats output) + (loop for i from 0 to (1- (length names)) + collect + (make-instance 'channel + :name (nth i names) + :streams (make-array (length formats) :initial-element nil) + :output-root (when (and (pathnamep output) + (null (pathname-name output))) + output) + :current-output-names (make-array (length formats) + :initial-element nil)))) + (defun create-logger (nick server &key channels output (logging-stream t) (async t) @@ -311,21 +348,11 @@ :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)) - :output-root - (when (and (pathnamep output) - (null (pathname-name output))) - output) - :current-output-names - (make-list (length formats)))) - :user-output output - :formats formats))) - (mapc #'(lambda (channel) (join conn channel)) channels) + :channels (make-channels channels formats output) + :user-output output + :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) @@ -353,10 +380,11 @@ (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)) + (when (streamp (get-stream channel i)) + (close (get-stream channel i)) + (setf (get-stream channel i) nil)))) + (setq *loggers* + (delete nick *loggers* :test #'string-equal :key #'nickname)) t)))) (defun add-logger (nick server &key channels output From bmastenbrook at common-lisp.net Mon Dec 15 19:48:19 2003 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Mon, 15 Dec 2003 14:48:19 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/example/cliki.lisp Message-ID: Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv21141 Modified Files: cliki.lisp Log Message: Add NickServ authentication Date: Mon Dec 15 14:48:19 2003 Author: bmastenbrook Index: net-nittin-irc/example/cliki.lisp diff -u net-nittin-irc/example/cliki.lisp:1.5 net-nittin-irc/example/cliki.lisp:1.6 --- net-nittin-irc/example/cliki.lisp:1.5 Sat Dec 13 18:44:33 2003 +++ net-nittin-irc/example/cliki.lisp Mon Dec 15 14:48:19 2003 @@ -1,4 +1,4 @@ -;;;; $Id: cliki.lisp,v 1.5 2003/12/13 23:44:33 bmastenbrook Exp $ +;;;; $Id: cliki.lisp,v 1.6 2003/12/15 19:48:19 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. @@ -131,9 +131,9 @@ (symbol-macrolet ((it ,test)) ,else)))) -(defparameter *cliki-attention-prefix* "cliki: ") +(defparameter *cliki-attention-prefix* "minion: ") -(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.") +(defparameter *cliki-bot-help* "The minion bot supplies small definitions and performs lookups on CLiki. To use it, try ``minion: term?''. To add a term for IRC, try saying ``minion: add \"term\" as: definition''; otherwise, edit the corresponding CLiki page.") (defun cliki-lookup (term-with-question) (let ((first-pass (regex-replace-all "^(\\s*)([^?]+)(\\?*)$" term-with-question "\\2"))) @@ -144,11 +144,18 @@ (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)))))) + (if (scan "^alias \"([^\"]+)\" as: (.+)$" first-pass) + (let ((term (regex-replace "^alias \"([^\"]+)\" .*$" first-pass "\\1")) + (defn (regex-replace "^alias \"[^\"]+\" as: (.+)$" first-pass "\\1"))) + (add-small-definition term (list defn)) + "OK, done.") + (or + (if (string-equal first-pass "help") *cliki-bot-help*) + (if (scan "^(?i)do my bidding!*$" first-pass) "Yes, my master.") + (concatenate 'string first-pass ": " + (or (let ((term (cdr (assoc first-pass *small-definitions* :test #'string-equal)))) + (if term (if (stringp term) term (cliki-lookup (car term))))) + (cliki-first-sentence first-pass)))))))) (defun valid-cliki-message (message) (eql (search *cliki-attention-prefix* (trailing-argument message) :test #'char-equal) 0)) @@ -161,14 +168,22 @@ (if (valid-cliki-message message) (privmsg *cliki-connection* (first (arguments message)) (cliki-lookup (subseq (trailing-argument message) (length *cliki-attention-prefix*))))))) +(defvar *cliki-nickserv-password* "") + +(defun notice-hook (message) + (if (and (string-equal (source message) "NickServ") + (scan "owned by someone else" (trailing-argument message))) + (privmsg *cliki-connection* (source message) (format nil "IDENTIFY ~A" *cliki-nickserv-password*)))) + (defun start-cliki-bot (nick server &rest channels) (setf *cliki-nickname* nick) (setf *cliki-connection* (connect :nickname *cliki-nickname* :server server)) (mapcar #'(lambda (channel) (join *cliki-connection* channel)) channels) - (add-hook *cliki-connection* 'irc::irc-privmsg-message #'msg-hook) + (add-hook *cliki-connection* 'irc::irc-privmsg-message 'msg-hook) + (add-hook *cliki-connection* 'irc::irc-notice-message 'notice-hook) #+sbcl (add-asynchronous-message-handler *cliki-connection*) #-sbcl (read-message-loop *cliki-connection*)) (defun shuffle-hooks () (irc::remove-hooks *cliki-connection* 'irc::irc-privmsg-message) - (add-hook *cliki-connection* 'irc::irc-privmsg-message #'msg-hook)) + (add-hook *cliki-connection* 'irc::irc-privmsg-message 'msg-hook)) From bmastenbrook at common-lisp.net Mon Dec 15 23:11:14 2003 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Mon, 15 Dec 2003 18:11:14 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/example/cliki.lisp Message-ID: Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv28571 Modified Files: cliki.lisp Log Message: Make cliki read its small definitions file on startup Date: Mon Dec 15 18:11:13 2003 Author: bmastenbrook Index: net-nittin-irc/example/cliki.lisp diff -u net-nittin-irc/example/cliki.lisp:1.6 net-nittin-irc/example/cliki.lisp:1.7 --- net-nittin-irc/example/cliki.lisp:1.6 Mon Dec 15 14:48:19 2003 +++ net-nittin-irc/example/cliki.lisp Mon Dec 15 18:11:12 2003 @@ -1,4 +1,4 @@ -;;;; $Id: cliki.lisp,v 1.6 2003/12/15 19:48:19 bmastenbrook Exp $ +;;;; $Id: cliki.lisp,v 1.7 2003/12/15 23:11:12 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. @@ -176,6 +176,7 @@ (privmsg *cliki-connection* (source message) (format nil "IDENTIFY ~A" *cliki-nickserv-password*)))) (defun start-cliki-bot (nick server &rest channels) + (read-small-definitions) (setf *cliki-nickname* nick) (setf *cliki-connection* (connect :nickname *cliki-nickname* :server server)) (mapcar #'(lambda (channel) (join *cliki-connection* channel)) channels) From krosenberg at common-lisp.net Tue Dec 16 18:30:33 2003 From: krosenberg at common-lisp.net (Kevin Rosenberg) Date: Tue, 16 Dec 2003 13:30:33 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/command.lisp net-nittin-irc/protocol.lisp Message-ID: Update of /project/net-nittin-irc/cvsroot/net-nittin-irc In directory common-lisp.net:/tmp/cvs-serv1338 Modified Files: command.lisp protocol.lisp Log Message: conditionalize sb-bsd-socket usage and warn for implementations where function not implemented Date: Tue Dec 16 13:30:32 2003 Author: krosenberg Index: net-nittin-irc/command.lisp diff -u net-nittin-irc/command.lisp:1.8 net-nittin-irc/command.lisp:1.9 --- net-nittin-irc/command.lisp:1.8 Sun Nov 23 18:21:57 2003 +++ net-nittin-irc/command.lisp Tue Dec 16 13:30:32 2003 @@ -1,4 +1,4 @@ -;;;; $Id: command.lisp,v 1.8 2003/11/23 23:21:57 eenge Exp $ +;;;; $Id: command.lisp,v 1.9 2003/12/16 18:30:32 krosenberg Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/command.lisp,v $ ;;;; See LICENSE for licensing information. @@ -304,6 +304,7 @@ (send-irc-message connection :privmsg (make-ctcp-message message) target)) (defmethod ctcp-chat-initiate ((connection connection) (nickname string)) + #+sbcl (let ((socket (sb-bsd-sockets:make-inet-socket :stream :tcp)) (port 44347)) (sb-bsd-sockets:socket-bind socket #(127 0 0 1) port) ; arbitrary port @@ -315,4 +316,6 @@ (make-dcc-connection :user (find-user connection nickname) :input-stream t :output-stream (sb-bsd-sockets:socket-make-stream socket :input t :output t :buffering :none) - :socket socket))) + :socket socket)) + #-sbcl (warn "ctcp-chat-initiate is not supported on this implementation.") + ) Index: net-nittin-irc/protocol.lisp diff -u net-nittin-irc/protocol.lisp:1.23 net-nittin-irc/protocol.lisp:1.24 --- net-nittin-irc/protocol.lisp:1.23 Tue Nov 25 08:14:34 2003 +++ net-nittin-irc/protocol.lisp Tue Dec 16 13:30:32 2003 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.23 2003/11/25 13:14:34 eenge Exp $ +;;;; $Id: protocol.lisp,v 1.24 2003/12/16 18:30:32 krosenberg Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/protocol.lisp,v $ ;;;; See LICENSE for licensing information. @@ -211,13 +211,16 @@ (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 t))) + :output-stream t)) + #-sbcl + (warn "make-dcc-connection not supported for this implementation.")) (defmethod read-message ((connection dcc-connection)) (let ((message (read-line (stream connection)))) @@ -237,7 +240,8 @@ (close (stream connection)) (setf (user connection) nil) (setf *dcc-connections* (remove connection *dcc-connections*)) - (sb-bsd-sockets:socket-close (socket connection))) + #+sbcl (sb-bsd-sockets:socket-close (socket connection)) + ) (defmethod connectedp ((connection dcc-connection)) (let ((stream (stream connection))) From krosenberg at common-lisp.net Tue Dec 16 18:57:37 2003 From: krosenberg at common-lisp.net (Kevin Rosenberg) Date: Tue, 16 Dec 2003 13:57:37 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/protocol.lisp net-nittin-irc/package.lisp net-nittin-irc/command.lisp Message-ID: Update of /project/net-nittin-irc/cvsroot/net-nittin-irc In directory common-lisp.net:/tmp/cvs-serv32586 Modified Files: protocol.lisp package.lisp command.lisp Log Message: avoid setting symbol-functions on cl exported symbols Date: Tue Dec 16 13:57:36 2003 Author: krosenberg Index: net-nittin-irc/protocol.lisp diff -u net-nittin-irc/protocol.lisp:1.24 net-nittin-irc/protocol.lisp:1.25 --- net-nittin-irc/protocol.lisp:1.24 Tue Dec 16 13:30:32 2003 +++ net-nittin-irc/protocol.lisp Tue Dec 16 13:57:36 2003 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.24 2003/12/16 18:30:32 krosenberg Exp $ +;;;; $Id: protocol.lisp,v 1.25 2003/12/16 18:57:36 krosenberg Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/protocol.lisp,v $ ;;;; See LICENSE for licensing information. @@ -143,7 +143,7 @@ message)) (defmethod send-irc-message ((connection connection) command - trailing-argument &rest arguments) + &optional trailing-argument &rest arguments) "Turn the arguments into a valid IRC message and send it to the server, via the `connection'." (let ((raw-message (make-irc-message command @@ -186,7 +186,7 @@ user at this end can be reached via your normal connection object.") (stream :initarg :stream - :accessor stream) + :accessor dcc-stream) (output-stream :initarg :output-stream :accessor output-stream @@ -223,7 +223,7 @@ (warn "make-dcc-connection not supported for this implementation.")) (defmethod read-message ((connection dcc-connection)) - (let ((message (read-line (stream connection)))) + (let ((message (read-line (dcc-stream connection)))) (format (output-stream connection) "~A~%" message) (force-output (output-stream connection)) message)) @@ -232,19 +232,19 @@ (loop while (read-message connection))) (defmethod send-dcc-message ((connection dcc-connection) message) - (format (stream connection) "~A~%" message)) + (format (dcc-stream connection) "~A~%" message)) ;; argh. I want to name this quit but that gives me issues with ;; generic functions. need to resolve. (defmethod dcc-close ((connection dcc-connection)) - (close (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)) - (let ((stream (stream connection))) + (let ((stream (dcc-stream connection))) (and (streamp stream) (open-stream-p stream)))) Index: net-nittin-irc/package.lisp diff -u net-nittin-irc/package.lisp:1.11 net-nittin-irc/package.lisp:1.12 --- net-nittin-irc/package.lisp:1.11 Mon Nov 24 22:35:55 2003 +++ net-nittin-irc/package.lisp Tue Dec 16 13:57:36 2003 @@ -1,4 +1,4 @@ -;;;; $Id: package.lisp,v 1.11 2003/11/25 03:35:55 eenge Exp $ +;;;; $Id: package.lisp,v 1.12 2003/12/16 18:57:36 krosenberg Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/package.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -100,7 +100,7 @@ :away :rehash :die - :restart + :restart- :summon :users- :wallops Index: net-nittin-irc/command.lisp diff -u net-nittin-irc/command.lisp:1.9 net-nittin-irc/command.lisp:1.10 --- net-nittin-irc/command.lisp:1.9 Tue Dec 16 13:30:32 2003 +++ net-nittin-irc/command.lisp Tue Dec 16 13:57:36 2003 @@ -1,4 +1,4 @@ -;;;; $Id: command.lisp,v 1.9 2003/12/16 18:30:32 krosenberg Exp $ +;;;; $Id: command.lisp,v 1.10 2003/12/16 18:57:36 krosenberg Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/command.lisp,v $ ;;;; See LICENSE for licensing information. @@ -274,7 +274,7 @@ (defmethod die ((connection connection)) (send-irc-message connection :die)) -(defmethod restart ((connection connection)) +(defmethod restart- ((connection connection)) (send-irc-message connection :restart)) (defmethod summon ((connection connection) (nickname string) From krosenberg at common-lisp.net Tue Dec 16 20:52:40 2003 From: krosenberg at common-lisp.net (Kevin Rosenberg) Date: Tue, 16 Dec 2003 15:52:40 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/utility.lisp Message-ID: Update of /project/net-nittin-irc/cvsroot/net-nittin-irc In directory common-lisp.net:/tmp/cvs-serv16616 Modified Files: utility.lisp Log Message: bind *print-circle* to nil when composing irc messages Date: Tue Dec 16 15:52:40 2003 Author: krosenberg Index: net-nittin-irc/utility.lisp diff -u net-nittin-irc/utility.lisp:1.5 net-nittin-irc/utility.lisp:1.6 --- net-nittin-irc/utility.lisp:1.5 Sun Nov 23 17:39:16 2003 +++ net-nittin-irc/utility.lisp Tue Dec 16 15:52:39 2003 @@ -1,4 +1,4 @@ -;;;; $Id: utility.lisp,v 1.5 2003/11/23 22:39:16 eenge Exp $ +;;;; $Id: utility.lisp,v 1.6 2003/12/16 20:52:39 krosenberg Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/utility.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -53,13 +53,14 @@ (trailing-argument nil)) "Return a valid IRC message, as a string, composed of the input parameters." - (format nil "~A~{ ~A~}~A~A~A~A" command arguments - (if trailing-argument - " :" + (let ((*print-circle* nil)) + (format nil "~A~{ ~A~}~A~A~A~A" command arguments + (if trailing-argument + " :" "") - (or trailing-argument "") - #\Return - #\Linefeed)) + (or trailing-argument "") + #\Return + #\Linefeed))) (defun make-ctcp-message (string) "Return a valid IRC CTCP message, as a string, composed by From krosenberg at common-lisp.net Tue Dec 16 21:16:55 2003 From: krosenberg at common-lisp.net (Kevin Rosenberg) Date: Tue, 16 Dec 2003 16:16:55 -0500 Subject: [net-nittin-irc-cvs] CVS update: Directory change: net-nittin-irc/debian Message-ID: Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/debian In directory common-lisp.net:/tmp/cvs-serv30571/debian Log Message: Directory /project/net-nittin-irc/cvsroot/net-nittin-irc/debian added to the repository Date: Tue Dec 16 16:16:55 2003 Author: krosenberg New directory net-nittin-irc/debian added From krosenberg at common-lisp.net Tue Dec 16 21:19:56 2003 From: krosenberg at common-lisp.net (Kevin Rosenberg) Date: Tue, 16 Dec 2003 16:19:56 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/example/logger.lisp net-nittin-irc/example/irclogs.css Message-ID: Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv32272 Modified Files: logger.lisp Removed Files: irclogs.css Log Message: add raw support, unichannel format support, remove html support, improve sexp format Date: Tue Dec 16 16:19:56 2003 Author: krosenberg Index: net-nittin-irc/example/logger.lisp diff -u net-nittin-irc/example/logger.lisp:1.10 net-nittin-irc/example/logger.lisp:1.11 --- net-nittin-irc/example/logger.lisp:1.10 Mon Dec 15 13:16:40 2003 +++ net-nittin-irc/example/logger.lisp Tue Dec 16 16:19:56 2003 @@ -1,5 +1,5 @@ ;;;; -*- Mode: Lisp -*- -;;;; $Id: logger.lisp,v 1.10 2003/12/15 18:16:40 krosenberg Exp $ +;;;; $Id: logger.lisp,v 1.11 2003/12/16 21:19:56 krosenberg Exp $ ;;;; ;;;; Purpose: A logging bot ;;;; Author: Kevin Rosenberg @@ -12,7 +12,10 @@ (:use :common-lisp :irc :cl-ppcre) (:export #:add-logger #:quit-logger - #:log-file-path)) + #:log-file-path + #:add-hook-logger + #:remove-hook-logger + #:*loggers*)) (in-package irc-logger) (defclass channel () @@ -36,25 +39,13 @@ (user-output :initarg :user-output :reader user-output :documentation "Output parameter from user, maybe stream or pathname.") + (unichannel :initarg :unichannel :reader unichannel :type boolean + :documentation "T if user-output is directory for individual channel output.") (formats :initarg :formats :reader formats :documentation "A list of output formats."))) (defvar *loggers* nil "List of active loggers.") -(defvar *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)) (defparameter *user-address-scanner* (create-scanner @@ -77,29 +68,19 @@ (declare (ignore second minute hour day-of-week daylight-p zone)) (make-output-name name year month day-of-month))) -(defun html-title (channel-name) - (multiple-value-bind - (second minute hour day-of-month month year dow daylight-p zone) - (decode-universal-time (get-universal-time)) - (declare (ignore second minute hour dow daylight-p zone)) - (format nil "~A IRC Log ~4,'0D/~2,'0D/~2,'0D" - (string-left-trim '(#\#) channel-name) year month day-of-month))) - -(defun write-file-header (format channel-name stream) - (case format - (:html - (format stream - "~%~%") - (format stream - "~%~%~A~%~%~%~%~%" - (html-title channel-name))))) - -(defun write-file-footer (format stream) - (case format - (:html - (format stream "
~%")))) +(defgeneric write-file-header (format channel-name stream)) -(defun log-file-path (output-root channel-name year month day format) +(defmethod write-file-header ((format t) channel-name stream) + (declare (ignore format channel-name stream)) + ) + +(defgeneric write-file-footer (format channel-name stream)) + +(defmethod write-file-footer ((format t) channel-name stream) + (declare (ignore format channel-name stream)) + ) + +(defun %log-file-path (output-root channel-name year month day type) (make-pathname :defaults output-root :directory (append (pathname-directory output-root) @@ -107,10 +88,18 @@ (string-left-trim '(#\#) channel-name) (format nil "~4,'0D-~2,'0D" year month))) :name (make-output-name channel-name year month day) - :type (case format - (:html "html") - (:sexp "sexp") - (t "txt")))) + :type type)) + +(defgeneric log-file-path (output-root channel-name year month day format)) + +(defmethod log-file-path (output-root channel-name year month day (format (eql :raw))) + (%log-file-path output-root channel-name year month day "raw")) + +(defmethod log-file-path (output-root channel-name year month day (format (eql :sexp))) + (%log-file-path output-root channel-name year month day "sexp")) + +(defmethod log-file-path (output-root channel-name year month day (format (eql :text))) + (%log-file-path output-root channel-name year month day "txt")) (defun log-file-path-utime (output-root channel-name format utime) @@ -135,11 +124,12 @@ (defun (setf get-output-name) (value channel istream) (setf (elt (current-output-names channel) istream) value)) -(defun ensure-output-stream-for-directory-output (utime logger channel istream) +(defun ensure-output-stream-for-unichannel (utime logger channel istream) (let ((name (make-output-name-utime (name channel) utime))) (unless (string= name (get-output-name channel istream)) (when (get-stream channel istream) (write-file-footer (get-format logger istream) + (name channel) (get-stream channel istream)) (close (get-stream channel istream))) (setf (get-output-name channel istream) name) @@ -161,18 +151,16 @@ (defun ensure-output-stream (utime logger channel istream) "Ensures that *output-stream* is correct." (cond - ((streamp (user-output logger)) - (unless (get-stream channel istream) - (setf (get-stream channel istream) (user-output logger)))) - ((pathnamep (user-output logger)) - (cond - ;; user specified a named file for output - ((pathname-name (user-output logger)) - (setf (get-stream channel istream) - (open (user-output logger) :direction :output :if-exists :append))) - ;; user specified a directory for output files - (t - (ensure-output-stream-for-directory-output utime logger channel istream)))))) + ((streamp (user-output logger)) + (unless (get-stream channel istream) + (setf (get-stream channel istream) (user-output logger)))) + ((pathnamep (user-output logger)) + (cond + ((unichannel logger) + (ensure-output-stream-for-unichannel utime logger channel istream)) + (t + (setf (get-stream channel istream) + (open (user-output logger) :direction :output :if-exists :append))))))) (defun format-utime (utime) (multiple-value-bind @@ -188,23 +176,6 @@ (declare (ignore second day-of-month month year day-of-week daylight-p zone)) (format nil "~2,'0D:~2,'0D" hour minute))) -(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" item item) - (write-string item stream))))))) - (defun user-address (msg) (let ((split (split *user-address-scanner* (raw-message-string msg) :with-registers-p t))) @@ -212,108 +183,112 @@ (second split) ""))) -(defun %output-event (stream format utime type source text object user-address) - (case format - (:html - (write-string "" stream) - (write-string (format-utime utime) stream) - (write-string " " 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] ~A" - source user-address text) - (when object - (case type - (:quit - (format stream " [~A]" - object)) - (t - (format stream " ~A" object)))) - (write-string "" stream) - )) - (write-string "" stream) - (write-char #\Newline stream)) - (:sexp - (format stream "(~W ~W ~W ~W ~W ~W)~%" utime type source text object user-address)) - (t - (format stream "~A " (format-utime utime)) - (case type - (:privmsg - (format stream "<~A> ~A" source text)) - (:action - (format stream "*~A* ~A" source text)) - (t - (format stream "[info] ~A [~A] ~A" source user-address text) - (when object - (format stream (case type - (:quit " [~A]") - (t " ~A")) - object)))) - (write-char #\Newline stream)))) - -(defun is-info-type (type) +(defun need-user-address? (type) (not (or (eq :action type) (eq :privmsg type)))) -(defun output-event-for-a-stream (msg type text object logger channel istream) +(defgeneric %output-event (format stream utime type channel source text msg unichannel)) + +(defmethod %output-event ((format t) stream utime type channel source text + msg unichannel) + (%output-event :raw stream utime type channel source text msg unichannel)) + +(defmethod %output-event ((format (eql :raw)) stream utime type channel source text + msg unichannel) + (declare (ignore unichannel)) + (format stream "~S~%" (string-right-trim '(#\return) (raw-message-string msg)))) + +(defmethod %output-event ((format (eql :sexp)) stream utime type channel source text + msg unichannel) + (if unichannel + (format stream "(~S ~S ~S ~S ~S)~%" utime type source text + (when (need-user-address? type) (user-address msg))) + (format stream "(~S ~S ~S ~S ~S ~S)~%" utime type source channel + text (when (need-user-address? type) (user-address msg))))) + +(defmethod %output-event ((format (eql :text)) stream utime type channel source text + msg unichannel) + (format stream "~A " (format-utime utime)) + (when (and (null unichannel) channel) + (format stream "[~A] " channel)) + + (let ((user-address (when (need-user-address? type) (user-address msg)))) + (case type + (:privmsg + (format stream "<~A> ~A" source text)) + (:action + (format stream "*~A* ~A" source text)) + (:join + (format stream "~A [~A] has joined ~A" source user-address channel)) + (:part + (format stream "-!- ~A [~A] has left ~A" source user-address channel)) + (:nick + (format stream "-!- ~A is now known as ~A" source text)) + (:kick + (format stream "-!- ~A [~A] has been kicked from ~A" source user-address channel)) + (:quit + (format stream "-!- ~A [~A] has quit [~A]" source user-address text)) + (:mode + (format stream "-!- ~A has set mode ~A" source text)) + (:topic + (format stream "-!- ~A changed the topic of ~A to: ~A" source channel text)) + (:notice + (format stream "-~A:~A- ~A" source channel text)) + (t + (warn "Unhandled msg type ~A." type)))) + (write-char #\Newline stream)) + +(defun output-event-for-a-stream (msg type channel text logger istream) (ensure-output-stream (received-time msg) logger channel istream) - (%output-event (get-stream channel istream) (get-format logger istream) - (received-time msg) type (source msg) text object - (when (is-info-type type) (user-address msg))) + (%output-event (get-format logger istream) (get-stream channel istream) + (received-time msg) type (name channel) (source msg) text msg + (unichannel logger)) (force-output (get-stream channel istream))) -(defun output-event (msg type text &optional object) +(defun output-event (msg type channel-name &optional text) (dolist (logger *loggers*) (case type - (:quit + ((:quit :nick) (dolist (channel (channels logger)) (dotimes (i (length (formats logger))) - (output-event-for-a-stream msg type text object logger channel i)))) + (output-event-for-a-stream msg type channel text logger i)))) (t - (let* ((channel-name (case type - (:join - (trailing-argument msg)) - (t - (car (last (arguments msg)))))) - (channel (find channel-name (the list (channels logger)) + (let* ((channel (find channel-name (the list (channels logger)) :test #'string-equal :key #'name))) (when channel (dotimes (i (length (formats logger))) - (output-event-for-a-stream msg type text object logger channel i)))))))) + (output-event-for-a-stream msg type channel text logger i)))))))) (defun privmsg-hook (msg) - (output-event msg :privmsg (trailing-argument msg))) + (output-event msg :privmsg (first (arguments msg)) (trailing-argument msg))) (defun action-hook (msg) - (output-event msg :action - (subseq (trailing-argument msg) - 8 + (output-event msg :action (first (arguments msg)) + (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))) + (output-event msg :nick nil (trailing-argument msg))) (defun part-hook (msg) - (output-event msg :part "has left" - (first (arguments msg)))) + (output-event msg :part (first (arguments msg)))) (defun quit-hook (msg) - (output-event msg :quit "has quit" (trailing-argument msg))) + (output-event msg :quit (trailing-argument msg))) (defun join-hook (msg) - (output-event msg :join "has joined" - (trailing-argument msg))) + (output-event msg :join (trailing-argument msg))) (defun kick-hook (msg) - (output-event msg :kick "has been kicked from" - (first (arguments msg)))) + (output-event msg :kick (first (arguments msg)))) + +(defun notice-hook (msg) + (output-event msg :notice (first (arguments msg)) (trailing-argument msg))) + +(defun topic-hook (msg) + (output-event msg :topic (first (arguments msg)) (trailing-argument msg))) + +(defun mode-hook (msg) + (output-event msg :mode (first (arguments msg)))) (defun make-channels (names formats output) (loop for i from 0 to (1- (length names)) @@ -327,6 +302,10 @@ :current-output-names (make-array (length formats) :initial-element nil)))) +(defun is-unichannel-output (user-output) + "Returns T if output is setup for a single channel directory structure." + (and (pathnamep user-output) (null (pathname-name user-output)))) + (defun create-logger (nick server &key channels output (logging-stream t) (async t) @@ -350,7 +329,8 @@ :server server :channels (make-channels channels formats output) :user-output output - :formats formats))) + :formats formats + :unichannel (is-unichannel-output output)))) (mapc #'(lambda (channel) (join conn channel)) channels) (add-hook conn 'irc::irc-privmsg-message 'privmsg-hook) @@ -360,6 +340,9 @@ (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) + (add-hook conn 'irc::irc-mode-message 'mode-hook) + (add-hook conn 'irc::irc-topic-message 'topic-hook) + (add-hook conn 'irc::irc-notice-message 'notice-hook) (cond (async #+sbcl (add-asynchronous-message-handler conn) @@ -400,5 +383,9 @@ :async async :formats formats))) (push logger *loggers*) logger)) - +(defun add-hook-logger (logger msg hook) + (add-hook (connection logger) msg hook)) + +(defun remove-hook-logger (logger msg) + (remove-hook (connection logger) msg)) From krosenberg at common-lisp.net Tue Dec 16 21:29:13 2003 From: krosenberg at common-lisp.net (Kevin Rosenberg) Date: Tue, 16 Dec 2003 16:29:13 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/debian/changelog net-nittin-irc/debian/compat net-nittin-irc/debian/control net-nittin-irc/debian/copyright net-nittin-irc/debian/postinst net-nittin-irc/debian/prerm net-nittin-irc/debian/rules Message-ID: Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/debian In directory common-lisp.net:/tmp/cvs-serv4333/debian Added Files: changelog compat control copyright postinst prerm rules Log Message: add cl-irc.asd file for new name, add debian packaging files Date: Tue Dec 16 16:29:12 2003 Author: krosenberg From krosenberg at common-lisp.net Tue Dec 16 21:29:12 2003 From: krosenberg at common-lisp.net (Kevin Rosenberg) Date: Tue, 16 Dec 2003 16:29:12 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/cl-irc.asd net-nittin-irc/CREDITS net-nittin-irc/package.lisp Message-ID: Update of /project/net-nittin-irc/cvsroot/net-nittin-irc In directory common-lisp.net:/tmp/cvs-serv4333 Modified Files: CREDITS package.lisp Added Files: cl-irc.asd Log Message: add cl-irc.asd file for new name, add debian packaging files Date: Tue Dec 16 16:29:12 2003 Author: krosenberg Index: net-nittin-irc/CREDITS diff -u net-nittin-irc/CREDITS:1.2 net-nittin-irc/CREDITS:1.3 --- net-nittin-irc/CREDITS:1.2 Sat Nov 22 13:40:36 2003 +++ net-nittin-irc/CREDITS Tue Dec 16 16:29:12 2003 @@ -1,3 +1,4 @@ Erik Enge Brian Mastenbrook Jochen Schmidt +Kevin Rosenberg Index: net-nittin-irc/package.lisp diff -u net-nittin-irc/package.lisp:1.12 net-nittin-irc/package.lisp:1.13 --- net-nittin-irc/package.lisp:1.12 Tue Dec 16 13:57:36 2003 +++ net-nittin-irc/package.lisp Tue Dec 16 16:29:12 2003 @@ -1,4 +1,4 @@ -;;;; $Id: package.lisp,v 1.12 2003/12/16 18:57:36 krosenberg Exp $ +;;;; $Id: package.lisp,v 1.13 2003/12/16 21:29:12 krosenberg Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/package.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -9,7 +9,7 @@ (eval-when (:execute :load-toplevel :compile-toplevel) (defpackage :net-nittin-irc (:use :cl) - (:nicknames :irc) + (:nicknames :irc :cl-irc) (:export :read-message-loop :read-message :add-asynchronous-message-handler From krosenberg at common-lisp.net Tue Dec 16 21:41:52 2003 From: krosenberg at common-lisp.net (Kevin Rosenberg) Date: Tue, 16 Dec 2003 16:41:52 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/example/irc-logger.asd net-nittin-irc/example/logger.lisp Message-ID: Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv9612 Removed Files: irc-logger.asd logger.lisp Log Message: move to http://files.b9.com/irc-logger/ Date: Tue Dec 16 16:41:46 2003 Author: krosenberg From krosenberg at common-lisp.net Tue Dec 16 22:45:54 2003 From: krosenberg at common-lisp.net (Kevin Rosenberg) Date: Tue, 16 Dec 2003 17:45:54 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/package.lisp net-nittin-irc/protocol.lisp Message-ID: Update of /project/net-nittin-irc/cvsroot/net-nittin-irc In directory common-lisp.net:/tmp/cvs-serv7798 Modified Files: package.lisp protocol.lisp Log Message: add read-message-loop-background function Date: Tue Dec 16 17:45:54 2003 Author: krosenberg Index: net-nittin-irc/package.lisp diff -u net-nittin-irc/package.lisp:1.13 net-nittin-irc/package.lisp:1.14 --- net-nittin-irc/package.lisp:1.13 Tue Dec 16 16:29:12 2003 +++ net-nittin-irc/package.lisp Tue Dec 16 17:45:54 2003 @@ -1,4 +1,4 @@ -;;;; $Id: package.lisp,v 1.13 2003/12/16 21:29:12 krosenberg Exp $ +;;;; $Id: package.lisp,v 1.14 2003/12/16 22:45:54 krosenberg Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/package.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -12,6 +12,7 @@ (:nicknames :irc :cl-irc) (:export :read-message-loop :read-message + :read-message-loop-background :add-asynchronous-message-handler :send-message :server-name Index: net-nittin-irc/protocol.lisp diff -u net-nittin-irc/protocol.lisp:1.25 net-nittin-irc/protocol.lisp:1.26 --- net-nittin-irc/protocol.lisp:1.25 Tue Dec 16 13:57:36 2003 +++ net-nittin-irc/protocol.lisp Tue Dec 16 17:45:54 2003 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.25 2003/12/16 18:57:36 krosenberg Exp $ +;;;; $Id: protocol.lisp,v 1.26 2003/12/16 22:45:54 krosenberg Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/protocol.lisp,v $ ;;;; See LICENSE for licensing information. @@ -130,9 +130,22 @@ message))) ; needed because of the "loop while" in read-message-loop (stream-error () (setf read-more-p nil))))) -(defmethod read-message-loop ((connection connection)) +(defvar *background-count* 0) +(defmethod read-message-loop-background ((connection connection)) "Read messages from the `connection', parse them and dispatch irc-message-event on them." + (flet ((do-loop () (read-message-loop connection))) + (let ((name (format nil "irc-hander-~D" (incf *background-count*)))) + (cond + (async + #+allegro (mp:process-run-function name #'do-loop) + #+cmu (mp:make-process #'do-loop :name name) + #+lispworks (mp:process-run-function name nil #'do-loop) + #+sbcl-thread (sb-thread:make-thread #'do-loop) + #+(and sbcl (not sbcl-thread)) (add-asynchronous-message-handler + connection)))))) + +(defmethod read-message-loop ((connection connection)) (loop while (read-message connection))) (defmethod read-irc-message ((connection connection)) From bmastenbrook at common-lisp.net Tue Dec 16 23:18:02 2003 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Tue, 16 Dec 2003 18:18:02 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/example/cliki.lisp Message-ID: Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv20742 Modified Files: cliki.lisp Log Message: Just in case commit Date: Tue Dec 16 18:18:02 2003 Author: bmastenbrook Index: net-nittin-irc/example/cliki.lisp diff -u net-nittin-irc/example/cliki.lisp:1.7 net-nittin-irc/example/cliki.lisp:1.8 --- net-nittin-irc/example/cliki.lisp:1.7 Mon Dec 15 18:11:12 2003 +++ net-nittin-irc/example/cliki.lisp Tue Dec 16 18:18:01 2003 @@ -1,4 +1,4 @@ -;;;; $Id: cliki.lisp,v 1.7 2003/12/15 23:11:12 bmastenbrook Exp $ +;;;; $Id: cliki.lisp,v 1.8 2003/12/16 23:18:01 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. @@ -133,7 +133,7 @@ (defparameter *cliki-attention-prefix* "minion: ") -(defparameter *cliki-bot-help* "The minion bot supplies small definitions and performs lookups on CLiki. To use it, try ``minion: term?''. To add a term for IRC, try saying ``minion: add \"term\" as: definition''; otherwise, edit the corresponding CLiki page.") +(defparameter *cliki-bot-help* "The minion bot supplies small definitions and performs lookups on CLiki. To use it, try ``minion: term?''. To add a term for IRC, try saying ``minion: add \"term\" as: definition'' or ``minion: alias \"term\" as: term''; otherwise, edit the corresponding CLiki page.") (defun cliki-lookup (term-with-question) (let ((first-pass (regex-replace-all "^(\\s*)([^?]+)(\\?*)$" term-with-question "\\2"))) From krosenberg at common-lisp.net Tue Dec 16 23:21:57 2003 From: krosenberg at common-lisp.net (Kevin Rosenberg) Date: Tue, 16 Dec 2003 18:21:57 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/protocol.lisp Message-ID: Update of /project/net-nittin-irc/cvsroot/net-nittin-irc In directory common-lisp.net:/tmp/cvs-serv22463 Modified Files: protocol.lisp Log Message: fix typo Date: Tue Dec 16 18:21:56 2003 Author: krosenberg Index: net-nittin-irc/protocol.lisp diff -u net-nittin-irc/protocol.lisp:1.26 net-nittin-irc/protocol.lisp:1.27 --- net-nittin-irc/protocol.lisp:1.26 Tue Dec 16 17:45:54 2003 +++ net-nittin-irc/protocol.lisp Tue Dec 16 18:21:56 2003 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.26 2003/12/16 22:45:54 krosenberg Exp $ +;;;; $Id: protocol.lisp,v 1.27 2003/12/16 23:21:56 krosenberg Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/protocol.lisp,v $ ;;;; See LICENSE for licensing information. @@ -136,14 +136,12 @@ irc-message-event on them." (flet ((do-loop () (read-message-loop connection))) (let ((name (format nil "irc-hander-~D" (incf *background-count*)))) - (cond - (async - #+allegro (mp:process-run-function name #'do-loop) - #+cmu (mp:make-process #'do-loop :name name) - #+lispworks (mp:process-run-function name nil #'do-loop) - #+sbcl-thread (sb-thread:make-thread #'do-loop) - #+(and sbcl (not sbcl-thread)) (add-asynchronous-message-handler - connection)))))) + #+allegro (mp:process-run-function name #'do-loop) + #+cmu (mp:make-process #'do-loop :name name) + #+lispworks (mp:process-run-function name nil #'do-loop) + #+sbcl-thread (sb-thread:make-thread #'do-loop) + #+(and sbcl (not sbcl-thread)) (add-asynchronous-message-handler + connection)))) (defmethod read-message-loop ((connection connection)) (loop while (read-message connection))) From krosenberg at common-lisp.net Tue Dec 16 23:27:25 2003 From: krosenberg at common-lisp.net (Kevin Rosenberg) Date: Tue, 16 Dec 2003 18:27:25 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/package.lisp net-nittin-irc/protocol.lisp Message-ID: Update of /project/net-nittin-irc/cvsroot/net-nittin-irc In directory common-lisp.net:/tmp/cvs-serv24683 Modified Files: package.lisp protocol.lisp Log Message: remove read-message-loop-background, subsume add-asynchronous-message-handler Date: Tue Dec 16 18:27:25 2003 Author: krosenberg Index: net-nittin-irc/package.lisp diff -u net-nittin-irc/package.lisp:1.14 net-nittin-irc/package.lisp:1.15 --- net-nittin-irc/package.lisp:1.14 Tue Dec 16 17:45:54 2003 +++ net-nittin-irc/package.lisp Tue Dec 16 18:27:25 2003 @@ -1,4 +1,4 @@ -;;;; $Id: package.lisp,v 1.14 2003/12/16 22:45:54 krosenberg Exp $ +;;;; $Id: package.lisp,v 1.15 2003/12/16 23:27:25 krosenberg Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/package.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -12,8 +12,7 @@ (:nicknames :irc :cl-irc) (:export :read-message-loop :read-message - :read-message-loop-background - :add-asynchronous-message-handler + :start-background-message-handler :send-message :server-name :no-such-reply Index: net-nittin-irc/protocol.lisp diff -u net-nittin-irc/protocol.lisp:1.27 net-nittin-irc/protocol.lisp:1.28 --- net-nittin-irc/protocol.lisp:1.27 Tue Dec 16 18:21:56 2003 +++ net-nittin-irc/protocol.lisp Tue Dec 16 18:27:25 2003 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.27 2003/12/16 23:21:56 krosenberg Exp $ +;;;; $Id: protocol.lisp,v 1.28 2003/12/16 23:27:25 krosenberg Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/protocol.lisp,v $ ;;;; See LICENSE for licensing information. @@ -107,16 +107,6 @@ (let ((stream (server-stream connection))) (and (streamp stream) (open-stream-p stream)))) - -(defmethod add-asynchronous-message-handler ((connection connection)) - #+sbcl - (sb-sys:add-fd-handler (sb-bsd-sockets:socket-file-descriptor - (server-socket connection)) - :input (lambda (fd) - (declare (ignore fd)) - (read-message connection))) - #-sbcl - (error "add-asynchronous-message-handler is not supported now on non-SBCL")) (defmethod read-message ((connection connection)) (let ((read-more-p t)) @@ -130,18 +120,22 @@ message))) ; needed because of the "loop while" in read-message-loop (stream-error () (setf read-more-p nil))))) -(defvar *background-count* 0) -(defmethod read-message-loop-background ((connection connection)) +(defvar *process-count* 0) +(defmethod start-background-message-handler ((connection connection)) "Read messages from the `connection', parse them and dispatch irc-message-event on them." (flet ((do-loop () (read-message-loop connection))) - (let ((name (format nil "irc-hander-~D" (incf *background-count*)))) + (let ((name (format nil "irc-hander-~D" (incf *process-count*)))) #+allegro (mp:process-run-function name #'do-loop) #+cmu (mp:make-process #'do-loop :name name) #+lispworks (mp:process-run-function name nil #'do-loop) #+sbcl-thread (sb-thread:make-thread #'do-loop) - #+(and sbcl (not sbcl-thread)) (add-asynchronous-message-handler - connection)))) + #+(and sbcl (not sbcl-thread)) + (sb-sys:add-fd-handler (sb-bsd-sockets:socket-file-descriptor + (server-socket connection)) + :input (lambda (fd) + (declare (ignore fd)) + (read-message connection)))))) (defmethod read-message-loop ((connection connection)) (loop while (read-message connection))) From krosenberg at common-lisp.net Tue Dec 16 23:31:17 2003 From: krosenberg at common-lisp.net (Kevin Rosenberg) Date: Tue, 16 Dec 2003 18:31:17 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/protocol.lisp Message-ID: Update of /project/net-nittin-irc/cvsroot/net-nittin-irc In directory common-lisp.net:/tmp/cvs-serv26733 Modified Files: protocol.lisp Log Message: fix typo Date: Tue Dec 16 18:31:17 2003 Author: krosenberg Index: net-nittin-irc/protocol.lisp diff -u net-nittin-irc/protocol.lisp:1.28 net-nittin-irc/protocol.lisp:1.29 --- net-nittin-irc/protocol.lisp:1.28 Tue Dec 16 18:27:25 2003 +++ net-nittin-irc/protocol.lisp Tue Dec 16 18:31:17 2003 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.28 2003/12/16 23:27:25 krosenberg Exp $ +;;;; $Id: protocol.lisp,v 1.29 2003/12/16 23:31:17 krosenberg Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/protocol.lisp,v $ ;;;; See LICENSE for licensing information. @@ -129,7 +129,7 @@ #+allegro (mp:process-run-function name #'do-loop) #+cmu (mp:make-process #'do-loop :name name) #+lispworks (mp:process-run-function name nil #'do-loop) - #+sbcl-thread (sb-thread:make-thread #'do-loop) + #+sb-thread (sb-thread:make-thread #'do-loop) #+(and sbcl (not sbcl-thread)) (sb-sys:add-fd-handler (sb-bsd-sockets:socket-file-descriptor (server-socket connection)) From krosenberg at common-lisp.net Tue Dec 16 23:32:26 2003 From: krosenberg at common-lisp.net (Kevin Rosenberg) Date: Tue, 16 Dec 2003 18:32:26 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/protocol.lisp Message-ID: Update of /project/net-nittin-irc/cvsroot/net-nittin-irc In directory common-lisp.net:/tmp/cvs-serv26938 Modified Files: protocol.lisp Log Message: fix typo Date: Tue Dec 16 18:32:26 2003 Author: krosenberg Index: net-nittin-irc/protocol.lisp diff -u net-nittin-irc/protocol.lisp:1.29 net-nittin-irc/protocol.lisp:1.30 --- net-nittin-irc/protocol.lisp:1.29 Tue Dec 16 18:31:17 2003 +++ net-nittin-irc/protocol.lisp Tue Dec 16 18:32:26 2003 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.29 2003/12/16 23:31:17 krosenberg Exp $ +;;;; $Id: protocol.lisp,v 1.30 2003/12/16 23:32:26 krosenberg Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/protocol.lisp,v $ ;;;; See LICENSE for licensing information. @@ -130,7 +130,7 @@ #+cmu (mp:make-process #'do-loop :name name) #+lispworks (mp:process-run-function name nil #'do-loop) #+sb-thread (sb-thread:make-thread #'do-loop) - #+(and sbcl (not sbcl-thread)) + #+(and sbcl (not sb-thread)) (sb-sys:add-fd-handler (sb-bsd-sockets:socket-file-descriptor (server-socket connection)) :input (lambda (fd) From bmastenbrook at common-lisp.net Thu Dec 18 01:45:40 2003 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Wed, 17 Dec 2003 20:45:40 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/example/clhs.lisp Message-ID: Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv30814 Modified Files: clhs.lisp Log Message: Multiple attention prefixes, s-b-m-h instead of a-a-m-h, misc. changes Date: Wed Dec 17 20:45:39 2003 Author: bmastenbrook Index: net-nittin-irc/example/clhs.lisp diff -u net-nittin-irc/example/clhs.lisp:1.3 net-nittin-irc/example/clhs.lisp:1.4 --- net-nittin-irc/example/clhs.lisp:1.3 Mon Nov 17 09:04:28 2003 +++ net-nittin-irc/example/clhs.lisp Wed Dec 17 20:45:39 2003 @@ -1,4 +1,4 @@ -;;;; $Id: clhs.lisp,v 1.3 2003/11/17 14:04:28 bmastenbrook Exp $ +;;;; $Id: clhs.lisp,v 1.4 2003/12/18 01:45:39 bmastenbrook Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/example/clhs.lisp,v $ ;;;; clhs.lisp - an example IRC bot for net-nittin-irc @@ -20,7 +20,7 @@ (in-package :clhs) ;;; CLHS. This will be the default lookup. -(defparameter *hyperspec-pathname* #p"/home/chandler/public_html/HyperSpec/") +(defparameter *hyperspec-pathname* #p"/Users/chandler/Sites/HyperSpec/") (defparameter *hyperspec-map-file* (merge-pathnames "Data/Map_Sym.txt" *hyperspec-pathname*)) @@ -31,7 +31,7 @@ (defparameter *mop-root* "http://www.alu.org/mop/") -(defparameter *table* (make-hash-table :test 'equalp)) +(defvar *table* (make-hash-table :test 'equalp)) (defun add-clhs-section-to-table (&rest numbers) (let ((key (format nil "~{~d~^.~}" numbers)) @@ -142,30 +142,34 @@ it (format nil "Nothing was found for: ~A" str))) -(defparameter *clhs-attention-prefix* "clhs ") +(defparameter *clhs-attention-prefixes* '("clhs " "clhs: ")) + +(defun valid-clhs-message-1 (message prefix) + (if (eql (search prefix (trailing-argument message) :test #'char-equal) 0) + (and (not (find #\space (trailing-argument message) :start (length prefix))) + (length prefix)) + nil)) (defun valid-clhs-message (message) - (if (eql (search *clhs-attention-prefix* (trailing-argument message) :test #'char-equal) 0) - (not (find #\space (trailing-argument message) :start (length *clhs-attention-prefix*))) - nil)) + (some #'(lambda (e) (valid-clhs-message-1 message e)) *clhs-attention-prefixes*)) (defun msg-hook (message) (if (string-equal (first (arguments message)) *clhs-nickname*) - (if (valid-clhs-message message) - (privmsg *clhs-connection* (source message) (spec-lookup (subseq (trailing-argument message) (length *clhs-attention-prefix*)))) + (aif (valid-clhs-message message) + (privmsg *clhs-connection* (source message) (spec-lookup (subseq (trailing-argument message) it))) (privmsg *clhs-connection* (source message) (spec-lookup (trailing-argument message)))) - (if (valid-clhs-message message) - (privmsg *clhs-connection* (first (arguments message)) (spec-lookup (subseq (trailing-argument message) (length *clhs-attention-prefix*))))))) + (aif (valid-clhs-message message) + (privmsg *clhs-connection* (first (arguments message)) (spec-lookup (subseq (trailing-argument message) it)))))) (defun start-clhs-bot (nick server &rest channels) (populate-table) (setf *clhs-nickname* nick) (setf *clhs-connection* (connect :nickname *clhs-nickname* :server server)) (mapcar #'(lambda (channel) (join *clhs-connection* channel)) channels) - (add-hook *clhs-connection* 'irc::irc-privmsg-message #'msg-hook) - #+sbcl (add-asynchronous-message-handler *clhs-connection*) + (add-hook *clhs-connection* 'irc::irc-privmsg-message 'msg-hook) + #+sbcl (start-background-message-handler *clhs-connection*) #-sbcl (read-message-loop *clhs-connection*)) (defun shuffle-hooks () (irc::remove-hooks *clhs-connection* 'irc::irc-privmsg-message) - (add-hook *clhs-connection* 'irc::irc-privmsg-message #'msg-hook)) + (add-hook *clhs-connection* 'irc::irc-privmsg-message 'msg-hook)) From bmastenbrook at common-lisp.net Thu Dec 18 01:46:00 2003 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Wed, 17 Dec 2003 20:46:00 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/example/cliki.lisp Message-ID: Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv31020 Modified Files: cliki.lisp Log Message: s-b-m-h instead of a-a-m-h Date: Wed Dec 17 20:46:00 2003 Author: bmastenbrook Index: net-nittin-irc/example/cliki.lisp diff -u net-nittin-irc/example/cliki.lisp:1.8 net-nittin-irc/example/cliki.lisp:1.9 --- net-nittin-irc/example/cliki.lisp:1.8 Tue Dec 16 18:18:01 2003 +++ net-nittin-irc/example/cliki.lisp Wed Dec 17 20:46:00 2003 @@ -1,4 +1,4 @@ -;;;; $Id: cliki.lisp,v 1.8 2003/12/16 23:18:01 bmastenbrook Exp $ +;;;; $Id: cliki.lisp,v 1.9 2003/12/18 01:46:00 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. @@ -182,7 +182,7 @@ (mapcar #'(lambda (channel) (join *cliki-connection* channel)) channels) (add-hook *cliki-connection* 'irc::irc-privmsg-message 'msg-hook) (add-hook *cliki-connection* 'irc::irc-notice-message 'notice-hook) - #+sbcl (add-asynchronous-message-handler *cliki-connection*) + #+sbcl (start-background-message-handler *cliki-connection*) #-sbcl (read-message-loop *cliki-connection*)) (defun shuffle-hooks () From krosenberg at common-lisp.net Thu Dec 18 19:28:31 2003 From: krosenberg at common-lisp.net (Kevin Rosenberg) Date: Thu, 18 Dec 2003 14:28:31 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/package.lisp net-nittin-irc/protocol.lisp Message-ID: Update of /project/net-nittin-irc/cvsroot/net-nittin-irc In directory common-lisp.net:/tmp/cvs-serv8388 Modified Files: package.lisp protocol.lisp Log Message: add stop-background-message-handler function Date: Thu Dec 18 14:28:30 2003 Author: krosenberg Index: net-nittin-irc/package.lisp diff -u net-nittin-irc/package.lisp:1.15 net-nittin-irc/package.lisp:1.16 --- net-nittin-irc/package.lisp:1.15 Tue Dec 16 18:27:25 2003 +++ net-nittin-irc/package.lisp Thu Dec 18 14:28:28 2003 @@ -1,4 +1,4 @@ -;;;; $Id: package.lisp,v 1.15 2003/12/16 23:27:25 krosenberg Exp $ +;;;; $Id: package.lisp,v 1.16 2003/12/18 19:28:28 krosenberg Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/package.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -13,6 +13,7 @@ (:export :read-message-loop :read-message :start-background-message-handler + :stop-background-message-handler :send-message :server-name :no-such-reply Index: net-nittin-irc/protocol.lisp diff -u net-nittin-irc/protocol.lisp:1.30 net-nittin-irc/protocol.lisp:1.31 --- net-nittin-irc/protocol.lisp:1.30 Tue Dec 16 18:32:26 2003 +++ net-nittin-irc/protocol.lisp Thu Dec 18 14:28:29 2003 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.30 2003/12/16 23:32:26 krosenberg Exp $ +;;;; $Id: protocol.lisp,v 1.31 2003/12/18 19:28:29 krosenberg Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/protocol.lisp,v $ ;;;; See LICENSE for licensing information. @@ -123,7 +123,7 @@ (defvar *process-count* 0) (defmethod start-background-message-handler ((connection connection)) "Read messages from the `connection', parse them and dispatch -irc-message-event on them." +irc-message-event on them. Returns background process ID if available." (flet ((do-loop () (read-message-loop connection))) (let ((name (format nil "irc-hander-~D" (incf *process-count*)))) #+allegro (mp:process-run-function name #'do-loop) @@ -136,6 +136,13 @@ :input (lambda (fd) (declare (ignore fd)) (read-message connection)))))) + +(defun stop-backgound-message-handler (process) + "Stops a background message handler process returned by the start function." + #+cmu (mp:destroy-process process) + #+allegro (mp:process-kill process) + #+sb-thread (sb-thread:destroy-thread process) + #+lispworks (mp:process-kill process)) (defmethod read-message-loop ((connection connection)) (loop while (read-message connection))) From krosenberg at common-lisp.net Thu Dec 18 19:43:09 2003 From: krosenberg at common-lisp.net (Kevin Rosenberg) Date: Thu, 18 Dec 2003 14:43:09 -0500 Subject: [net-nittin-irc-cvs] CVS update: net-nittin-irc/protocol.lisp Message-ID: Update of /project/net-nittin-irc/cvsroot/net-nittin-irc In directory common-lisp.net:/tmp/cvs-serv17171 Modified Files: protocol.lisp Log Message: fix typo in function name Date: Thu Dec 18 14:43:09 2003 Author: krosenberg Index: net-nittin-irc/protocol.lisp diff -u net-nittin-irc/protocol.lisp:1.31 net-nittin-irc/protocol.lisp:1.32 --- net-nittin-irc/protocol.lisp:1.31 Thu Dec 18 14:28:29 2003 +++ net-nittin-irc/protocol.lisp Thu Dec 18 14:43:08 2003 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.31 2003/12/18 19:28:29 krosenberg Exp $ +;;;; $Id: protocol.lisp,v 1.32 2003/12/18 19:43:08 krosenberg Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/protocol.lisp,v $ ;;;; See LICENSE for licensing information. @@ -137,7 +137,7 @@ (declare (ignore fd)) (read-message connection)))))) -(defun stop-backgound-message-handler (process) +(defun stop-background-message-handler (process) "Stops a background message handler process returned by the start function." #+cmu (mp:destroy-process process) #+allegro (mp:process-kill process)