File Coverage

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

Criterion	Covered	Total	%
statement	101	132	76.5
branch	35	60	58.3
condition	8	15	53.3
subroutine	21	25	84.0
pod	10	22	45.4
total	175	254	68.9

###########################################################################
#
#   File.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.
#
##########################################################################

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

########################################################################
package Log::Agent::Driver::File;

use vars qw(@ISA);

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

#
# ->make        -- defined
#
# Creation routine.
#
# Attributes (and switches that set them):
#
# prefix        the application name
# duperr        whether to duplicate "error" channels to "output"
# stampfmt      stamping format ("syslog", "date", "own", "none") or closure
# showpid       whether to show pid after prefix in []
# channels      where each channel ("error", "output", "debug") goes
# chanperm      what permissions each channel ("error", "output", "debug") has
# magic_open    flag to tell whether ">>file" or "|proc" are allowed filenames
# rotate        default rotating policy for logfiles
#
# Additional switches:
#
# file          sole channel, implies -duperr = 0 and supersedes -channels
# perm          file permissions that supersedes all channel permissions
#
# Other attributes:
#
# channel_obj        opened channel objects
#
sub make {
    my $self = bless {}, shift;
    my (%args) = @_;
    my $prefix;
    my $file;
    my $perm;

    my %set = (
        -prefix     => \$prefix,  # Handled by parent via _init
        -duperr     => \$self->{'duperr'},
        -channels   => \$self->{'channels'},
        -chanperm   => \$self->{'chanperm'},
        -stampfmt   => \$self->{'stampfmt'},
        -showpid    => \$self->{'showpid'},
        -magic_open => \$self->{'magic_open'},
        -file       => \$file,
        -perm       => \$perm,
        -rotate     => \$self->{'rotate'},
    );

    while (my ($arg, $val) = each %args) {
        my $vset = $set{lc($arg)};
        unless (ref $vset) {
            require Carp;
            Carp::croak("Unknown switch $arg");
        }
        $$vset = $val;
    }

    #
    # If -file was used, it supersedes -duperr and -channels
    #

    if (defined $file && length $file) {
        $self->{'channels'} = {
            'debug'  => $file,
            'output' => $file,
            'error'  => $file,
        };
        $self->{'duperr'} = 0;
    }

    #
    # and we do something similar for file permissions
    #

    if (defined $perm && length $perm) {
        $self->{chanperm} = {
            debug  => $perm,
            output => $perm,
            error  => $perm
        };
    }

    $self->_init($prefix, 0);  # 1 is the skip Carp penalty for confess

    $self->{channels}    = {} unless $self->channels;  # No defined channels
    $self->{chanperm}    = {} unless $self->chanperm;  # No defined perms
    $self->{channel_obj} = {};                         # No opened files

    #
    # Check for logfile rotation, which can be specified on a global or
    # file by file basis.  Since Log::Agent::Rotate is a separate extension,
    # it may not be installed.
    #

    my $use_rotate = defined($self->rotate) ? 1 : 0;
    unless ($use_rotate) {
        foreach my $chan (keys %{$self->channels}) {
            $use_rotate = 1 if ref $self->channels->{$chan} eq 'ARRAY';
            last if $use_rotate;
        }
    }

    if ($use_rotate) {
        eval {
            require Log::Agent::File::Rotate;
        };
        if ($@) {
            warn $@;
            require Carp;
            Carp::croak("Must install Log::Agent::Rotate to use rotation");
        }
    }

    return $self;
}

#
# Attribute access
#

sub duperr      { $_[0]->{duperr}      }
sub channels    { $_[0]->{channels}    }
sub chanperm    { $_[0]->{chanperm}    }
sub channel_obj { $_[0]->{channel_obj} }
sub stampfmt    { $_[0]->{stampfmt}    }
sub showpid     { $_[0]->{showpid}     }
sub magic_open  { $_[0]->{magic_open}  }
sub rotate      { $_[0]->{rotate}      }

#
# ->prefix_msg  -- defined
#
# NOP: channel handles prefixing for us.
#
sub prefix_msg {
    my $self = shift;
    return $_[0];
}

#
# ->chanfn
#
# Return channel file name.
#
sub chanfn {
    my $self = shift;
    my ($channel) = @_;
    my $filename = $self->channels->{$channel};
    if (ref $filename eq 'ARRAY') {
        $filename = $filename->[0];
    }
    # No channel defined, use 'error'
    $filename = $self->channels->{'error'} unless
            defined $filename && length $filename;
    $filename = '' unless defined $filename;

    return $filename;
}

#
# ->channel_eq  -- defined
#
# Compare two channels.
#
# It's hard to know for certain that two channels are equivalent, so we
# compare filenames.  This is not correct, of course, but it will do for
# what we're trying to achieve here, namely avoid duplicates if possible
# when traces are remapped to Carp::Datum.
#
sub channel_eq {
    my $self = shift;
    my ($chan1, $chan2) = @_;
    my $fn1 = $self->chanfn($chan1);
    my $fn2 = $self->chanfn($chan2);
    return $fn1 eq $fn2;
}

#
# ->write       -- defined
#
sub write {
    my $self = shift;
    my ($channel, $priority, $logstring) = @_;
    my $chan = $self->channel($channel);
    return unless $chan;

    $chan->write($priority, $logstring);
}

