view release on metacpan or  search on metacpan

Spread.pm  view on Meta::CPAN

package Logger::Spread;

require 5.005_62;

use strict;
use warnings;
use Apache::Constants qw(:common);
use Apache::ModuleConfig ();
use Apache::Util qw( ht_time );
use DynaLoader ();
use English;
use POSIX;
use Spread;


use vars qw( $VERSION $mailbox $private_group $iter);

$VERSION = '1.0.3';

if($ENV{MOD_PERL}) {
    no strict;
    @ISA = qw(DynaLoader);
    __PACKAGE__->bootstrap($VERSION);
}

sub spconnect($)
{
    my $daemon = shift; 
    my %args;
    $args{'spread_name'} = $daemon;
    $args{'private_name'} = "http-$PID";
    $args{'priority'} = 0;
    $args{'group_membership'} = 0;
    return ($mailbox, $private_group) = Spread::connect( \%args );
}

sub handler($$) 
{
    my $self = shift;
    $self = bless {}, $self;
    my $apache_req = shift;
    my %log_hash;
    my $cfg = Apache::ModuleConfig->get($apache_req, 'Logger::Spread');
    unless($mailbox) {
        ($mailbox, $private_group) = spconnect($cfg->{spreaddaemon});
    }
    standard_log_entries($apache_req, \%log_hash);
    # handle variable expansion
    foreach my $log (@{$cfg->{mls_logs}}) {
        if ($log->{mask} && !$log->{mask}->($apache_req)) {
            next;
        }
        my $log_string = $cfg->{logformat}->{$log->{format}};
        # expand 'standard' LogFormat strings and custom Taubman entries
        $log_string =~ s/%([\w<>]+)/$log_hash{$1}/g;
        # expand Environment variables
        $log_string =~ s/%\{([\w-]+)\}e\b/$ENV{$1}/g;
        # expand request headers
        $log_string =~ s/%\{([\w-]+)\}i\b/$apache_req->header_in($1)/eg;
        # expand response headers
        $log_string =~ s/%\{([\w-]+)\}o\b/$apache_req->header_out($1)/eg;
        # expand arbitrary variables
        $log_string =~ s/%\{([\w-]+)\}v\b/$$1/g;
        $log_string =~ s/%\{([^\}]+)\}perl\b/eval($1)/eg;
        # handle proprietary extensions
        _interpolate_log_string(\$log_string);
        Spread::multicast($mailbox, 
            AGREED_MESS, 
            $log->{name},
            1,
            $log_string);
    }
}

# used to extend basic operation
sub _interpolate_log_string { }

sub standard_log_entries 
{
    my $orig = shift;
    my $r = $orig->last;
    my $hashref = shift;

    $hashref->{a} = $r->connection->remote_ip;
    $hashref->{B} = $r->bytes_sent;
    $hashref->{b} = $r->bytes_sent?$r->bytes_sent:"-";
    $hashref->{c} = "-";  # unimplemeted
    $hashref->{f} = $r->filename;
    $hashref->{h} = $r->get_remote_host;
    $hashref->{H} = $r->protocol;
    $hashref->{l} = $r->get_remote_logname;
    $hashref->{m} = $r->method;
    $hashref->{p} = $r->server->port;
    $hashref->{P} = $PID;
    $hashref->{q} = '?'.$r->args;
    $hashref->{r} = $r->the_request;
    $hashref->{s} = $r->status;
    $hashref->{'>s'} = $orig->status; 
    # [06/May/2002:23:56:56 -0400]
    $hashref->{t} = POSIX::strftime('[%d/%b/%Y:%H:%M:%S %z]',localtime($orig->request_time));
    $hashref->{u} = $r->connection->user?$r->connection->user:"-";
    $hashref->{U} = $orig->uri;
    $hashref->{v} = $r->hostname;
    $hashref->{V} = $r->hostname;
}

sub MLS_LogFormat($$$$) 
{
    my ($cfg, $parms, $format, $name, $env) = @_;
   $cfg->{logformat}->{$name}= $format;
}

sub MLS_Log($$$$;$)
{
    my ($cfg, $parms, $fname, $format, $mask) = @_;
    my $env;
    eval "\$env = sub { my \$r = shift; $mask}"; 
    push @{$cfg->{mls_logs}}, { name => $fname, format => $format, mask => $env};
}

sub SpreadDaemon($$$)
{