[net-nittin-irc-cvs] CVS update: net-nittin-irc/example/logger.lisp net-nittin-irc/example/irclogs.css
Kevin Rosenberg
krosenberg at common-lisp.net
Tue Dec 16 21:19:56 UTC 2003
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
- "<?xml version='1.0' ?>~%<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">~%")
- (format stream
- "<html xmlns='http://www.w3.org/1999/xhtml'>~%<head>~%<title>~A</title>~%<link rel='stylesheet' href='/irclogs.css' type='text/css' />~%</head>~%<body id='body'>~%<table><tbody>~%"
- (html-title channel-name)))))
-
-(defun write-file-footer (format stream)
- (case format
- (:html
- (format stream "</tbody></table></body></html>~%"))))
+(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 href='~A'>~A</a>" item item)
- (write-string item stream)))))))
-
(defun user-address (msg)
(let ((split (split *user-address-scanner* (raw-message-string msg)
:with-registers-p t)))
@@ -212,108 +183,112 @@
(second split)
"")))
-(defun %output-event (stream format utime type source text object user-address)
- (case format
- (:html
- (write-string "<tr><td class='time'>" stream)
- (write-string (format-utime utime) stream)
- (write-string "</td> " stream)
- (case type
- (:privmsg
- (format stream "<td><span class='brack'><</span><span class='source'>~A</span><span class='brack'>></span></td><td class='msg'>~A</td>"
- source (activate-uris text)))
- (:action
- (format stream
- "<td><span class='action-brack'>*</span><span class='action-name'>~A</span><span class='action-brack'>*</span> <span class='action-msg'>~A</span></td>"
- source (activate-uris text)))
- (t
- (format stream "<td><span class='info-source'>~A</span> <span class='info-brack'>[</span><span class='user-address'>~A</span><span class='info-brack'>]</span> <span class='info-msg'>~A</span>"
- source user-address text)
- (when object
- (case type
- (:quit
- (format stream " <span class='info-brack'>[</span><span class='info-object'>~A</span><span class='info-brack'>]</span>"
- object))
- (t
- (format stream " <span class='info-object'>~A</span>" object))))
- (write-string "</td>" stream)
- ))
- (write-string "</tr>" 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))
More information about the Net-nittin-irc-cvs
mailing list