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) "</body></html>~%"))))

-(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 "<div><span class='time'>" stream) + (write-string (format-utime utime) stream) + (write-string "</span> " stream) + (case type + (:privmsg + (format stream "<span class='brack'>&lt;</span><span class='source'>~A</span><span class='brack'>&gt;</span> <span class='msg'>~A</span>" + 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>" + 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>" + 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)))))) + (format stream "</div>~%")) + (: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 "<div><span class='time'>" stream) - (write-string (format-time (received-time msg)) stream) - (write-string "</span> " stream) - (case type - (:privmsg - (format stream "<span class='brack'>&lt;</span><span class='subject'>~A</span><span class='brack'>&gt;</span> <span class='msg'>~A</span>" - 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>" - source (activate-uris text))) - (t - (format stream "<span class='info-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 - (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)))))) - (format stream "</div>~%")) - (: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