File Coverage

blib/lib/Log/Handler/Output/DBI.pm
Criterion Covered Total %
statement 73 131 55.7
branch 16 78 20.5
condition 4 21 19.0
subroutine 10 14 71.4
pod 7 7 100.0
total 110 251 43.8


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Log::Handler::Output::DBI - Log messages to a database.
4              
5             =head1 SYNOPSIS
6              
7             use Log::Handler::Output::DBI;
8              
9             my $db = Log::Handler::Output::DBI->new(
10             # database source
11             database => "database",
12             driver => "mysql",
13             host => "127.0.0.1",
14             port => 3306,
15              
16             # or with "dbname" instead of "database"
17             dbname => "database",
18             driver => "Pg",
19             host => "127.0.0.1",
20             port => 5432,
21              
22             # or with data_source
23             data_source => "dbi:mysql:database=database;host=127.0.0.1;port=3306",
24              
25             # Username and password
26             user => "user",
27             password => "password",
28              
29             # debugging
30             debug => 1,
31              
32             # table, columns and values (as string)
33             table => "messages",
34             columns => "level ctime cdate pid hostname progname message",
35             values => "%level %time %date %pid %hostname %progname %message",
36              
37             # table, columns and values (as array reference)
38             table => "messages",
39             columns => [ qw/level ctime cdate pid hostname progname message/ ],
40             values => [ qw/%level %time %date %pid %hostname %progname %message/ ],
41              
42             # table, columns and values (your own statement)
43             statement => "insert into messages (level,ctime,cdate,pid,hostname,progname,message) values (?,?,?,?,?,?,?)",
44             values => [ qw/%level %time %date %pid %hostname %progname %message/ ],
45              
46             # if you like persistent connections and want to re-connect
47             persistent => 1,
48             );
49              
50             my %message = (
51             level => "ERROR",
52             time => "10:12:13",
53             date => "1999-12-12",
54             pid => $$,
55             hostname => "localhost",
56             progname => $0,
57             message => "an error here"
58             );
59              
60             $db->log(\%message);
61              
62             =head1 DESCRIPTION
63              
64             With this output you can insert messages into a database table.
65              
66             =head1 METHODS
67              
68             =head2 new()
69              
70             Call C to create a new Log::Handler::Output::DBI object.
71              
72             The following options are possible:
73              
74             =over 4
75              
76             =item B
77              
78             Set the dsn (data source name).
79              
80             You can use this parameter instead of C, C, C
81             and C.
82              
83             =item B or B
84              
85             Pass the database name.
86              
87             =item B
88              
89             Pass the database driver.
90              
91             =item B
92              
93             Pass the hostname where the database is running.
94              
95             =item B
96              
97             Pass the port where the database is listened.
98              
99             =item B
100              
101             Pass the database user for the connect.
102              
103             =item B
104              
105             Pass the users password.
106              
107             =item B and B
108              
109             With this options you can pass the table name for the insert and the columns.
110             You can pass the columns as string or as array. Example:
111              
112             # the table name
113             table => "messages",
114              
115             # columns as string
116             columns => "level, ctime, cdate, pid, hostname, progname, message",
117              
118             # columns as array
119             columns => [ qw/level ctime cdate pid hostname progname message/ ],
120              
121             The statement would created as follows
122              
123             insert into message (level, ctime, cdate, pid, hostname, progname, mtime, message)
124             values (?,?,?,?,?,?,?)
125              
126             =item B
127              
128             With this option you can pass your own statement if you don't want to you the
129             options C and C.
130              
131             statement => "insert into message (level, ctime, cdate, pid, hostname, progname, mtime, message)"
132             ." values (?,?,?,?,?,?,?)"
133              
134             =item B
135              
136             With this option you have to set the values for the insert.
137              
138             values => "%level, %time, %date, %pid, %hostname, %progname, %message",
139              
140             # or
141              
142             values => [ qw/%level %time %date %pid %hostname %progname %message/ ],
143              
144             The placeholders are identical with the pattern names that you have to pass
145             with the option C from L.
146              
147             %L level
148             %T time
149             %D date
150             %P pid
151             %H hostname
152             %N newline
153             %C caller
154             %p package
155             %f filename
156             %l line
157             %s subroutine
158             %S progname
159             %r runtime
160             %t mtime
161             %m message
162              
163             Take a look to the documentation of L for all possible patterns.
164              
165             =item B
166              
167             With this option you can enable or disable a persistent database connection and
168             re-connect if the connection was lost.
169              
170             This option is set to 1 on default.
171              
172             =item B
173              
174             This option is useful if you want to pass arguments to L. The default is
175             set to
176              
177             {
178             PrintError => 0,
179             AutoCommit => 1
180             }
181              
182             C is deactivated because this would print error messages as
183             warnings to STDERR.
184              
185             You can pass your own arguments - and overwrite it - with
186              
187             dbi_params => { PrintError => 1, AutoCommit => 0 }
188              
189             =item B
190              
191             With this option it's possible to enable debugging. The information can be
192             intercepted with C<$SIG{__WARN__}>.
193              
194             =back
195              
196             =head2 log()
197              
198             Log a message to the database.
199              
200             my $db = Log::Handler::Output::DBI->new(
201             database => "database",
202             driver => "mysql",
203             user => "user",
204             password => "password",
205             host => "127.0.0.1",
206             port => 3306,
207             table => "messages",
208             columns => [ qw/level ctime message/ ],
209             values => [ qw/%level %time %message/ ],
210             persistent => 1,
211             );
212              
213             $db->log(
214             message => "your message",
215             level => "INFO",
216             time => "2008-10-10 10:12:23",
217             );
218              
219             Or you can connect to the database yourself. You should
220             notice that if the database connection lost then the
221             logger can't re-connect to the database and would return
222             an error. Use C at your own risk.
223              
224             my $dbh = DBI->connect(...);
225              
226             my $db = Log::Handler::Output::DBI->new(
227             dbi_handle => $dbh,
228             table => "messages",
229             columns => [ qw/level ctime message/ ],
230             values => [ qw/%level %time %message/ ],
231             );
232              
233             =head2 connect()
234              
235             Connect to the database.
236              
237             =head2 disconnect()
238              
239             Disconnect from the database.
240              
241             =head2 validate()
242              
243             Validate a configuration.
244              
245             =head2 reload()
246              
247             Reload with a new configuration.
248              
249             =head2 errstr()
250              
251             This function returns the last error message.
252              
253             =head1 PREREQUISITES
254              
255             Carp
256             Params::Validate
257             DBI
258             your DBI driver you want to use
259              
260             =head1 EXPORTS
261              
262             No exports.
263              
264             =head1 REPORT BUGS
265              
266             Please report all bugs to .
267              
268             If you send me a mail then add Log::Handler into the subject.
269              
270             =head1 AUTHOR
271              
272             Jonny Schulz .
273              
274             =head1 COPYRIGHT
275              
276             Copyright (C) 2007-2009 by Jonny Schulz. All rights reserved.
277              
278             This program is free software; you can redistribute it and/or
279             modify it under the same terms as Perl itself.
280              
281             =cut
282              
283             package Log::Handler::Output::DBI;
284              
285 1     1   90160 use strict;
  1         13  
  1         30  
