—

              
HideShow 281 lines of Pod
=head1 NAME
Log::Handler::Output::DBI - Log messages to a database.
=head1 SYNOPSIS
    use Log::Handler::Output::DBI;
    my $db = Log::Handler::Output::DBI->new(
        # database source
        database    => "database",
        driver      => "mysql",
        host        => "127.0.0.1",
        port        => 3306,
        # or with "dbname" instead of "database"
        dbname      => "database",
        driver      => "Pg",
        host        => "127.0.0.1",
        port        => 5432,
        # or with data_source
        data_source => "dbi:mysql:database=database;host=127.0.0.1;port=3306",
        # Username and password
        user        => "user",
        password    => "password",
        # debugging
        debug       => 1,
        # table, columns and values (as string)
        table       => "messages",
        columns     => "level ctime cdate pid hostname progname message",
        values      => "%level %time %date %pid %hostname %progname %message",
        # table, columns and values (as array reference)
        table       => "messages",
        columns     => [ qw/level ctime cdate pid hostname progname message/ ],
        values      => [ qw/%level %time %date %pid %hostname %progname %message/ ],
        # table, columns and values (your own statement)
        statement   => "insert into messages (level,ctime,cdate,pid,hostname,progname,message) values (?,?,?,?,?,?,?)",
        values      => [ qw/%level %time %date %pid %hostname %progname %message/ ],
        # if you like persistent connections and want to re-connect
        persistent  => 1,
    );
    my %message = (
        level       => "ERROR",
        time        => "10:12:13",
        date        => "1999-12-12",
        pid         => $$,
        hostname    => "localhost",
        progname    => $0,
        message     => "an error here"
    );
    $db->log(\%message);
=head1 DESCRIPTION
With this output you can insert messages into a database table.
=head1 METHODS
=head2 new()
Call C<new()> to create a new Log::Handler::Output::DBI object.
The following options are possible:
=over 4
=item B<data_source>
Set the dsn (data source name).
You can use this parameter instead of C<database>, C<driver>, C<host>
and C<port>.
=item B<database> or B<dbname>
Pass the database name.
=item B<driver>
Pass the database driver.
=item B<host>
Pass the hostname where the database is running.
=item B<port>
Pass the port where the database is listened.
=item B<user>
Pass the database user for the connect.
=item B<password>
Pass the users password.
=item B<table> and B<columns>
With this options you can pass the table name for the insert and the columns.
You can pass the columns as string or as array. Example:
    # the table name
    table => "messages",
    # columns as string
    columns => "level, ctime, cdate, pid, hostname, progname, message",
    # columns as array
    columns => [ qw/level ctime cdate pid hostname progname message/ ],
The statement would created as follows
    insert into message (level, ctime, cdate, pid, hostname, progname, mtime, message)
                 values (?,?,?,?,?,?,?)
=item B<statement>
With this option you can pass your own statement if you don't want to you the
options C<table> and C<columns>.
    statement => "insert into message (level, ctime, cdate, pid, hostname, progname, mtime, message)"
                 ." values (?,?,?,?,?,?,?)"
=item B<values>
With this option you have to set the values for the insert.
        values => "%level, %time, %date, %pid, %hostname, %progname, %message",
        # or
        values => [ qw/%level %time %date %pid %hostname %progname %message/ ],
The placeholders are identical with the pattern names that you have to pass
with the option C<message_pattern> from L<Log::Handler>.
    %L   level
    %T   time
    %D   date
    %P   pid
    %H   hostname
    %N   newline
    %C   caller
    %p   package
    %f   filename
    %l   line
    %s   subroutine
    %S   progname
    %r   runtime
    %t   mtime
    %m   message
Take a look to the documentation of L<Log::Handler> for all possible patterns.
=item B<persistent>
With this option you can enable or disable a persistent database connection and
re-connect if the connection was lost.
This option is set to 1 on default.
=item B<dbi_params>
This option is useful if you want to pass arguments to L<DBI>. The default is
set to
    {
        PrintError => 0,
        AutoCommit => 1
    }
C<PrintError> is deactivated because this would print error messages as
warnings to STDERR.
You can pass your own arguments - and overwrite it - with
    dbi_params => { PrintError => 1, AutoCommit => 0 }
