File Coverage

blib/lib/Apache/DBILogConfig.pm

Criterion	Covered	Total	%
statement	4	6	66.6
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	6	8	75.0

package Apache::DBILogConfig;

require 5.004;

use strict;

# MODULES

use mod_perl 1.11_01;
use Apache::Constants qw( :common );
use DBI;
use Date::Format;

$Apache::DBILogConfig::VERSION = "0.02";

# List of allowed formats and their values
my %Formats =
  (
	 'a' => sub {return (shift)->connection->remote_ip}, # Remote IP Address
	 'A' => sub {}, # Local IP-address
	 'b' => sub {return (shift)->bytes_sent || '-'}, # Bytes sent, excluding heaers, in CLF format
	 'B' => sub {return (shift)->bytes_sent}, # Bytes sent, excluding heaers
	 'c' => sub {}, # Connection status when response is completed (X, +, -)
   'e' => sub {return (shift)->subprocess_env(shift)}, # Any environment variable
   'f' => sub {return (shift)->filename}, # Filename
   'h' => sub {return (shift)->get_remote_host}, # Remote host
   'H' => sub {return (shift)->protocol}, # The request protocol
   'i' => sub {return (shift)->header_in(shift)}, # A header in the client request
   'l' => sub {return (shift)->get_remote_logname}, # Remote log name (from identd)
   'm' => sub {return (shift)->method}, # The request method
   'n' => sub {return (shift)->notes(shift)}, # The contents of a note from another module
   'o' => sub {return (shift)->header_out(shift)}, # A header from the reply
   'p' => sub {return (shift)->get_server_port}, # Server port
   'P' => sub {return $$}, # Apache child PID
	 'q' => sub {return $_[0]->args ? '?' . $_[0]->args : ''}, # The query string (prepended with a ?
	                                                             # if the query exists)
   'r' => sub {return (shift)->the_request}, # First line of the request
   's' => sub {return (shift)->status}, # Status
   't' => sub {return time2str $_[1] || "%d/%b/%Y:%X %z", $_[0]->request_time}, # Time: CLF or strftime
   'T' => sub {return time - (shift)->request_time}, # Time taken to serve the request
   'u' => sub {return (shift)->connection->user}, # Remote user from auth
   'U' => sub {return (shift)->uri}, # URL
   'v' => sub {return (shift)->server->server_hostname}, # The canonical ServerName
   'V' => sub {} # The UseCanonicalName server name
  );

# SUBS

sub logger {

  my $r = shift;
  $r = $r->last; # Handle internal redirects
  $r->subprocess_env; # Setup the environment

  # Connect to the database
  my $source = $r->dir_config('DBILogConfig_data_source');
  my $username = $r->dir_config('DBILogConfig_username');
  my $password = $r->dir_config('DBILogConfig_password');
  my $dbh = DBI->connect($source, $username, $password);
  unless ($dbh) {
    $r->log_error("Apache::DBILogConfig could not connect to $source - $DBI::errstr");
    return DECLINED;
  } # End unless
  $r->warn("DBILogConfig: Connected to $source as $username");

  # Parse the formats ( %[conditions]{param}format=field [...] )
  my @format_list = (); # List of anon hashes {field, format, param, conditions}
	my $format_string = Apache->request->dir_config('DBILogConfig_log_format');
	while ($format_string =~ /%(!)?([^\{[:alpha:]]*)(?:\{([^\}]+)\})?(\w)=(\S+)/g) {
		my ($op, $conditions, $param, $format, $field) = ($1, $2, $3, $4, $5);

		# Or conditions together
    my @conditions = map q($r->status ==  ) . $_, split /,/, $conditions;
    $conditions = join(' or ', @conditions);

    $conditions = qq{!($conditions)} if $op eq '!'; # Negate if necessary
    $conditions ||= 1; # If no conditions we want a guranteed true condition
    $r->warn("DBILogConfig: format=$format, field=$field, param=$param, conditions=$conditions");
    push @format_list, {'field' => $field, 'format' => $format, 'param' => $param,
												'conditions' => $conditions};
  } # End foreach

  # Create the statement and insert data
  my $table = $r->dir_config('DBILogConfig_table');
  @format_list = grep eval $_->{'conditions'}, @format_list; # Keep only ones whose conditions are true
  my $fields = join ', ', map $_->{'field'}, @format_list; # Create string of fields
  my $values = join ', ', map $dbh->quote($Formats{$_->{'format'}}->($r, $_->{'param'})), @format_list; # Create str of values
  my $statement = qq(INSERT INTO $table ($fields) VALUES ($values));
  $r->warn("DBILogConfig: statement=$statement");
  $dbh->do($statement);

  $dbh->disconnect;

  return OK;

} # End logger

sub handler {shift->post_connection(\&logger)}

1;

__END__