Which one? The IRC one or a MoveableType file?
IRC One
#! /usr/bin/perl
BEGIN {
use CGI::Carp qw(carpout);
use diagnostics;
open(LOG, ">errors.txt");
carpout(LOG);
close(LOG);
}
my $BSD_STYLE_LICENSE = <<'EOF';
Copyright (c) 2007, Jason Fesler
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
Neither the name Jason Fesler nor the names of its
contributors may be used to endorse or promote products derived from
this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
EOF
use Net::IRCService;
use Net::IRCService::DB;
use YAML::Syck; # Human readable, used for config
use JSON::Syck; # Machine compact, for machine readable log
use Text::Wrap;
use strict;
use FileCache maxopen => 100;
use POSIX qw(strftime tzset);
my $VERSION = "0.10";
##########################################################################
# WARNING #
##########################################################################
# my_* functions will be called BEFORE Net::IRCService::DB functions #
# will due to our local functions being registered before DB functions. #
# Unfortunately, DB functions can only be registered AFTER we init #
# Net::IRCService; and I want to have all hooks in place before then. #
##########################################################################
my $YAML = "$0.yaml";
my %yaml; # $0.yaml config
my @bots; # Array of yaml->bots
my %bots; # Copy of yaml->bots
my %joined; # Bots track where they joined
my %topics; # track topic changes
my %topics_by; # And who made them
my %my_EK_count; # How many times any one op killed me
my $db = new Net::IRCService::DB;
my $statusbar = '-\|/';
my $statuscount = 0;
$| = 1;
init();
main_loop();
######################################################
# Function declarations #
######################################################
# I'm a bit inconsistent on where I use these.
sub print_tty(@);
######################################################
# Configuration and Init related #
######################################################
sub _lc($) {
my $nick = shift;
$nick =~ tr/[]\\/{}|/;
return lc($nick);
}
sub init {
load_yaml();
log_init();
copy_event_numbers();
&init_service( %{ $yaml{"connection"} } );
} ## end sub init
sub load_yaml {
my $ref = LoadFile($YAML) or die "$!";
%yaml = %{$ref};
after_yaml();
}
sub save_yaml {
DumpFile( "$YAML.$$", \%yaml );
if ( -s "$YAML.$$" ) {
rename( "$YAML.$$", "$YAML" );
} else {
warn "Failed to create a useful $YAML.$$";
}
after_yaml();
} ## end sub save_yaml
sub after_yaml {
@bots = keys %{ $yaml{"bots"} };
%bots = map { $_ => 1 } @bots;
}
my %eventnumbers;
sub copy_event_numbers {
foreach my $e ( keys %Net::IRCService:: ) {
if ( $e =~ /^EVENT_/ ) {
no strict "refs";
my $f = "Net::IRCService::$e";
eval {
# Do not error. Just try it, and let exceptions go silent.
my $fvalue = &$f();
$eventnumbers{$fvalue} = $e;
# Prepare debugging function
my $d = "debug_$e";
my $perl = "sub $d { my_ALLDEBUG('$e',\@_) }";
eval $perl;
die $@ if $@;
my $m = "my_$e";
if ( defined( &{$m} ) ) {
# Add local function to chain if found
add_event_handler( &$f(), \&$m );
} else {
# Add debugging function to chain to show uncaught events
add_event_handler( &$f(), \&$d );
}
};
} ## end if ( $e =~ /^EVENT_/ )
} ## end foreach my $e ( keys %Net::IRCService::)
} ## end sub copy_event_numbers
######################################################
# IRC server events #
######################################################
sub print_tty(@) {
print @_ if ( -t STDOUT );
}
sub my_ALLDEBUG {
my $e = shift @_;
$e = $eventnumbers{$e} if ( exists $eventnumbers{$e} );
return if ( ( $e eq "EVENT_DEBUG" ) && grep( /irc_send_now/, @_ ) );
print_tty "\e[1;31m" if ( $e eq "EVENT_RAW_IN" );
print_tty "\e[1;33m" if ( $e eq "EVENT_RAW_OUT" );
print_tty "\e[0;33m" if ( $e eq "EVENT_SEND" );
print_tty "\e[0;33m" if ( $e eq "EVENT_SEND_NOW" );
local $YAML::Syck::Headless = 1;
if ( scalar @_ <= 1 ) {
print "$e\: @_\n";
} else {
print Dump( { $e => \@_ } );
}
print_tty "\e[0m";
} ## end sub my_ALLDEBUG
sub my_EVENT_DEBUG { }
sub my_EVENT_RAW_IN { }
sub my_EVENT_RAW_OUT { }
sub my_EVENT_RAW_SEND { }
sub my_EVENT_SEND { }
sub my_EVENT_SEND_NOW { }
sub my_EVENT_RAW_SENDNOW { }
sub my_EVENT_CAPAB { }
sub my_EVENT_MODE { }
sub my_EVENT_SERVER { }
sub my_EVENT_SNICK { }
sub my_EVENT_PING { }
sub my_EVENT_INIT { }
# idle loop
sub my_EVENT_DO_ONE_LOOP {
$statuscount++;
if ( -t STDOUT && -t STDERR ) {
die "what statusbar=$statusbar" unless ( length($statusbar) );
print STDERR substr( $statusbar, $statuscount % length($statusbar), 1 );
print STDERR "\r";
}
if ( ( $statuscount % 10 ) == 0 ) {
logbot_periodic();
}
} ## end sub my_EVENT_DO_ONE_LOOP
sub my_EVENT_DISCONNECTED {
print "Server has disconnected, we need to clear all state.\n";
print "Cheating and just exiting instead.\n";
print "Run this under daemontools.\n";
exit;
} ## end sub my_EVENT_DISCONNECTED
sub my_EVENT_CONNECTED {
$db->init(); # Start tracking users, channels, etc.
}
sub my_EVENT_SVINFO {
bot_connect($_) foreach (@bots); # Connect our bots
}
sub my_EVENT_SSJOIN {
my ( $server, $ts, $channel, $mode, $nick ) = @_;
logbot_do_logging( "JOIN", $nick, $channel, "" );
bots_join($channel);
}
sub my_EVENT_PART {
my ( $nick, $channel, $message ) = @_;
$message ||= "";
logbot_do_logging( "PART", $nick, $channel, $message );
$nick = _lc $nick;
$channel = lc $channel;
$DB::single = 1;
my (@users) = grep( lc $_ ne $nick, $db->channel_get_users($channel) );
if ( !scalar @users ) {
# The bots are the last here. We are no longer needed.
foreach (@bots) {
bot_part( $_, $channel );
}
delete $topics{$channel};
} ## end if ( !scalar @users )
} ## end sub my_EVENT_PART
sub my_EVENT_QUIT {
my ($nick) = @_;
foreach my $channel ( get_user_channels($nick) ) {
print
"EVENT_QUIT: Caling my_EVENT_PART($nick,$channel,Client quit IRC)\n";
my_EVENT_PART( $nick, $channel, "Client quit IRC" );
}
} ## end sub my_EVENT_QUIT
sub my_EVENT_CTOPIC {
my ( $nick, $channel, $topic ) = @_;
logbot_do_logging( "TOPIC", $nick, $channel, $topic );
$topics{ lc $channel } = @_;
$topics_by{ lc $channel } = $nick;
} ## end sub my_EVENT_CTOPIC
sub my_EVENT_KILL {
my ( $nick, $bot ) = @_;
$nick = _lc $nick;
$bot = _lc $bot;
if ( exists $bots{$bot} ) {
bot_connect($bot);
bot_say( $bot, $nick,
"Please do not kill the bot. It reincarnates and you do not." );
if ( $my_EK_count{$nick}++ > 2 ) {
bot_kill(
$bot,
$nick,
"Please do not kill the bot. It reincarnates and you do not."
);
} ## end if ( $my_EK_count{$nick...
foreach my $channel ( $db->channel_list ) {
logbot_do_logging( "KILL", $bot, $channel,
"Bot killed by $nick but reincarnating" );
$joined{$bot}{$channel} = 0;
bots_join($channel);
} ## end foreach my $channel ( $db->channel_list)
} ## end if ( exists $bots{$bot...
} ## end sub my_EVENT_KILL
sub my_EVENT_KICK {
my ( $nick, $channel, $bot ) = @_;
my ( $kicker, $channel, $kickee ) = @_;
$nick = _lc $nick;
$bot = _lc $bot;
if ( exists $bots{$bot} ) {
# We got kicked, dude!
logbot_do_logging( "KICK", $bot, $channel,
"Kicked by $nick - considering this an uninvite" );
$joined{$bot}{$channel} = 0;
# Treat like uninvited:
$yaml{bots}{$bot}{"channels"}{$channel} = 0;
save_yaml();
bot_say( $bot, $nick, "Use /invite $bot $channel to bring me back." );
bot_say(
$bot,
$nick,
"Or use /msg $bot join $channel if your client does not do invites"
);
} ## end if ( exists $bots{$bot...
else {
logbot_do_logging( "KICK", $kicker, $channel, "kicked $kickee" );
my_EVENT_PART( $kickee, $channel, "kicked by $kicker" );
}
} ## end sub my_EVENT_KICK
sub my_EVENT_WHOIS {
my ( $nick, $bot, $crap ) = @_;
$nick = _lc $nick;
$bot = _lc $bot;
my $s = $yaml{connection}{SERVER_NAME};
irc_send("311 $nick $bot $s * :services bot uses Net::IRCService");
irc_send("318 $nick :Nosy bugger aren't you");
} ## end sub my_EVENT_WHOIS
sub my_EVENT_PRIVMSG {
my ( $nick, $towho, $string ) = @_;
if ( $towho =~ /^#/ ) {
logbot_do_logging( "PRIVMSG", $nick, $towho, $string );
}
$nick = _lc $nick;
$towho = lc $towho;
if ( exists $bots{$towho} ) {
if ( $string =~ m#\x01PING# ) {
$string =~ s#PING#PONG#;
bot_say( $towho, $nick, $string );
return;
}
} ## end if ( exists $bots{$towho...
# We still don't know if this is a message to me
my $tome;
my $replyto;
if ( $towho =~ m/^#/ ) {
# Really a channel
( $tome, $string ) = split( /[ :]+/, $string );
if ( exists $bots{ lc $tome } ) {
$replyto = $towho;
} else {
return; # Not a message to me.
}
} else {
if ( exists $bots{$towho} ) {
$tome = $towho;
$replyto = $nick;
} else {
return;
}
} ## end else [ if ( $towho =~ m/^#/ )
my $bot = $tome;
# $tome = my name
# $nick = requestor
# $replyto = how to reply
my (@words) = split( /\s+/, $string );
if ( ( $replyto =~ m/^#/ ) && ( $string =~ /^(part|leave)\s*$/i ) ) {
# Leave this channel.
bot_say( $bot, $replyto, "/invite $bot to bring back" );
bot_uninvited( $bot, $replyto );
return;
} ## end if ( ( $replyto =~ m/^#/...
if ( $words[0] =~ /^(join|invite)$/ ) {
if ( $words[1] =~ /^#/ ) {
if ( $db->channel_exists( $words[1] ) ) {
bot_invited( $bot, $words[1] );
} else {
bot_say( $bot, $replyto, "No such channel $words[1]" );
}
} ## end if ( $words[1] =~ /^#/)
return;
} ## end if ( $words[0] =~ /^(join|invite)$/)
my @args = @words;
my $f;
$f = "$bot" . "_" . shift @args;
if ( defined &{$f} ) {
no strict "refs";
return if &$f( $nick, $bot, $replyto, @args );
}
$f = "$bot" . "_" . "unhandled";
if ( defined &{$f} ) {
no strict "refs";
return if &$f( $nick, $bot, $replyto, @words );
}
bot_say( $bot, $replyto, "unknown command \x02$string\x02" );
} ## end sub my_EVENT_PRIVMSG
sub my_EVENT_NOTICE {
my ( $nick, $towho, $string ) = @_;
if ( $towho =~ /^#/ ) {
logbot_do_logging( "NOTICE", $nick, $towho, $string );
}
} ## end sub my_EVENT_NOTICE
sub my_EVENT_CNICK {
my ( $oldnick, $newnick, $ts ) = @_;
# Need to find all channels to log this in.
foreach
my $channel ( get_user_channels($oldnick), get_user_channels($newnick) )
{
logbot_do_logging( "CNICK", $oldnick, $channel,
"nick changed to $newnick" );
} ## end foreach my $channel ( get_user_channels...
} ## end sub my_EVENT_CNICK
sub my_EVENT_AWAY {
my ( $nick, $message ) = @_;
foreach my $channel ( get_user_channels($nick) ) {
logbot_do_logging( "AWAY", $nick, $channel, "Away message: $message" )
if ( $message =~ /./ );
logbot_do_logging( "AWAY", $nick, $channel, "No longer away" )
if ( $message !~ /./ );
} ## end foreach my $channel ( get_user_channels...
} ## end sub my_EVENT_AWAY
sub my_EVENT_UNKNOWN {
my (@stuff) = @_;
my ($stuff) = @_;
if ( $stuff =~ m#^PASS (\S+) TS (\d+)# ) {
irc_send_now("PASS $1 TS $2");
return;
}
if ( $stuff =~ m#^:(\S+) INVITE (\S+) (\#\S+)#i ) {
my ( $nick, $bot, $channel ) = ( $1, $2, $3 );
bot_invited( $2, $3 );
return;
}
if ( $stuff =~ m#^:(\S+) AWAY(.*)# ) {
my ( $nick, $msg ) = ( $1, $2 );
$msg =~ s/^\s+//;
$msg =~ s/^://;
my_EVENT_AWAY( $1, $2 );
return;
} ## end if ( $stuff =~ m#^:(\S+) AWAY(.*)#)
my_ALLDEBUG( "UNKNOWN", @_ );
} ## end sub my_EVENT_UNKNOWN
######################################################
# Helper functions for a bot #
######################################################
sub bot_shouldjoin {
my ( $bot, $channel ) = @_;
$bot = _lc $bot;
$channel = lc $channel;
if ( exists $yaml{"bots"}{$bot}{"channels"}{$channel} ) {
return $yaml{"bots"}{$bot}{"channels"}{$channel};
}
if ( exists $yaml{"bots"}{$bot}{"autojoin"} ) {
foreach my $re ( @{ $yaml{"bots"}{$bot}{"autojoin"} } ) {
return 1 if ( $channel =~ m/$re/ );
}
}
return 0;
} ## end sub bot_shouldjoin
# Scan configs for $channel
# See what bots belong there
# See how many of them are not yet joined.
sub bots_join {
my ($channel) = @_;
my @needbots;
foreach my $bot (@bots) {
if ( !$joined{$bot}{$channel} ) {
push( @needbots, $bot ) if ( bot_shouldjoin( $bot, $channel ) );
}
}
return if ( !@needbots );
my $ts = $db->channel_get_ts($channel);
$ts ||= time;
foreach my $bot (@needbots) {
irc_send("SJOIN $ts $channel + $bot");
$joined{$bot}{$channel} = 1;
logbot_do_logging( "JOIN", $bot, $channel );
if ( $bot eq "logbot" ) {
# Make sure we record who is already in channel once we start logging
my @users = $db->channel_get_users($channel);
if (@users) {
logbot_do_logging( "JOIN", "@users", $channel );
}
# Indicate who we are, and a timestamp
if ( $yaml{options}{introduction} ) {
bot_say( $bot, $channel, $yaml{options}{introduction} );
}
} ## end if ( $bot eq "logbot" )
my $f;
$f = "$bot" . "_" . "joined";
if ( defined &{$f} ) {
no strict "refs";
&{$f}($channel);
}
} ## end foreach my $bot (@needbots)
} ## end sub bots_join
sub bot_connect {
my ($bot) = @_;
my $t = time;
my $s = $yaml{connection}{SERVER_NAME};
irc_send("NICK $bot 0 1 +i ~$bot $s $s :services bot");
} ## end sub bot_connect
sub bot_say {
my ( $bot, $nick, $message ) = @_;
logbot_do_logging( "PRIVMSG", $bot, $nick, $message );
irc_send(":$bot PRIVMSG $nick :$message");
}
sub bot_kill {
my ( $bot, $nick, $message ) = @_;
my $s = $yaml{connection}{SERVER_NAME};
irc_send(":$bot KILL $nick $s\!$nick :$message");
}
sub bot_invited {
my ( $bot, $channel ) = @_;
$bot = _lc $bot;
$channel = lc $channel;
$yaml{bots}{$bot}{"channels"}{$channel} = 1;
bots_join($channel); # Will join if needed
save_yaml();
} ## end sub bot_invited
sub bot_part {
my ( $bot, $channel ) = @_;
$bot = _lc $bot;
$channel = lc $channel;
if ( $joined{$bot}{$channel} ) {
logbot_do_logging( "PART", $bot, $channel );
irc_send(":$bot PART $channel") if ( $joined{$bot}{$channel} );
$joined{$bot}{$channel} = 0;
}
} ## end sub bot_part
sub bot_uninvited {
my ( $bot, $channel ) = @_;
bot_part(@_);
$bot = _lc $bot;
$channel = lc $channel;
$yaml{bots}{$bot}{"channels"}{$channel} = 0;
save_yaml();
} ## end sub bot_uninvited
sub get_user_channels {
my ($nick) = @_;
return () if ( !$db->user_exists($nick) );
my $ref = $db->user_find($nick);
my @ret;
foreach ( keys %{ ${$ref}{channels} } ) {
push( @ret, $_ );
}
@ret = sort @ret;
return @ret;
} ## end sub get_user_channels
######################################################
# logbot specific #
######################################################
sub logbot_help {
my ( $nick, $bot, $replyto, @args ) = @_;
if ( $replyto =~ /^#/ ) {
bot_say(
$bot,
$replyto,
"To have $bot leave, type: \x02$bot\: leave\x02 . You can get the log url with \x02$bot\: url\x02 . For more info, \x02/msg $bot help\x02."
);
} else {
bot_say(
$bot,
$replyto,
"To invite me to a channel, either \x02/msg $bot invite #channel\x02 or, from the channel, \x02/invite $bot\x02"
);
if ( $db->is_oper($nick) ) {
bot_say(
$bot,
$replyto,
"Oper only: \x02/msg $bot showchannels [-v] [-users] [#channel ..]\x02"
);
bot_say(
$bot,
$replyto,
"Oper only: \x02/msg $bot showusers [username ..] [servername ..]\x02"
);
} ## end if ( $db->is_oper($nick...
} ## end else [ if ( $replyto =~ /^#/ )
return 1; # Handled
} ## end sub logbot_help
sub logbot_info {
my ( $nick, $bot, $replyto, @args ) = @_;
my $i = $yaml{options}{introduction};
bot_say( $bot, $replyto, "log-irc.pl $VERSION; this installation: $i", );
return 1; # Handled
} ## end sub logbot_info
sub logbot_version { return &logbot_info(@_); }
sub logbot_time {
my ( $nick, $bot, $replyto, @args ) = @_;
_logbot_ts( "logbot", $replyto );
return 1;
}
sub _logbot_url {
my ($channel) = @_;
my ($name) = logbot_set_basename($channel);
my ($dir) = $yaml{options}{logpath};
substr( $name, 0, length($dir) ) = "";
$name =~ s#^/+##;
my ($urlbase) = $yaml{options}{urlbase};
$urlbase =~ s#/+$##;
$name = "$urlbase/$name";
} ## end sub _logbot_url
my %logbot_url_last;
sub logbot_url {
my ( $nick, $bot, $replyto, @args ) = @_;
if ( $replyto =~ /^#/ ) {
my $url = _logbot_url($replyto);
bot_say( $bot, $replyto, "log file url is \x02 $url \x02" );
$logbot_url_last{ lc $replyto } = $url;
return 1;
} else {
return 0;
}
} ## end sub logbot_url
sub logbot_showchannels {
my ( $nick, $bot, $replyto, @args ) = @_;
# Privately only.
return 0 if ( $replyto =~ m/^#/ );
return 0 unless ( $db->is_oper($nick) );
my %options = map { lc $_ => 1 } @args;
$options{"-channel"} = 1 if ( grep( /^#/, @args ) ); # Limit to a few chans
foreach my $channel ( $db->channel_list ) {
# Sometimes we only want a specific channel
next
if ( ( $options{"-channel"} )
&& ( !exists $options{ lc $channel } ) );
my @show;
my @users = $db->channel_get_users($channel);
my $count = scalar @users;
# Sometimes we want to know who is inside, too.
if ( $options{"-users"} ) {
my @users = $db->channel_get_users($channel);
foreach my $user (@users) {
my $ref = $db->user_find($user);
if ( $db->has_op( $user, $channel ) ) {
$user = '@' . ${$ref}{"nick"};
} elsif ( $db->has_voice( $user, $channel ) ) {
$user = '+' . ${$ref}{"nick"};
}
push( @show, $user );
} ## end foreach my $user (@users)
} ## end if ( $options{"-users"...
@show = sort @show;
unshift( @show, "($count)" );
local ($Text::Wrap::columns) = 400;
if ( $options{"-v"} ) {
$channel =~ s/^#//;
$channel = "#\Q$channel";
}
@show = wrap( "$channel ", "$channel ... ", @show );
foreach (@show) {
chomp;
bot_say( $bot, $nick, $_ );
}
} ## end foreach my $channel ( $db->channel_list)
bot_say( $bot, $nick, "End of showchannels @args" );
return 1;
} ## end sub logbot_showchannels
sub logbot_showusers {
# Sneak a peek into Net::IRCService::DB - no API
my ( $nick, $bot, $replyto, @args ) = @_;
# Privately only.
return 0 if ( $replyto =~ m/^#/ );
return 0 unless ( $db->is_oper($nick) );
my %options = map { lc $_ => 1 } @args;
$options{"-user"} = 1
if ( grep( /^[^-]/, @args ) ); # Limit to a few users or a server
# Copy the hash over.
my @users = $db->user_list;
my %byserver;
foreach my $user (@users) {
my $ref = $db->user_find($user);
my $show = ${$ref}{'nick'}; # As they are known as, not LC
my $server = ${$ref}{'server'}; # Where are are in from
next
if ( ( $options{"-user"} )
&& ( !exists $options{ lc $user } )
&& ( !exists $options{ lc $server } ) );
# nick hops ts mode ident host server geco
$show = "\@$show" if ( $db->is_oper($user) );
$byserver{$server} ||= [];
push( @{ $byserver{$server} }, $show );
} ## end foreach my $user (@users)
foreach my $server ( sort keys %byserver ) {
my @show = @{ $byserver{$server} };
@show = sort @show;
my $count = scalar @show;
unshift( @show, "($count)" );
local ($Text::Wrap::columns) = 400;
@show = wrap( "$server ", "$server ... ", @show );
foreach (@show) {
chomp;
bot_say( $bot, $nick, $_ );
}
} ## end foreach my $server ( sort keys...
bot_say( $bot, $nick, "End of showusers @args" );
return 1;
} ## end sub logbot_showusers
######################################################
# Logging related functions go here. #
######################################################
my @tz = ();
sub log_init {
unless (@tz) {
my $t;
if ( exists $yaml{options}{tz} ) {
$t = $yaml{options}{tz};
if ( !ref $t ) {
$t = [$t];
}
@tz = @{$t};
} ## end if ( exists $yaml{options...
} ## end unless (@tz)
# die "No TZ in config file (options->tz should be scalar or array)"
# unless (@tz);
$ENV{"TZ"} = $tz[0] if (@tz);
tzset();
die "missing options->logpath" unless ( $yaml{options}{logpath} );
die "missing options->urlbase" unless ( $yaml{options}{urlbase} );
die "missing options->periodic" unless ( $yaml{options}{periodic} );
logbot_periodic();
} ## end sub log_init
sub channel_safe {
my ($channel) = @_;
$channel = lc $channel;
$channel =~ s/^#//;
$channel =~ s/[^a-z0-9_-]/_/g;
return $channel;
} ## end sub channel_safe
my ( $year, $month, $day, $hour, $minute );
my ($nextperiodic);
my %filename_cache;
my %did_ts_cache;
sub logbot_periodic {
my $time = time;
my $frequency = $yaml{options}{periodic};
if ( $time > $nextperiodic ) {
# print "logbot_periodic recalculating\n";
$nextperiodic = $time + $frequency - ( $time % $frequency );
$ENV{"TZ"} = $tz[0] if (@tz);
tzset();
( $year, $month, $day, $hour, $minute ) =
split( / /, strftime( '%Y %m %d %H %M', localtime time ) );
%filename_cache = (); # Force recalculation
%did_ts_cache = (); # And channel announcements
} ## end if ( $time > $nextperiodic)
} ## end sub logbot_periodic
sub _logbot_ts {
my ( $bot, $channel ) = @_;
$channel = lc $channel;
my $ts = timestamps();
$did_ts_cache{$channel} = time;
bot_say( $bot, $channel, "time is $ts" );
if ( $channel =~ m/^#/ ) {
my $url = _logbot_url($channel);
if ( $url ne $logbot_url_last{$channel} ) {
bot_say( $bot, $channel, "log file url is now \x02 $url \x02" );
$logbot_url_last{ lc $channel } = $url;
}
} ## end if ( $channel =~ m/^#/)
} ## end sub _logbot_ts
sub logbot_set_basename {
my ($channel) = lc shift @_;
if ( !exists $filename_cache{$channel} ) {
my $channel_safe = channel_safe($channel);
my $dir = $yaml{options}{logpath};
$dir =~ s#/$##; # Trim to known state
my $log = "$dir/$channel_safe/$year/$month";
system( "mkdir", "-p", $log );
$log .= "/$year-$month-$day";
$filename_cache{$channel} = $log;
} ## end if ( !exists $filename_cache...
return $filename_cache{$channel};
} ## end sub logbot_set_basename
sub openfile_txt {
my ($channel) = lc shift @_;
return cacheout ">>", logbot_set_basename($channel) . ".txt";
}
sub openfile_machine {
my ($channel) = lc shift @_;
return cacheout ">>", logbot_set_basename($channel) . ".machine";
}
sub logbot_do_logging {
my ( $event, $nick, $channel, $message ) = @_;
$nick = _lc $nick;
my $onick = $nick;
if ( $nick =~ /^[@\+]/ ) {
$nick =~ s/^[@\+]//;
} else {
if ( $db->is_member( $nick, $channel ) ) {
$onick = ( $db->has_op( $nick, $channel ) ? '@' : '' ) . $nick;
}
}
$channel = lc $channel;
no strict "refs";
if ( $joined{"logbot"}{ lc $channel } ) {
my $fresh = !exists $filename_cache{$channel};
my $fh_mac = openfile_machine($channel);
my $fh_txt = openfile_txt($channel);
if ($fresh) {
$fh_mac->autoflush(1);
$fh_txt->autoflush(1);
}
# Machine parsable
print $fh_mac JSON::Syck::Dump(
{
"time" => time,
"event" => $event,
"nick" => $onick,
"channel" => $channel,
"message" => $message
}
) . "\n";
# Human readable
my $time = strftime( '%H:%M:%S', localtime time );
if ( $event eq "PRIVMSG" ) {
print $fh_txt "$time $channel <$nick> $message\n";
# Timestamps
_logbot_ts( "logbot", $channel )
unless ( $did_ts_cache{$channel}++ );
} elsif ( $event =~ m#^(CNICK|KILL|AWAY)$# ) {
# don't show channel name
print $fh_txt "$time $nick $event $message\n";
} elsif ( $event eq "TOPIC" ) {
print $fh_txt "$time $channel $nick changed topic to $message\n";
} else {
print $fh_txt "$time $channel $nick $event\n";
}
} ## end if ( $joined{"logbot"}...
} ## end sub logbot_do_logging
sub timestamps {
my $time = time;
my @res;
my $prevdate = "";
if ( !@tz ) {
my ( $d, $t, $z ) =
split( / /, strftime( '%Y-%m-%d %H:%M %Z', localtime $time ) );
return "$d $t $z";
}
foreach my $tz (@tz) {
$ENV{"TZ"} = $tz;
my ($where) = reverse split( m#/#, $tz );
tzset();
my ( $d, $t, $z ) =
split( / /, strftime( '%Y-%m-%d %H:%M %Z', localtime $time ) );
if ( $d eq $prevdate ) {
push( @res, "$where=$t $z" );
} else {
push( @res, "$where=$d $t $z" );
$prevdate = $d;
}
} ## end foreach my $tz (@tz)
$ENV{"TZ"} = $tz[0];
tzset();
return join( "; ", @res );
} ## end sub timestamps
Also, http://services.cl58tools.co.cc/perl/errors.txt is working now.
