mirror of
https://github.com/pragma-/pbot.git
synced 2024-12-23 19:22:40 +01:00
Add SQLite logger and profiler functionality
This commit is contained in:
parent
39c0cd3fb5
commit
5c14727fd1
@ -31,8 +31,10 @@ sub initialize {
|
||||
$self->{new_entries} = 0;
|
||||
|
||||
$self->{pbot}->{registry}->add_default('text', 'messagehistory', 'sqlite_commit_interval', 30);
|
||||
$self->{pbot}->{registry}->add_default('text', 'messagehistory', 'sqlite_debug', $conf{sqlite_debug} // 0);
|
||||
|
||||
$self->{pbot}->{registry}->add_trigger('messagehistory', 'sqlite_commit_interval', sub { $self->sqlite_commit_interval_trigger(@_) });
|
||||
$self->{pbot}->{registry}->add_trigger('messagehistory', 'sqlite_debug', sub { $self->sqlite_debug_trigger(@_) });
|
||||
|
||||
$self->{pbot}->{timer}->register(
|
||||
sub { $self->commit_message_history },
|
||||
@ -46,6 +48,12 @@ sub sqlite_commit_interval_trigger {
|
||||
$self->{pbot}->{timer}->update_interval('messagehistory_sqlite_commit_interval', $newvalue);
|
||||
}
|
||||
|
||||
sub sqlite_debug_trigger {
|
||||
my ($self, $section, $item, $newvalue) = @_;
|
||||
$self->{dbh}->trace($self->{dbh}->parse_trace_flags("SQL|$newvalue")) if defined $self->{dbh};
|
||||
|
||||
}
|
||||
|
||||
sub begin {
|
||||
my $self = shift;
|
||||
|
||||
@ -54,7 +62,11 @@ sub begin {
|
||||
$self->{dbh} = DBI->connect("dbi:SQLite:dbname=$self->{filename}", "", "", { RaiseError => 1, PrintError => 0, AutoInactiveDestroy => 1 }) or die $DBI::errstr;
|
||||
|
||||
eval {
|
||||
#$self->{dbh}->trace($self->{dbh}->parse_trace_flags('SQL|1|test'));
|
||||
my $sqlite_debug = $self->{pbot}->{registry}->get_value('messagehistory', 'sqlite_debug');
|
||||
use PBot::SQLiteLoggerLayer;
|
||||
use PBot::SQLiteLogger;
|
||||
open $self->{trace_layer}, '>:via(PBot::SQLiteLoggerLayer)', PBot::SQLiteLogger->new(pbot => $self->{pbot});
|
||||
$self->{dbh}->trace($self->{dbh}->parse_trace_flags("SQL|$sqlite_debug"), $self->{trace_layer});
|
||||
|
||||
$self->{dbh}->do(<<SQL);
|
||||
CREATE TABLE IF NOT EXISTS Hostmasks (
|
||||
|
55
PBot/SQLiteLogger.pm
Normal file
55
PBot/SQLiteLogger.pm
Normal file
@ -0,0 +1,55 @@
|
||||
# File: SQLiteLogger
|
||||
# Author: pragma_
|
||||
#
|
||||
# Purpose: Logs SQLite trace messages to Logger.pm with profiling of elapsed
|
||||
# time between messages.
|
||||
|
||||
package PBot::SQLiteLogger;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Carp;
|
||||
use Time::HiRes qw(gettimeofday);
|
||||
|
||||
sub new
|
||||
{
|
||||
my ($class, %conf) = @_;
|
||||
my $self = {};
|
||||
$self->{buf} = '';
|
||||
$self->{timestamp} = gettimeofday;
|
||||
$self->{pbot} = $conf{pbot} // Carp::croak("Missing pbot reference in " . __FILE__);
|
||||
return bless $self, $class;
|
||||
}
|
||||
|
||||
sub log
|
||||
{
|
||||
my $self = shift;
|
||||
$self->{buf} .= shift;
|
||||
|
||||
# DBI feeds us pieces at a time, so accumulate a complete line
|
||||
# before outputing
|
||||
if($self->{buf} =~ tr/\n//) {
|
||||
$self->log_message;
|
||||
$self->{buf} = '';
|
||||
}
|
||||
}
|
||||
|
||||
sub log_message {
|
||||
my $self = shift;
|
||||
my $now = gettimeofday;
|
||||
my $elapsed = $now - $self->{timestamp};
|
||||
$elapsed = sprintf '%10.4f', $elapsed;
|
||||
$self->{pbot}->{logger}->log("$elapsed : $self->{buf}");
|
||||
$self->{timestamp} = $now;
|
||||
}
|
||||
|
||||
sub close {
|
||||
my $self = shift;
|
||||
if($self->{buf}) {
|
||||
$self->log_message;
|
||||
$self->{buf} = '';
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
38
PBot/SQLiteLoggerLayer.pm
Normal file
38
PBot/SQLiteLoggerLayer.pm
Normal file
@ -0,0 +1,38 @@
|
||||
# File: SQLiteLoggerLayer
|
||||
# Author: pragma_
|
||||
#
|
||||
# Purpose: PerlIO::via layer to log DBI trace messages
|
||||
|
||||
package PBot::SQLiteLoggerLayer;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
sub PUSHED
|
||||
{
|
||||
my ($class, $mode, $fh) = @_;
|
||||
my $logger;
|
||||
return bless \$logger, $class;
|
||||
}
|
||||
|
||||
sub OPEN {
|
||||
my ($self, $path, $mode, $fh) = @_;
|
||||
# $path is actually our logger object
|
||||
$$self = $path;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub WRITE
|
||||
{
|
||||
my ($self, $buf, $fh) = @_;
|
||||
$$self->log($buf);
|
||||
return length($buf);
|
||||
}
|
||||
|
||||
sub CLOSE {
|
||||
my $self = shift;
|
||||
$$self->close();
|
||||
return 0;
|
||||
}
|
||||
|
||||
1;
|
@ -13,8 +13,8 @@ use warnings;
|
||||
# These are set automatically by the build/commit script
|
||||
use constant {
|
||||
BUILD_NAME => "PBot",
|
||||
BUILD_REVISION => 594,
|
||||
BUILD_DATE => "2014-05-19",
|
||||
BUILD_REVISION => 596,
|
||||
BUILD_DATE => "2014-05-20",
|
||||
};
|
||||
|
||||
1;
|
||||
|
Loading…
Reference in New Issue
Block a user