286 1     1   6 use warnings;
  1         2  
  1         32  
287 1     1   15 use DBI;
  1         3  
  1         36  
288 1     1   6 use Carp;
  1         2  
  1         57  
289 1     1   557 use Params::Validate qw();
  1         9403  
  1         1572  
290              
291             our $VERSION = "0.12";
292             our $ERRSTR = "";
293              
294             sub new {
295 1     1 1 1011 my $class = shift;
296 1         7 my $opts = $class->_validate(@_);
297 1         3 my $self = bless $opts, $class;
298              
299 1 50       6 if ($self->{debug}) {
300 0         0 warn "Create a new Log::Handler::Output::DBI object";
301             }
302              
303 1         4 return $self;
304             }
305              
306             sub log {
307 0     0 1 0 my $self = shift;
308 0 0       0 my $message = @_ > 1 ? {@_} : shift;
309 0         0 my @values = ();
310              
311 0         0 foreach my $v (@{$self->{values}}) {
  0         0  
312 0 0 0     0 if (ref($v) eq "CODE") {
    0          
313 0         0 push @values, &$v();
314             } elsif ($v =~ /^%(.+)/ && exists $message->{$1}) {
315 0         0 push @values, $message->{$1};
316             } else {
317 0         0 push @values, $v;
318             }
319             }
320              
321 0 0       0 if ($self->{debug}) {
322 0         0 warn "execute: ".@values." bind values";
323             }
324              
325 0 0       0 $self->connect or return undef;
326              
327 0 0       0 if ( ! $self->{sth}->execute(@values) ) {
328 0         0 return $self->_raise_error("DBI execute error: ".DBI->errstr);
329             }
330              
331 0 0 0     0 if (!$self->{persistent} && !$self->{dbi_handle}) {
332 0 0       0 $self->disconnect or return undef;
333             }
334              
335 0         0 return 1;
336             }
337              
338             sub connect {
339 0     0 1 0 my $self = shift;
340              
341 0 0 0     0 if ($self->{persistent} && $self->{dbh}) {
342 0 0       0 if ($self->{use_ping}) {
343 0 0       0 if ($self->{dbh}->ping) {
344 0         0 return 1;
345             }
346             } else {
347 0 0       0 eval { $self->{dbh}->do($self->{pingstmt}) or die DBI->errstr };
  0         0  
348 0 0       0 return 1 unless $@;
349             }
350             }
351              
352 0 0       0 if ($self->{debug}) {
353 0         0 warn "Connect to the database: $self->{cstr}->[0] ...";
354             }
355              
356 0         0 my $dbh;
357              
358 0 0       0 if ($self->{dbi_handle}) {
359             # If db ping failed and dbi_handle and dbi is set
360             # then it seems that the database is down.
361 0 0       0 if ($self->{dbi}) {
362 0         0 return $self->_raise_error("dbi_handle - lost connection");
363             }
364 0         0 $dbh = $self->{dbi_handle};
365             } else {
366 0 0       0 $dbh = DBI->connect(@{$self->{cstr}})
  0         0  
367             or return $self->_raise_error("DBI connect error: ".DBI->errstr);
368             }
369              
370             my $sth = $dbh->prepare($self->{statement})
371 0 0       0 or return $self->_raise_error("DBI prepare error: ".$dbh->errstr);
372              
373 0         0 $self->{dbh} = $dbh;
374 0         0 $self->{sth} = $sth;
375              
376 0         0 return 1;
377             }
378              
379             sub disconnect {
380 1     1 1 3 my $self = shift;
381              
382 1 50       13 if ($self->{sth}) {
383             $self->{sth}->finish
384 0 0       0 or return $self->_raise_error("DBI finish error: ".$self->{sth}->errstr);
385              
386 0         0 delete $self->{sth};
387             }
388              
389 1 50       6 if ($self->{dbh}) {
390 0 0       0 if ($self->{debug}) {
391 0         0 warn "Disconnect from database";
392             }
393              
394             $self->{dbh}->disconnect
395 0 0       0 or return $self->_raise_error("DBI disconnect error: ".DBI->errstr);;
396              
397 0         0 delete $self->{dbh};
398             }
399              
400 1         2 return 1;
401             }
402              
403             sub validate {
404 1     1 1 3 my $self = shift;
405 1         2 my $opts = ();
406              
407 1         2 eval { $opts = $self->_validate(@_) };
  1         5  
408              
409 1 50       4 if ($@) {
410 0         0 return $self->_raise_error($@);
411             }
412              
413 1         3 return $opts;
414             }
415              
416             sub reload {
417 1     1 1 2062 my $self = shift;
418 1         4 my $opts = $self->validate(@_);
419              
420 1 50       3 if (!$opts) {
421 0         0 return undef;
422             }
423              
424 1         6 $self->disconnect;
425              
426 1         6 foreach my $key (keys %$opts) {
427 16         29 $self->{$key} = $opts->{$key};
428             }
429              
430 1         7 return 1;
431             }
432              
433             sub errstr {
434 0     0 1 0 return $ERRSTR;
435             }
436              
437             #
438             # private stuff
439             #
440              
441             sub _validate {
442 2     2   6 my $class = shift;
443              
444 2         135 my %options = Params::Validate::validate(@_, {
445             dbi_handle => {
446             type => Params::Validate::OBJECT,
447             optional => 1,
448             },
449             data_source => {
450             type => Params::Validate::SCALAR,
451             optional => 1,
452             },
453             database => {
454             type => Params::Validate::SCALAR,
455             optional => 1,
456             },
457             dbname => {
458             type => Params::Validate::SCALAR,
459             optional => 1,
460             },
461             driver => {
462             type => Params::Validate::SCALAR,
463             optional => 1,
464             },
465             user => {
466             type => Params::Validate::SCALAR,
467             optional => 1,
468             },
469             password => {
470             type => Params::Validate::SCALAR,
471             optional => 1,
472             },
473             host => {
474             type => Params::Validate::SCALAR,
475             optional => 1,
476             },
477             port => {
478             type => Params::Validate::SCALAR,
479             optional => 1,
480             },
481             table => {
482             type => Params::Validate::SCALAR,
483             depends => [ "columns" ],
484             optional => 1,
485             },
486             columns => {
487             type => Params::Validate::SCALAR | Params::Validate::ARRAYREF,
488             depends => [ "table" ],
489             optional => 1,
490             },
491             values => {
492             type => Params::Validate::SCALAR | Params::Validate::ARRAYREF,
493             },
494             statement => {
495             type => Params::Validate::SCALAR,
496             optional => 1,
497             },
498             persistent => {
499             type => Params::Validate::SCALAR,
500             default => 1,
501             },
502             dbi_params => {
503             type => Params::Validate::HASHREF,
504             default => { PrintError => 0, AutoCommit => 1 },
505             },
506             use_ping => {
507             type => Params::Validate::SCALAR,
508             regex => qr/^[01]\z/,
509             default => 0,
510             },
511             debug => {
512             type => Params::Validate::SCALAR,
513             regex => qr/^[01]\z/,
514             default => 0,
515             },
516             });
517              
518 2 0 33     111 if (!$options{table} && !$options{statement}) {
519 0         0 Carp::croak "Missing one of the mandatory options: 'statement' or 'table' and 'columns'";
520             }
521              
522             # build the connect string (data source name)
523 2         4 my @cstr = ();
524              
525 2 50 33     15 if (defined $options{data_source}) {
    50 33        
    0          
526 0         0 @cstr = ($options{data_source});
527             } elsif ($options{driver} && ($options{database} || $options{dbname})) {
528 2         6 $cstr[0] = "dbi:$options{driver}:";
529              
530 2 50       5 if ($options{database}) {
531 2         7 $cstr[0] .= "database=$options{database}";
532             } else {
533 0         0 $cstr[0] .= "dbname=$options{dbname}";
534             }
535              
536 2 50       6 if ($options{host}) {
537 2         5 $cstr[0] .= ";host=$options{host}";
538 2 50       5 if ($options{port}) {
539 2         16 $cstr[0] .= ";port=$options{port}";
540             }
541             }
542             } elsif (!defined $options{dbi_handle}) {
543 0         0 Carp::croak "Missing mandatory options data_source or database/dbname";
544             }
545              
546 2 50       7 if ($options{user}) {
547 2         4 $cstr[1] = $options{user};
548 2 50       6 if ($options{password}) {
549 2         5 $cstr[2] = $options{password};
550             }
551             }
552              
553 2         3 $cstr[3] = $options{dbi_params};
554 2         26 $options{cstr} = \@cstr;
555              
556             # build the statement
557              
558 2 50       8 if (!ref($options{values})) {
559 2         17 $options{values} = [ split /[\s,]+/, $options{values} ];
560             }
561              
562 2 50       7 if (!$options{statement}) {
563              
564 2         6 $options{statement} = "insert into $options{table} (";
565              
566 2 50       5 if (ref($options{columns})) {
567 0         0 $options{statement} .= join(",", @{$options{columns}});
  0         0  
568             } else {
569 2         12 $options{statement} .= join(",", split /[\s,]+/, $options{columns});
570             }
571              
572 2         5 $options{statement} .= ") values (";
573              
574 2         4 my @binds;
575 2         3 foreach my $v (@{$options{values}}) {
  2         8  
576 4         9 $v =~ s/^\s+//;
577 4         9 $v =~ s/\s+\z//;
578 4         8 push @binds, "?";
579             }
580              
581 2         6 $options{statement} .= join(",", @binds);
582 2         5 $options{statement} .= ")";
583             }
584              
585 2 50 33     11 if ($options{driver} && $options{driver} =~ /oracle/i) {
586 0         0 $options{pingstmt} = "select 1 from dual";
587             } else {
588 2         6 $options{pingstmt} = "select 1";
589             }
590              
591 2         6 return \%options;
592             }
593              
594             sub _raise_error {
595 0     0     my $self = shift;
596 0           $ERRSTR = shift;
597 0           return undef;
598             }
599              
600             1;