=item B<debug>
With this option it's possible to enable debugging. The information can be
intercepted with C<$SIG{__WARN__}>.
=back
=head2 log()
Log a message to the database.
    my $db = Log::Handler::Output::DBI->new(
        database   => "database",
        driver     => "mysql",
        user       => "user",
        password   => "password",
        host       => "127.0.0.1",
        port       => 3306,
        table      => "messages",
        columns    => [ qw/level ctime message/ ],
        values     => [ qw/%level %time %message/ ],
        persistent => 1,
    );
    $db->log(
        message => "your message",
        level   => "INFO",
        time    => "2008-10-10 10:12:23",
    );
Or you can connect to the database yourself. You should
notice that if the database connection lost then the
logger can't re-connect to the database and would return
an error. Use C<dbi_handle> at your own risk.
    my $dbh = DBI->connect(...);
    my $db = Log::Handler::Output::DBI->new(
        dbi_handle => $dbh,
        table      => "messages",
        columns    => [ qw/level ctime message/ ],
        values     => [ qw/%level %time %message/ ],
    );
=head2 connect()
Connect to the database.
=head2 disconnect()
Disconnect from the database.
=head2 validate()
Validate a configuration.
=head2 reload()
Reload with a new configuration.
=head2 errstr()
This function returns the last error message.
=head1 PREREQUISITES
    Carp
    Params::Validate
    DBI
    your DBI driver you want to use
