=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 informations 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",
    );

=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.09";
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->disconnect or return undef;
    }

    return 1;
}

sub connect {
    my $self = shift;

    if ($self->{persistent} && $self->{dbh}) {
        eval { $self->{dbh}->do("select 1") or die DBI->errstr };
        return 1 unless $@;
    }

    if ($self->{debug}) {
        warn "Connect to the database: $self->{cstr}->[0] ...";
    }


    my $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 },
        },
        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} .= ")";
    }

    return \%options;
}

sub _raise_error {
    my $self = shift;
    $ERRSTR = shift;
    return undef;
}

1;