File Coverage

blib/lib/Log/Log4perl/Appender/DBI.pm
Criterion Covered Total %
statement 103 129 79.8
branch 27 64 42.1
condition 13 29 44.8
subroutine 12 12 100.0
pod 1 6 16.6
total 156 240 65.0


line stmt bran cond sub pod time code
1              
2             our @ISA = qw(Log::Log4perl::Appender);
3              
4             use Carp;
5 3     3   29  
  3         97  
  3         256  
6             use strict;
7 3     3   22 use DBI;
  3         9  
  3         150  
8 3     3   25  
  3         7  
  3         5598  
9             my($proto, %p) = @_;
10             my $class = ref $proto || $proto;
11 5     5 1 37  
12 5   33     27 my $self = bless {}, $class;
13              
14 5         15 $self->_init(%p);
15              
16 5         31 my %defaults = (
17             reconnect_attempts => 1,
18 5         23 reconnect_sleep => 0,
19             );
20              
21             for (keys %defaults) {
22             if(exists $p{$_}) {
23 5         20 $self->{$_} = $p{$_};
24 10 50       28 } else {
25 0         0 $self->{$_} = $defaults{$_};
26             }
27 10         23 }
28              
29             #e.g.
30             #log4j.appender.DBAppndr.params.1 = %p
31             #log4j.appender.DBAppndr.params.2 = %5.5m
32             foreach my $pnum (keys %{$p{params}}){
33             $self->{bind_value_layouts}{$pnum} =
34 5         11 Log::Log4perl::Layout::PatternLayout->new({
  5         17  
35             ConversionPattern => {value => $p{params}->{$pnum}},
36             undef_column_value => undef,
37 13         210 });
38             }
39             #'bind_value_layouts' now contains a PatternLayout
40             #for each parameter heading for the Sql engine
41              
42             $self->{SQL} = $p{sql}; #save for error msg later on
43              
44 5         114 $self->{MAX_COL_SIZE} = $p{max_col_size};
45              
46 5         144 $self->{BUFFERSIZE} = $p{bufferSize} || 1;
47              
48 5   100     31 if ($p{usePreparedStmt}) {
49             $self->{sth} = $self->create_statement($p{sql});
50 5 100       16 $self->{usePreparedStmt} = 1;
51 3         13 }else{
52 3         11795 $self->{layout} = Log::Log4perl::Layout::PatternLayout->new({
53             ConversionPattern => {value => $p{sql}},
54             undef_column_value => undef,
55             });
56 2         11 }
57              
58             if ($self->{usePreparedStmt} && $self->{bufferSize}){
59             warn "Log4perl: you've defined both usePreparedStmt and bufferSize \n".
60 5 50 66     35 "in your appender '$p{name}'--\n".
61 0         0 "I'm going to ignore bufferSize and just use a prepared stmt\n";
62             }
63              
64             return $self;
65             }
66 5         29  
67              
68             my $self = shift;
69             my %params = @_;
70              
71 5     5   13 if ($params{dbh}) {
72 5         26 $self->{dbh} = $params{dbh};
73             } else {
74 5 50       24 $self->{connect} = sub {
75 0         0 DBI->connect(@params{qw(datasource username password)},
76             {PrintError => 0, $params{attrs} ? %{$params{attrs}} : ()})
77             or croak "Log4perl: $DBI::errstr";
78             };
79 5 50   5   49 $self->{dbh} = $self->{connect}->();
  0 50       0  
80             $self->{_mine} = 1;
81 5         75 }
82 5         19 }
83 5         5944  
84             my ($self, $stmt) = @_;
85              
86             $stmt || croak "Log4perl: sql not set in Log4perl::Appender::DBI";
87              
88 7     7 0 17 return $self->{dbh}->prepare($stmt) || croak "Log4perl: DBI->prepare failed $DBI::errstr\n$stmt";
89              
90 7 50       25 }
91              
92 7   33     55  
93             my $self = shift;
94             my %p = @_;
95              
96             #%p is
97             # { name => $appender_name,
98 10     10 0 26 # level => loglevel
99 10         36 # message => $message,
100             # log4p_category => $category,
101             # log4p_level => $level,);
102             # },
103              
104             #getting log4j behavior with no specified ConversionPattern
105             chomp $p{message} unless ref $p{message};
106              
107            
108             my $qmarks = $self->calculate_bind_values(\%p);
109              
110 10 50       35  
111             if ($self->{usePreparedStmt}) {
112              
113 10         44 $self->query_execute($self->{sth}, @$qmarks);
114              
115             }else{
116 10 100       30  
117             #first expand any %x's in the statement
118 4         42 my $stmt = $self->{layout}->render(
119             $p{message},
120             $p{log4p_category},
121             $p{log4p_level},
122             5 + $Log::Log4perl::caller_depth,
123             );
124              
125             push @{$self->{BUFFER}}, $stmt, $qmarks;
126              
127 6         24 $self->check_buffer();
128             }
129             }
130 6         12  
  6         15  
