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 "<?xml version='1.0' ?>~%<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">~%") - (format (elt (streams channel) istream) "<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'>~%" - (html-title channel))))) + (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 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) "</body></html>~%")))) + (format stream "</tbody></table></body></html>~%"))))
(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 "<div><span class='time'>" stream) + (write-string "<tr><td class='time'>" stream) (write-string (format-utime utime) stream) - (write-string "</span> " stream) + (write-string "</td> " stream) (case type (:privmsg - (format stream "<span class='brack'><</span><span class='source'>~A</span><span class='brack'>></span> <span class='msg'>~A</span>" + (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 - "<span class='action-brack'>*</span><span class='action-name'>~A</span><span class='action-brack'>*</span> <span class='action-msg'>~A</span>" + "<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 "<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>" + (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 @@ -213,8 +235,11 @@ (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)))))) - (format stream "</div>~%")) + (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 @@ -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