=head1 EXPORTS
No exports.
=head1 REPORT BUGS
Please report all bugs to <jschulz.cpan(at)bloonix.de>.
If you send me a mail then add Log::Handler into the subject.
=head1 AUTHOR
Jonny Schulz <jschulz.cpan(at)bloonix.de>.
=head1 COPYRIGHT
Copyright (C) 2007-2009 by Jonny Schulz. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut
package Log::Handler::Output::DBI;
use strict;
use warnings;
use DBI;
use Carp;
use Params::Validate qw();
our $VERSION = "0.11";
our $ERRSTR  = "";
sub new {
    my $class = shift;
    my $opts  = $class->_validate(@_);
    my $self  = bless $opts, $class;
    if ($self->{debug}) {
        warn "Create a new Log::Handler::Output::DBI object";
    }
    return $self;
}
sub log {
    my $self    = shift;
    my $message = @_ > 1 ? {@_} : shift;
    my @values  = ();
    foreach my $v (@{$self->{values}}) {
        if (ref($v) eq "CODE") {
            push @values, &$v();
        } elsif ($v =~ /^%(.+)/ && exists $message->{$1}) {
            push @values, $message->{$1};
        } else {
            push @values, $v;
        }
    }
    if ($self->{debug}) {
        warn "execute: ".@values." bind values";
    }
    $self->connect or return undef;
    if ( ! $self->{sth}->execute(@values) ) {
        return $self->_raise_error("DBI execute error: ".DBI->errstr);
    }
    if (!$self->{persistent} && !$self->{dbi_handle}) {
        $self->disconnect or return undef;
    }
    return 1;
}
sub connect {
    my $self = shift;
    if ($self->{persistent} && $self->{dbh}) {
        if ($self->{use_ping}) {
            if ($self->{dbh}->ping) {
                return 1;
            }
        } else {
            eval { $self->{dbh}->do($self->{pingstmt}) or die DBI->errstr };
            return 1 unless $@;
        }
    }
    if ($self->{debug}) {
        warn "Connect to the database: $self->{cstr}->[0] ...";
    }
    my $dbh;
    if ($self->{dbi_handle}) {
        # If db ping failed and dbi_handle and dbi is set
        # then it seems that the database is down.
        if ($self->{dbi}) {
            return $self->_raise_error("dbi_handle - lost connection");
        }
        $dbh = $self->{dbi_handle};
    } else {
        $dbh = DBI->connect(@{$self->{cstr}})
            or return $self->_raise_error("DBI connect error: ".DBI->errstr);
    }
    my $sth = $dbh->prepare($self->{statement})
        or return $self->_raise_error("DBI prepare error: ".$dbh->errstr);
    $self->{dbh} = $dbh;
    $self->{sth} = $sth;
    return 1;
}
sub disconnect {
    my $self = shift;
    if ($self->{sth}) {
        $self->{sth}->finish
            or return $self->_raise_error("DBI finish error: ".$self->{sth}->errstr);
        delete $self->{sth};
    }
    if ($self->{dbh}) {
        if ($self->{debug}) {
            warn "Disconnect from database";
        }
        $self->{dbh}->disconnect
            or return $self->_raise_error("DBI disconnect error: ".DBI->errstr);;
        delete $self->{dbh};
    }
    return 1;
}
sub validate {
    my $self = shift;
    my $opts = ();
    eval { $opts = $self->_validate(@_) };
    if ($@) {
        return $self->_raise_error($@);
    }
    return $opts;
}
sub reload {
    my $self = shift;
    my $opts = $self->validate(@_);
    if (!$opts) {
        return undef;
    }
    $self->disconnect;
    foreach my $key (keys %$opts) {
        $self->{$key} = $opts->{$key};
    }
    return 1;
}
sub errstr {
    return $ERRSTR;
}
#
# private stuff
#
sub _validate {
    my $class = shift;
    my %options = Params::Validate::validate(@_, {
        data_source => {
            type => Params::Validate::SCALAR,
            optional => 1,
        },
        database => {
            type => Params::Validate::SCALAR,
            optional => 1,
        },
        dbname => {
            type => Params::Validate::SCALAR,
            optional => 1,
        },
        driver => {
            type => Params::Validate::SCALAR,
            optional => 1,
        },
        user => {
            type => Params::Validate::SCALAR,
            optional => 1,
        },
        password => {
            type => Params::Validate::SCALAR,
            optional => 1,
        },
        host => {
            type => Params::Validate::SCALAR,
            optional => 1,
        },
        port => {
            type => Params::Validate::SCALAR,
            optional => 1,
        },
        table => {
            type => Params::Validate::SCALAR,
            depends => [ "columns" ],
            optional => 1,
        },
        columns => {
            type => Params::Validate::SCALAR | Params::Validate::ARRAYREF,
            depends => [ "table" ],
            optional => 1,
        },
        values => {
            type => Params::Validate::SCALAR | Params::Validate::ARRAYREF,
        },
        statement => {
            type => Params::Validate::SCALAR,
            optional => 1,
        },
        persistent => {
            type => Params::Validate::SCALAR,
            default => 1,
        },
        dbi_params => {
            type => Params::Validate::HASHREF,
            default => { PrintError => 0, AutoCommit => 1 },
        },
        use_ping => {
            type => Params::Validate::SCALAR,
            regex => qr/^[01]\z/,
            default => 0,
        },
        debug => {
            type => Params::Validate::SCALAR,
            regex => qr/^[01]\z/,
            default => 0,
        },
    });
    if (!$options{table} && !$options{statement}) {
        Carp::croak "Missing one of the mandatory options: 'statement' or 'table' and 'columns'";
    }
    # build the connect string (data source name)
    my @cstr = ();
    if (defined $options{data_source}) {
        @cstr = ($options{data_source});
    } elsif ($options{driver} && ($options{database} || $options{dbname})) {
        $cstr[0] = "dbi:$options{driver}:";
        if ($options{database}) {
            $cstr[0] .= "database=$options{database}";
        } else {
            $cstr[0] .= "dbname=$options{dbname}";
        }
        if ($options{host}) {
            $cstr[0] .= ";host=$options{host}";
            if ($options{port}) {
                $cstr[0] .= ";port=$options{port}";
            }
        }
    } else {
        Carp::croak "Missing mandatory options data_source or database/dbname";
    }
    if ($options{user}) {
        $cstr[1] = $options{user};
        if ($options{password}) {
            $cstr[2] = $options{password};
        }
    }
    $cstr[3] = $options{dbi_params};
    $options{cstr} = \@cstr;
    # build the statement
    if (!ref($options{values})) {
        $options{values} = [ split /[\s,]+/, $options{values} ];
    }
    if (!$options{statement}) {
        $options{statement} = "insert into $options{table} (";
        if (ref($options{columns})) {
            $options{statement} .= join(",", @{$options{columns}});
        } else {
            $options{statement} .= join(",", split /[\s,]+/, $options{columns});
        }
        $options{statement} .= ") values (";
        my @binds;
        foreach my $v (@{$options{values}}) {
            $v =~ s/^\s+//;
            $v =~ s/\s+\z//;
            push @binds, "?";
        }
        $options{statement} .= join(",", @binds);
        $options{statement} .= ")";
    }
    if ($options{driver} && $options{driver} =~ /oracle/i) {
        $options{pingstmt} = "select 1 from dual";
    } else {
        $options{pingstmt} = "select 1";
    }
    return \%options;
}
sub _raise_error {
    my $self = shift;
    $ERRSTR = shift;
    return undef;
}
1;