131             my($self, $sth, @qmarks) = @_;
132 6         17  
133             my $errstr = "[no error]";
134              
135             for my $attempt (0..$self->{reconnect_attempts}) {
136             #warn "Exe: @qmarks"; # TODO
137 10     10 0 41 if(! $sth->execute(@qmarks)) {
138              
139 10         21 # save errstr because ping() would override it [RT 56145]
140             $errstr = $self->{dbh}->errstr();
141 10         32  
142             # Exe failed -- was it because we lost the DB
143 10 50       11157 # connection?
144             if($self->{dbh}->ping()) {
145             # No, the connection is ok, we failed because there's
146 0         0 # something wrong with the execute(): Bad SQL or
147             # missing parameters or some such). Abort.
148             croak "Log4perl: DBI appender error: '$errstr'";
149             }
150 0 0       0  
151             if($attempt == $self->{reconnect_attempts}) {
152             croak "Log4perl: DBI appender failed to " .
153             ($self->{reconnect_attempts} == 1 ? "" : "re") .
154 0         0 "connect " .
155             "to database after " .
156             "$self->{reconnect_attempts} attempt" .
157 0 0       0 ($self->{reconnect_attempts} == 1 ? "" : "s") .
158             " (last error error was [$errstr]";
159             }
160             if(! $self->{dbh}->ping()) {
161             # Ping failed, try to reconnect
162             if($attempt) {
163 0 0       0 #warn "Sleeping"; # TODO
    0          
164             sleep($self->{reconnect_sleep}) if $self->{reconnect_sleep};
165             }
166 0 0       0  
167             eval {
168 0 0       0 #warn "Reconnecting to DB"; # TODO
169             $self->{dbh} = $self->{connect}->();
170 0 0       0 };
171             }
172              
173 0         0 if ($self->{usePreparedStmt}) {
174             $sth = $self->create_statement($self->{SQL});
175 0         0 $self->{sth} = $sth if $self->{sth};
176             } else {
177             #warn "Pending stmt: $self->{pending_stmt}"; #TODO
178             $sth = $self->create_statement($self->{pending_stmt});
179 0 0       0 }
180 0         0  
181 0 0       0 next;
182             }
183             return 1;
184 0         0 }
185             croak "Log4perl: DBI->execute failed $errstr, \n".
186             "on $self->{SQL}\n @qmarks";
187 0         0 }
188              
189 10         24769 my ($self, $p) = @_;
190              
191 0         0 my @qmarks;
192             my $user_ph_idx = 0;
193              
194             my $i=0;
195            
196 10     10 0 22 if ($self->{bind_value_layouts}) {
197              
198 10         17 my $prev_pnum = 0;
199 10         27 my $max_pnum = 0;
200            
201 10         17 my @pnums = sort {$a <=> $b} keys %{$self->{bind_value_layouts}};
202             $max_pnum = $pnums[-1];
203 10 50       29
204             #Walk through the integers for each possible bind value.
205 10         25 #If it doesn't have a layout assigned from the config file
206 10         19 #then shift it off the array from the $log call
207             #This needs to be reworked now that we always get an arrayref? --kg 1/2003
208 10         19 foreach my $pnum (1..$max_pnum){
  32         87  
  10         53  
209 10         69 my $msg;
210            
211             #we've got a bind_value_layout to fill the spot
212             if ($self->{bind_value_layouts}{$pnum}){
213             $msg = $self->{bind_value_layouts}{$pnum}->render(
214             $p->{message},
215 10         40 $p->{log4p_category},
216 42         60 $p->{log4p_level},
217             5 + $Log::Log4perl::caller_depth,
218             );
219 42 100 33     129  
    50          
    0          
    0          
220             #we don't have a bind_value_layout, so get
221             #a message bit
222             }elsif (ref $p->{message} eq 'ARRAY' && @{$p->{message}}){
223             #$msg = shift @{$p->{message}};
224 30         135 $msg = $p->{message}->[$i++];
225              
226             #here handle cases where we ran out of message bits
227             #before we ran out of bind_value_layouts, just keep going
228             }elsif (ref $p->{message} eq 'ARRAY'){
229 12         36 $msg = undef;
230             $p->{message} = undef;
231 12         45  
232             #here handle cases where we didn't get an arrayref
233             #log the message in the first placeholder and nothing in the rest
234             }elsif (! ref $p->{message} ){
235             $msg = $p->{message};
236 0         0 $p->{message} = undef;
237 0         0  
238             }
239              
240             if ($self->{MAX_COL_SIZE} &&
241             length($msg) > $self->{MAX_COL_SIZE}){
242 0         0 substr($msg, $self->{MAX_COL_SIZE}) = '';
243 0         0 }
244             push @qmarks, $msg;
245             }
246             }
247 42 50 33     118  
248             #handle leftovers
249 0         0 if (ref $p->{message} eq 'ARRAY' && @{$p->{message}} ) {
250             #push @qmarks, @{$p->{message}};
251 42         120 push @qmarks, @{$p->{message}}[$i..@{$p->{message}}-1];
252              
253             }
254              
255             return \@qmarks;
256 10 50 33     51 }
  10         56  
