File Coverage

blib/lib/Log/Agent/Driver/Fork.pm

Criterion	Covered	Total	%
statement	46	69	66.6
branch	12	16	75.0
condition	1	2	50.0
subroutine	10	17	58.8
pod	12	15	80.0
total	81	119	68.0

###########################################################################
#
#   Fork.pm
#
#   Copyright (C) 1999 Raphael Manfredi.
#   Copyright (C) 2002-2017 Mark Rogaski, [e-mail];
#   all rights reserved.
#
#   See the README file included with the
#   distribution for license information.
#
##########################################################################

package Log::Agent::Driver::Fork;

use strict;
require Log::Agent::Driver;

use vars qw(@ISA);
@ISA = qw(Log::Agent::Driver);

###########################################################################
#
# Public Methods
#
###########################################################################

#
# make
#
# constructor method
#
sub make {
    my $class = shift;

    # initialize the dispatcher
    my $self = {
        drivers => []
    };
    bless $self, $class;
    $self->_init('', 0);

    # test for 5.6
    $^W = 0;
    my $new_perl = eval "$^V and $^V ge v5.6.0" || 0;
    $^W = 1;

    # process the arguments
    foreach my $arg (@_) {
        if (ref $arg) {
            # add to the list of drivers
            push(@{$self->{drivers}}, $arg);
        } else {
            require Carp;
            Carp::croak("argument is not an object reference: $arg");
        }
    }

    return $self;
}

#
# prefix_msg
#
# does little of value
#
sub prefix_msg {
    return $_[1];
}

#
# write
#
# pass-through to drivers
#
sub write {
    my($self, $channel, $priority, $str) = @_;
    foreach my $driver (@{$self->{drivers}}) {
        $driver->write($channel, $priority, $str);
    }
}

#
# emit
#
# wrapper for write() that uses dynamically bound priority() and prefix_msg()
# methods
#
sub emit {
    my($self, $channel, $priority, $str) = @_;
    foreach my $driver (@{$self->{drivers}}) {
        $driver->emit($channel, $priority, $str);

        # This is a kludge to make duperr work in file driver,
        # the encapsulation purists should lynch me for this.
        if ($driver->isa('Log::Agent::Driver::File')) {
            if ($driver->duperr) {
                if ($priority eq 'critical') {
                    $driver->emit_output('critical', 'FATAL', $str);
                } elsif ($priority eq 'error') {
                    $driver->emit_output('error', 'ERROR', $str);
                } elsif ($priority eq 'warning') {
                    $driver->emit_output('warning', 'WARNING', $str);
                }
            }
        }

    }
}

#
# emit_carp
#
# A specialized wrapper to hand-off carp/croak messages at a
# specified offset.
#
sub emit_carp {
    my($self, $channel, $priority, $offset, $str) = @_;

    # yet another kludge
    $offset++ if (caller(3))[3] =~ /^main::/;

    foreach my $driver (@{$self->{drivers}}) {
        # construct the message
        require Carp;
        my $msg = $driver->carpmess($offset, $str, \&Carp::shortmess);
        # send it to the driver
        $driver->emit($channel, $priority, $str);
    }
}

#
# channel_eq
#
# exhaustive equality comparison
#
sub channel_eq {
    my $self = shift;
    foreach my $driver (@{$self->{drivers}}) {
        $driver->channel_eq(@_) || return;
    }
    return 1;
}

#
# logconfess
#
# Fatal error, with stack trace
#
sub logconfess {
    my($self, $str) = @_;

    # log error to all drivers
    $self->emit_carp('error', 'critical', 0, $str);

    die;
}

#
# logcroak
#
# Fatal error
#
sub logcroak {
    my($self, $str) = @_;

    #
    # log error to all drivers
    #
    $self->emit_carp('error', 'critical', 0, $str);

    die;
}

#
# logxcroak
#
# Fatal error, from perspective of caller
#
sub logxcroak {
    my($self, $offset, $str) = @_;

    #
    # log error to all drivers
    #
    $self->emit_carp('error', 'critical', $offset, $str);

    die;
}

#
# logdie
#
# Fatal error
#
sub logdie {
    my ($self, $str) = @_;

    #
    # log error to all drivers
    #
    $self->emit('error', 'critical', $str);
    die;
}

#
# logerr
#
# Signal error on stderr
#
sub logerr {
    my ($self, $str) = @_;

    #
    # log error to all drivers
    #
    $self->emit('error', 'error', $str);
}

#
# logwarn
#
# Warn, with "WARNING" clearly emphasized
#
sub logwarn {
    my ($self, $str) = @_;

    #
    # log error to all drivers
    #
    $self->emit('error', 'warning', $str);
}

#
# logcarp
#
# log a warning, carp-style
#
sub logcarp {
    my($self, $str) = @_;

    #
    # log message to all drivers
    #
    $self->emit_carp('error', 'warning', 0, $str);
}

#
# logxcarp
#
# Warn from perspective of caller
#
sub logxcarp {
    my($self, $offset, $str) = @_;

    #
    # log message to all drivers
    #
    $self->emit_carp('error', 'warning', $offset, $str);
}

#
# logsay
#
# Log message to "output" channel at "notice" priority
#
sub logsay {
    my($self, $str) = @_;

    #
    # send message to drivers
    #
    $self->emit('output', 'notice', $str);
}

1;  # for require
__END__