File Coverage

blib/lib/CGI/Application/Plugin/LogDispatch.pm

Criterion	Covered	Total	%
statement	126	152	82.8
branch	50	72	69.4
condition	9	19	47.3
subroutine	21	23	91.3
pod	2	2	100.0
total	208	268	77.6

package CGI::Application::Plugin::LogDispatch;

use strict;
use vars qw($VERSION @EXPORT);

use Log::Dispatch;
use Log::Dispatch::Screen;
use Scalar::Util ();
use CGI::Application ();
use File::Spec ();
require UNIVERSAL::require;

$VERSION = '1.02';

@EXPORT = qw(
  log
  log_config
);

sub import {
    my $pkg = shift;
    my $callpkg = caller;
    no strict 'refs';
    foreach my $sym (@EXPORT) {
        *{"${callpkg}::$sym"} = \&{$sym};
    }
    $callpkg->log_config(@_) if @_;
}

sub log {
    my $self = shift;

    my ($log, $options, $frompkg) = _get_object_or_options($self);

    if (!$log) {
        # define the config hash if it doesn't exist to save some checks later
        $options = {} unless $options;

        # create Log::Dispatch object
        if ($options->{LOG_DISPATCH_OPTIONS}) {
            # use the parameters the user supplied
            $log = Log::Dispatch->new( %{ $options->{LOG_DISPATCH_OPTIONS} } );
        } else {
            $log = Log::Dispatch->new( );
        }

        if ($options->{LOG_DISPATCH_MODULES}) {
            foreach my $logger (@{ $options->{LOG_DISPATCH_MODULES} }) {
                if (!$logger->{module}) {
                    # no logger module provided
                    #  not fatal... just skip this logger
                    warn "No 'module' name provided -- skipping this logger";
                } elsif (!$logger->{module}->require) {
                    # Couldn't load the logger module
                    #  not fatal... just skip this logger
                    warn $UNIVERSAL::require::ERROR;
                } else {
                    my $module = delete $logger->{module};
                    # setup a callback to append a newline if requested
                    if ($logger->{append_newline} || $options->{APPEND_NEWLINE}) {
                        delete $logger->{append_newline} if exists $logger->{append_newline};
                        $logger->{callbacks} = [ $logger->{callbacks} ]
                            if $logger->{callbacks} &&  ref $logger->{callbacks} ne 'ARRAY';
                        push @{ $logger->{callbacks} }, \&_append_newline;
                    }
                    # add the logger to the dispatcher
                    $log->add( $module->new( %$logger ) );
                }
            }
        } else {
            # create a simple STDERR logger
            my %options = (
                                name => 'screen',
                              stderr => 1,
                           min_level => 'debug',
            );
            $options{callbacks} = \&_append_newline if $options->{APPEND_NEWLINE};
            $log->add( Log::Dispatch::Screen->new( %options ) );
        }
        _set_object($frompkg||$self, $log);

        # CAP::DevPopup support
        if (UNIVERSAL::can($self, 'devpopup')) {
            # Register our report with DevPopup
            $self->add_callback( 'devpopup_report', \&_devpopup_report );

            # Create logger to capture all log entries
            my %options = (
                'name'      => 'DevPopup',
                'min_level' => 'debug',
                'filename'  => File::Spec->devnull(),
                'callbacks' => sub {
                    my %args = @_;
                    push( @{$self->{LOG_DISPATCH_DEVPOPUP_HISTORY}}, [$args{level}, $args{message}] );
                    },
                );
            $log->add( Log::Dispatch::File->new(%options) );
        }
    }

    return $log;
}

