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