[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 19:30:47 UTC 2003
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'><</span><span class='source'>~A</span><span class='brack'>></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'><</span><span class='subject'>~A</span><span class='brack'>></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
More information about the Net-nittin-irc-cvs
mailing list