#
# ->channel
#
# Return channel object (one of the Log::Agent::Channel::* objects)
#
sub channel {
    my $self = shift;
    my ($name) = @_;
    my $obj = $self->channel_obj->{$name};
    $obj = $self->open_channel($name) unless $obj;
    return $obj;
}


#
# ->open_channel
#
# Open given channel according to the configured channel description and
# return the object file descriptor.
#
# If no channel of that name was defined, use 'error' or STDERR.
#
sub open_channel {
    my $self = shift;
    my ($name) = @_;
    my $filename = $self->channels->{$name};

    #
    # Handle possible logfile rotation, which may be defined globally
    # or on a file by file basis.
    #

    my $rotate;        # A Log::Agent::Rotate object
    if (ref $filename eq 'ARRAY') {
        ($filename, $rotate) = @$filename;
    } else {
        $rotate = $self->rotate;
    }

    my @common_args = (
        -prefix   => $self->prefix,
        -stampfmt => $self->stampfmt,
        -showpid  => $self->showpid,
    );
    my @other_args;
    my $type;

    #
    # No channel defined, use 'error', or revert to STDERR
    #

    unless (defined $filename && length $filename) {
        $filename = $self->channels->{'error'};
        ($filename, $rotate) = @$filename if ref $filename eq 'ARRAY';
    }

    unless (defined $filename && length $filename) {
        require Log::Agent::Channel::Handle;
        select((select(main::STDERR), $| = 1)[0]);
        $type = "Log::Agent::Channel::Handle";
        @other_args = (-handle => \*main::STDERR);
    } else {
        require Log::Agent::Channel::File;
        $type = "Log::Agent::Channel::File";
        @other_args = (
            -filename   => $filename,
            -magic_open => $self->magic_open,
            -share      => 1,
        );
        push(@other_args, -fileperm   => $self->chanperm->{$name})
                if $self->chanperm->{$name};
        push(@other_args, -rotate => $rotate) if ref $rotate;
    }

    return $self->channel_obj->{$name} =
            $type->make(@common_args, @other_args);
}

#
# ->emit_output
#
# Force error message to the regular 'output' channel with a specified tag.
#
sub emit_output {
    my $self = shift;
    my ($prio, $tag, $str) = @_;
    my $cstr = $str->clone;       # We're prepending tag on a copy
    $cstr->prepend("$tag: ");
    $self->write('output', $prio, $cstr);
}

###
### Redefined routines to handle duperr
###

#
# ->logconfess
#
# When `duperr' is true, emit message on the 'output' channel prefixed
# with FATAL.
#
sub logconfess {
    my $self = shift;
    my ($str) = @_;
    $self->emit_output('critical', "FATAL", $str) if $self->duperr;
    $self->SUPER::logconfess($str);    # Carp strips calls within hierarchy
}

#
# ->logxcroak
#
# When `duperr' is true, emit message on the 'output' channel prefixed
# with FATAL.
#
sub logxcroak {
    my $self = shift;
    my ($offset, $str) = @_;
    my $msg = Log::Agent::Message->make(
        $self->carpmess($offset, $str, \&Carp::shortmess)
    );
    $self->emit_output('critical', "FATAL", $msg) if $self->duperr;

    #
    # Carp strips calls within hierarchy, so that new call should not show,
    # there's no need to adjust the frame offset.
    #
    $self->SUPER::logdie($msg);
}

#
# ->logdie
#
# When `duperr' is true, emit message on the 'output' channel prefixed
# with FATAL.
#
sub logdie {
    my $self = shift;
    my ($str) = @_;
    $self->emit_output('critical', "FATAL", $str) if $self->duperr;
    $self->SUPER::logdie($str);
}

#
# ->logerr
#
# When `duperr' is true, emit message on the 'output' channel prefixed
# with ERROR.
#
sub logerr {
    my $self = shift;
    my ($str) = @_;
    $self->emit_output('error', "ERROR", $str) if $self->duperr;
    $self->SUPER::logerr($str);
}

#
# ->logwarn
#
# When `duperr' is true, emit message on the 'output' channel prefixed
# with WARNING.
#
sub logwarn {
    my $self = shift;
    my ($str) = @_;
    $self->emit_output('warning', "WARNING", $str) if $self->duperr;
    $self->SUPER::logwarn($str);
}

#
# ->logxcarp
#
# When `duperr' is true, emit message on the 'output' channel prefixed
# with WARNING.
#
sub logxcarp {
    my $self = shift;
    my ($offset, $str) = @_;
    my $msg = Log::Agent::Message->make(
        $self->carpmess($offset, $str, \&Carp::shortmess)
    );
    $self->emit_output('warning', "WARNING", $msg) if $self->duperr;
    $self->SUPER::logwarn($msg);
}

#
# ->DESTROY
#
# Close all opened channels, so they may be removed from the common pool.
#
sub DESTROY {
    my $self = shift;
    my $channel_obj = $self->channel_obj;
    return unless defined $channel_obj;
    foreach my $chan (values %$channel_obj) {
        $chan->close if defined $chan;
    }
}

1;        # for require
__END__