sub log_config {
    my $self = shift;
    my $class = ref $self ? ref $self : $self;

    my $log_config;
    if (ref $self) {
        die "Calling log_config after the log object has already been created" if @_ && defined $self->{__LOG_OBJECT};
        $log_config = $self->{__LOG_CONFIG} ||= {};
    } else {
        no strict 'refs';
        die "Calling log_config after the log object has already been created" if @_ && defined ${$class.'::__LOG_OBJECT'};
        ${$class.'::__LOG_CONFIG'} ||= {};
        $log_config = ${$class.'::__LOG_CONFIG'};
    }

    if (@_) {
        my $props;
        if (ref($_[0]) eq 'HASH') {
            my $rthash = %{$_[0]};
            $props = CGI::Application->_cap_hash($_[0]);
        } else {
            $props = CGI::Application->_cap_hash({ @_ });
        }
        my %options;
        # Check for LOG_OPTIONS
        if ($props->{LOG_DISPATCH_OPTIONS}) {
            die "log_config error:  parameter LOG_DISPATCH_OPTIONS is not a hash reference"
                if ref $props->{LOG_DISPATCH_OPTIONS} ne 'HASH';
            $log_config->{LOG_DISPATCH_OPTIONS} = delete $props->{LOG_DISPATCH_OPTIONS};
        }

        # Check for LOG_DISPATCH_MODULES
        if ($props->{LOG_DISPATCH_MODULES}) {
            die "log_config error:  parameter LOG_DISPATCH_MODULES is not an array reference"
                if ref $props->{LOG_DISPATCH_MODULES} ne 'ARRAY';
            $log_config->{LOG_DISPATCH_MODULES} = delete $props->{LOG_DISPATCH_MODULES};
        }

        # Check for APPEND_NEWLINE
        if ($props->{APPEND_NEWLINE}) {
            $log_config->{APPEND_NEWLINE} = 1;
            delete $props->{APPEND_NEWLINE};
        }

        # Check for LOG_METHOD_EXECUTION
        if ($props->{LOG_METHOD_EXECUTION}) {
            die "log_config error:  parameter LOG_METHOD_EXECUTION is not an array reference"
                if ref $props->{LOG_METHOD_EXECUTION} ne 'ARRAY';
            _log_subroutine_calls($self->log, @{$props->{LOG_METHOD_EXECUTION}});
            delete $props->{LOG_METHOD_EXECUTION};
        }

        # If there are still entries left in $props then they are invalid
        die "Invalid option(s) (".join(', ', keys %$props).") passed to log_config" if %$props;
    }

    $log_config;
}

sub _log_subroutine_calls {
  my $log = shift;
  eval {
    Sub::WrapPackages->require;
    Sub::WrapPackages->import(
                            packages => [@_],
                            pre      => sub {
                              $log->debug("calling $_[0](".join(', ', @_[1..$#_]).")");
                            },
                            post     => sub {
                              no warnings qw(uninitialized);
                              $log->debug("returning from $_[0] (".join(', ', @_[1..$#_]).")");
                            }
    );
    1;
  } or do {
    $log->error("Failed to load and configure Sub::WrapPackages:  $@");
  };
}

sub _append_newline {
  my %hash = @_;
  chomp $hash{message};
  return $hash{message}.$/;
}


##
## Private methods
##
sub _set_object {
    my $self = shift;
    my $log  = shift;
    my $class = ref $self ? ref $self : $self;

    if (ref $self) {
        $self->{__LOG_OBJECT} = $log;
    } else {
        no strict 'refs';
        ${$class.'::__LOG_OBJECT'} = $log;
    }
}

sub _get_object_or_options {
    my $self = shift;
    my $class = ref $self ? ref $self : $self;

    # Handle the simple case by looking in the object first
    if (ref $self) {
        return ($self->{__LOG_OBJECT}, undef) if $self->{__LOG_OBJECT};
        return (undef, $self->{__LOG_CONFIG}) if $self->{__LOG_CONFIG};
    }

    # See if we can find them in the class hierarchy
    #  We look at each of the modules in the @ISA tree, and
    #  their parents as well until we find either a log
    #  object or a set of configuration parameters
    require Class::ISA;
    foreach my $super ($class, Class::ISA::super_path($class)) {
        no strict 'refs';
        return (${$super.'::__LOG_OBJECT'}, undef) if ${$super.'::__LOG_OBJECT'};
        return (undef, ${$super.'::__LOG_CONFIG'}, $super) if ${$super.'::__LOG_CONFIG'};
    }
    return;
}

sub _devpopup_report {
    my $self = shift;
    my $r=0;
    my $history = join $/, map {
                    $r=1-$r;
                    qq(
                    }
                    @{$self->{LOG_DISPATCH_DEVPOPUP_HISTORY}};
    $self->devpopup->add_report(
        title   => 'Log Entries',
        summary => 'All entries logged via Log::Dispatch',
        report  => qq(
             </td>
</tr>

<tr>
<td  class="h" >
<a name="242">242</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">               tr.even{background-color:#eee} </td>
</tr>

<tr>
<td  class="h" >
<a name="243">243</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">

              $history 




246




 





 





 





 





 





 



                 LevelMessage 




247




 





 





 





 





 





 



                  




248




            ),
        );
}

1;
__END__