257              
258 10         22  
  10         28  
  10         37  
259             my $self = shift;
260              
261             return unless ($self->{BUFFER} && ref $self->{BUFFER} eq 'ARRAY');
262 10         30  
263             if (scalar @{$self->{BUFFER}} >= $self->{BUFFERSIZE} * 2) {
264              
265             my ($sth, $stmt, $prev_stmt);
266              
267 11     11 0 20 $prev_stmt = ""; # Init to avoid warning (ms 5/10/03)
268              
269 11 100 66     94 while (@{$self->{BUFFER}}) {
270             my ($stmt, $qmarks) = splice (@{$self->{BUFFER}},0,2);
271 8 100       15  
  8         34  
272             $self->{pending_stmt} = $stmt;
273 4         9  
274             #reuse the sth if the stmt doesn't change
275 4         8 if ($stmt ne $prev_stmt) {
276             $sth->finish if $sth;
277 4         7 $sth = $self->create_statement($stmt);
  10         28  
278 6         11 }
  6         18  
279              
280 6         13 $self->query_execute($sth, @$qmarks);
281              
282             $prev_stmt = $stmt;
283 6 100       15  
284 4 50       10 }
285 4         12  
286             $sth->finish;
287              
288 6         25154 my $dbh = $self->{dbh};
289              
290 6         16 if ($dbh && ! $dbh->{AutoCommit}) {
291             $dbh->commit;
292             }
293             }
294 4         27 }
295              
296 4         44 my $self = shift;
297              
298 4 50 33     45 $self->{BUFFERSIZE} = 1;
299 0         0  
300             $self->check_buffer();
301              
302             if ($self->{_mine} && $self->{dbh}) {
303             $self->{dbh}->disconnect;
304             }
305 5     5   12 }
306              
307 5         15  
308             1;
309 5         20  
310              
311 5 50 33     38 =encoding utf8
312 5         204  
313             =head1 NAME
314              
315             Log::Log4perl::Appender::DBI - implements appending to a DB
316              
317             =head1 SYNOPSIS
318              
319             my $config = q{
320             log4j.category = WARN, DBAppndr
321             log4j.appender.DBAppndr = Log::Log4perl::Appender::DBI
322             log4j.appender.DBAppndr.datasource = DBI:CSV:f_dir=t/tmp
323             log4j.appender.DBAppndr.username = bobjones
324             log4j.appender.DBAppndr.password = 12345
325             log4j.appender.DBAppndr.sql = \
326             insert into log4perltest \
327             (loglevel, custid, category, message, ipaddr) \
328             values (?,?,?,?,?)
329             log4j.appender.DBAppndr.params.1 = %p
330             #2 is custid from the log() call
331             log4j.appender.DBAppndr.params.3 = %c
332             #4 is the message from log()
333             #5 is ipaddr from log()
334              
335             log4j.appender.DBAppndr.usePreparedStmt = 1
336             #--or--
337             log4j.appender.DBAppndr.bufferSize = 2
338              
339             #just pass through the array of message items in the log statement
340             log4j.appender.DBAppndr.layout = Log::Log4perl::Layout::NoopLayout
341             log4j.appender.DBAppndr.warp_message = 0
342              
343             #driver attributes support
344             log4j.appender.DBAppndr.attrs.f_encoding = utf8
345             };
346              
347               Log::Log4perl::init ( \$config ) ;
348              
349               my $logger = Log::Log4perl->get_logger () ;
350             $logger->warn( $custid, 'big problem!!', $ip_addr );
351              
352             =head1 CAVEAT
353              
354             This is a very young module and there are a lot of variations
355             in setups with different databases and connection methods,
356             so make sure you test thoroughly! Any feedback is welcome!
357              
358             =head1 DESCRIPTION
359              
360             This is a specialized Log::Dispatch object customized to work with
361             log4perl and its abilities, originally based on Log::Dispatch::DBI
362             by Tatsuhiko Miyagawa but with heavy modifications.
363              
364             It is an attempted compromise between what Log::Dispatch::DBI was
365             doing and what log4j's JDBCAppender does. Note the log4j docs say
366             the JDBCAppender "is very likely to be completely replaced in the future."
367              
368             The simplest usage is this:
369              
370             log4j.category = WARN, DBAppndr
371             log4j.appender.DBAppndr = Log::Log4perl::Appender::DBI
372             log4j.appender.DBAppndr.datasource = DBI:CSV:f_dir=t/tmp
373             log4j.appender.DBAppndr.username = bobjones
374             log4j.appender.DBAppndr.password = 12345
375             log4j.appender.DBAppndr.sql = \
376             INSERT INTO logtbl \
377             (loglevel, message) \
378             VALUES ('%c','%m')
379              
380             log4j.appender.DBAppndr.layout = Log::Log4perl::Layout::PatternLayout
381              
382              
383             $logger->fatal('fatal message');
384             $logger->warn('warning message');
385              
386             ===============================
387             |FATAL|fatal message |
388             |WARN |warning message |
389             ===============================
390              
391              
392             But the downsides to that usage are:
393              
394             =over 4
395              
396             =item *
397              
398             You'd better be darn sure there are not quotes in your log message, or your
399             insert could have unforeseen consequences! This is a very insecure way to
400             handle database inserts, using place holders and bind values is much better,
401             keep reading. (Note that the log4j docs warn "Be careful of quotes in your
402             messages!") B<*>.
403              
404             =item *
405              
406             It's not terribly high-performance, a statement is created and executed
407             for each log call.
408              
409             =item *
410              
411             The only run-time parameter you get is the %m message, in reality
412             you probably want to log specific data in specific table columns.
413              
414             =back
415              
416             So let's try using placeholders, and tell the logger to create a
417             prepared statement handle at the beginning and just reuse it
418             (just like Log::Dispatch::DBI does)
419              
420              
421             log4j.appender.DBAppndr.sql = \
422             INSERT INTO logtbl \
423             (custid, loglevel, message) \
424             VALUES (?,?,?)
425              
426             #---------------------------------------------------
427             #now the bind values:
428             #1 is the custid
429             log4j.appender.DBAppndr.params.2 = %p
430             #3 is the message
431             #---------------------------------------------------
432              
433             log4j.appender.DBAppndr.layout = Log::Log4perl::Layout::NoopLayout
434             log4j.appender.DBAppndr.warp_message = 0
435            
436             log4j.appender.DBAppndr.usePreparedStmt = 1
437            
438            
439             $logger->warn( 1234, 'warning message' );
440              
441              
442             Now see how we're using the '?' placeholders in our statement? This
443             means we don't have to worry about messages that look like
444              
445             invalid input: 1234';drop table custid;
446              
447             fubaring our database!
448              
449             Normally a list of things in the logging statement gets concatenated into
450             a single string, but setting C<warp_message> to 0 and using the
451             NoopLayout means that in
452              
453             $logger->warn( 1234, 'warning message', 'bgates' );
454              
455             the individual list values will still be available for the DBI appender later
456             on. (If C<warp_message> is not set to 0, the default behavior is to
457             join the list elements into a single string. If PatternLayout or SimpleLayout
458             are used, their attempt to C<render()> your layout will result in something
459             like "ARRAY(0x841d8dc)" in your logs. More information on C<warp_message>
460             is in Log::Log4perl::Appender.)
461              
462             In your insert SQL you can mix up '?' placeholders with conversion specifiers
463             (%c, %p, etc) as you see fit--the logger will match the question marks to
464             params you've defined in the config file and populate the rest with values
465             from your list. If there are more '?' placeholders than there are values in
466             your message, it will use undef for the rest. For instance,
467              
468             log4j.appender.DBAppndr.sql = \
469             insert into log4perltest \
470             (loglevel, message, datestr, subpoena_id)\
471             values (?,?,?,?)
472             log4j.appender.DBAppndr.params.1 = %p
473             log4j.appender.DBAppndr.params.3 = %d
474              
475             log4j.appender.DBAppndr.warp_message=0
476              
477              
478             $logger->info('arrest him!', $subpoena_id);
479              
480             results in the first '?' placeholder being bound to %p, the second to
481             "arrest him!", the third to the date from "%d", and the fourth to your
482             $subpoenaid. If you forget the $subpoena_id and just log
483              
484             $logger->info('arrest him!');
485              
486             then you just get undef in the fourth column.
487              
488              
489             If the logger statement is also being handled by other non-DBI appenders,
490             they will just join the list into a string, joined with
491             C<$Log::Log4perl::JOIN_MSG_ARRAY_CHAR> (default is an empty string).
492              
493             And see the C<usePreparedStmt>? That creates a statement handle when
494             the logger object is created and just reuses it. That, however, may
495             be problematic for long-running processes like webservers, in which case
496             you can use this parameter instead
497              
498             log4j.appender.DBAppndr.bufferSize=2
499              
500             This copies log4j's JDBCAppender's behavior, it saves up that many
501             log statements and writes them all out at once. If your INSERT
502             statement uses only ? placeholders and no %x conversion specifiers
503             it should be quite efficient because the logger can re-use the
504             same statement handle for the inserts.
505              
506             If the program ends while the buffer is only partly full, the DESTROY
507             block should flush the remaining statements, if the DESTROY block
508             runs of course.
509              
510             * I<As I was writing this, Danko Mannhaupt was coming out with his
511             improved log4j JDBCAppender (http://www.mannhaupt.com/danko/projects/)
512             which overcomes many of the drawbacks of the original JDBCAppender.>
513              
514             =head1 DESCRIPTION 2
515              
516             Or another way to say the same thing:
517              
518             The idea is that if you're logging to a database table, you probably
519             want specific parts of your log information in certain columns. To this
520             end, you pass an list to the log statement, like
521              
522             $logger->warn('big problem!!',$userid,$subpoena_nr,$ip_addr);
523              
524             and the array members drop into the positions defined by the placeholders
525             in your SQL statement. You can also define information in the config
526             file like
527              
528             log4j.appender.DBAppndr.params.2 = %p
529              
530             in which case those numbered placeholders will be filled in with
531             the specified values, and the rest of the placeholders will be
532             filled in with the values from your log statement's array.
533              
534             =head1 MISC PARAMETERS
535              
536              
537             =over 4
538              
539             =item usePreparedStmt
540              
541             See above.
542              
543             =item warp_message
544              
545             see Log::Log4perl::Appender
546              
547             =item max_col_size
548              
549             If you're used to just throwing debugging messages like huge stacktraces
550             into your logger, some databases (Sybase's DBD!!) may surprise you
551             by choking on data size limitations. Normally, the data would
552             just be truncated to fit in the column, but Sybases's DBD it turns out
553             maxes out at 255 characters. Use this parameter in such a situation
554             to truncate long messages before they get to the INSERT statement.
555              
556             =back
557              
558             =head1 CHANGING DBH CONNECTIONS (POOLING)
559              
560             If you want to get your dbh from some place in particular, like
561             maybe a pool, subclass and override _init() and/or create_statement(),
562             for instance
563              
564             sub _init {
565             ; #no-op, no pooling at this level
566             }
567             sub create_statement {
568             my ($self, $stmt) = @_;
569            
570             $stmt || croak "Log4perl: sql not set in ".__PACKAGE__;
571            
572             return My::Connections->getConnection->prepare($stmt)
573             || croak "Log4perl: DBI->prepare failed $DBI::errstr\n$stmt";
574             }
575              
576              
577             =head1 LIFE OF CONNECTIONS
578              
579             If you're using C<log4j.appender.DBAppndr.usePreparedStmt>
580             this module creates an sth when it starts and keeps it for the life
581             of the program. For long-running processes (e.g. mod_perl), connections
582             might go stale, but if C<Log::Log4perl::Appender::DBI> tries to write
583             a message and figures out that the DB connection is no longer working
584             (using DBI's ping method), it will reconnect.
585              
586             The reconnection process can be controlled by two parameters,
587             C<reconnect_attempts> and C<reconnect_sleep>. C<reconnect_attempts>
588             specifies the number of reconnections attempts the DBI appender
589             performs until it gives up and dies. C<reconnect_sleep> is the
590             time between reconnection attempts, measured in seconds.
591             C<reconnect_attempts> defaults to 1, C<reconnect_sleep> to 0.
592              
593             Alternatively, use C<Apache::DBI> or C<Apache::DBI::Cache> and read
594             CHANGING DB CONNECTIONS above.
595              
596             Note that C<Log::Log4perl::Appender::DBI> holds one connection open
597             for every appender, which might be too many.
598              
599             =head1 SEE ALSO
600              
601             L<Log::Dispatch::DBI>
602              
603             L<Log::Log4perl::JavaMap::JDBCAppender>
604              
605             =head1 LICENSE
606              
607             Copyright 2002-2013 by Mike Schilli E<lt>m@perlmeister.comE<gt>
608             and Kevin Goess E<lt>cpan@goess.orgE<gt>.
609              
610             This library is free software; you can redistribute it and/or modify
611             it under the same terms as Perl itself.
612              
613             =head1 AUTHOR
614              
615             Please contribute patches to the project on Github:
616              
617             http://github.com/mschilli/log4perl
618              
619             Send bug reports or requests for enhancements to the authors via our
620              
621             MAILING LIST (questions, bug reports, suggestions/patches):
622             log4perl-devel@lists.sourceforge.net
623              
624             Authors (please contact them via the list above, not directly):
625             Mike Schilli <m@perlmeister.com>,
626             Kevin Goess <cpan@goess.org>
627              
628             Contributors (in alphabetical order):
629             Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton
630             Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony
631             Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy
632             Grundman, Paul Harrington, Alexander Hartmaier David Hull,
633             Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter,
634             Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope,
635             Lars Thegler, David Viner, Mac Yang.
636