[net-nittin-irc-cvs] CVS update: net-nittin-irc/example/logger.lisp
Kevin Rosenberg
krosenberg at common-lisp.net
Mon Dec 15 18:16:40 UTC 2003
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
More information about the Net-nittin-irc-cvs
mailing list