File Coverage

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

Criterion	Covered	Total	%
statement	81	98	82.6
branch	29	54	53.7
condition	6	17	35.2
subroutine	15	16	93.7
pod	3	11	27.2
total	134	196	68.3

###########################################################################
#
#   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::Channel;
require Log::Agent::Prefixer;

########################################################################
package Log::Agent::Channel::File;

use vars qw(@ISA);

@ISA = qw(Log::Agent::Channel Log::Agent::Prefixer);

use Symbol;
use Fcntl;
use Log::Agent::Stamping;

#
# ->make        -- defined
#
# Creation routine.
#
# Attributes (and switches that set them):
#
# prefix        the application name
# stampfmt      stamping format ("syslog", "date", "own", "none") or closure
# showpid       whether to show pid after prefix in []
# filename      file name to open (magical open needs -magic_open)
# fileperm      permissions to open file with
# magic_open    flag to tell whether ">>file" or "|proc" are allowed filenames
# rotate        rotating policy for this file
# share         true implies that non-magic filenames share the same fd object
# no_ucfirst    don't capitalize first letter of message when no prefix
# no_prefixing  don't prefix logs
# no_newline    never append any newline character at the end of messages
#
# Other attributes:
#
# fd            records Log::Agent::File::* objects
# crlf          the new-line marker for this OS ("\n" on UNIX)
# warned        records calls made to hardwired warn() to only do them once
#
sub make {
    my $self = bless {}, shift;
    my (%args) = @_;

    my %set = (
        -prefix       => \$self->{'prefix'},
        -stampfmt     => \$self->{'stampfmt'},
        -showpid      => \$self->{'showpid'},
        -magic_open   => \$self->{'magic_open'},
        -filename     => \$self->{'filename'},
        -fileperm     => \$self->{'fileperm'},
        -rotate       => \$self->{'rotate'},
        -no_ucfirst   => \$self->{'no_ucfirst'},
        -no_prefixing => \$self->{'no_prefixing'},
        -no_newline   => \$self->{'no_newline'},
        -share        => \$self->{'share'},
    );

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

    #
    # Initialize proper time-stamping routine.
    #

    $self->{'stampfmt'} = stamping_fn($self->stampfmt)
        unless ref $self->stampfmt eq 'CODE';

    $self->{'fd'} = undef;
    $self->{'crlf'} = $^O =~ /^dos|win/i ? "\r\n" : "\n";
    $self->{'warned'} = {};

    if ($self->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 magic_open { $_[0]->{'magic_open'} }
sub rotate     { $_[0]->{'rotate'}     }
sub filename   { $_[0]->{'filename'}   }
sub fileperm   { $_[0]->{'fileperm'}   }
sub fd         { $_[0]->{'fd'}         }
sub share      { $_[0]->{'share'}      }
sub warned     { $_[0]->{'warned'}     }

#
# ->write            -- defined
#
# Write logstring to the file.
# Priority is ignored by this channel.
#
sub write {
    my $self = shift;
    my ($priority, $logstring) = @_;

    #
    # This routine is called often...
    # Bypass the attribute access routines.
    #

    my $fd = $self->{fd};
    $fd = $self->open unless $fd;
    return unless ref $fd;

    my $prefix = '';
    $prefix = $self->prefixing_string(\$logstring)
        unless $self->{no_prefixing};

    my $crlf = '';
    $crlf = $self->{crlf} unless $self->{no_newline};

    #
    # The innocent-looking ->print statement below is NOT a polymorphic call.
    #
    # It can be targetted on various Log::Agent::File::* objects, which
    # all happen to provide a print() feature with the same signature.
    # However, those clases have no inheritance relationship because Perl
    # is not typed, and the ancestor would be a deferred class anyway.
    #

    $fd->print($prefix, $logstring, $crlf);
    return;
}

#
# ->open
#
# Open channel, and return the opened file descriptor.
# Also record opened file within $self->fd.
#
sub open {
    my $self = shift;
    my $filename = $self->filename;

    require Log::Agent::File::Native;

    my $fobj;
    my $note;

    #
    # They may use ">file" or "|proc" as channel files if -magic_open
    #

    if ($filename =~ /^\s*[>|]/ && $self->magic_open) {

        # restrict the permissions
        my $mask = umask;
        umask($mask | 0666 ^ $self->fileperm) if defined $self->fileperm;

        # open the file
        my $h = gensym;
        $fobj = Log::Agent::File::Native->make($h) if open($h, $filename);

        # restore the permissions
        umask $mask;

    } else {
        #
        # If the file is already opened, and the current channel can be
        # shared, do not re-open it: share the same Log::Agent::File::* object,
        # along with its rotation policy.
        #

        my $rotate = $self->rotate;                # A Log::Agent::Rotate object
        my $pool;

        if ($self->share) {
            require Log::Agent::File_Pool;
            $pool = Log::Agent::File_Pool::file_pool();
            my ($eobj, $erot) = $pool->get($filename);

            if (defined $eobj) {
                $fobj = $eobj;            # Reuse same object
                $note = "rotation for '$filename' may be wrong" .
                    " (shared with distinct policies)" if
                        defined $erot && defined $rotate &&
                        !$erot->is_same($rotate);
            }
        }

        unless (defined $fobj) {
            if (defined $rotate) {
                $fobj = Log::Agent::File::Rotate->make($filename, $rotate);
            } else {
                my $h = gensym;
                $fobj = Log::Agent::File::Native->make($h)
                        if sysopen($h, $filename, O_CREAT|O_APPEND|O_WRONLY,
                        defined $self->fileperm ? $self->fileperm : 0666);
            }
        }

        #
        # Record object in pool if shared, even if already present.
        # We maintain a refcount of all the shared items.
        #

        $pool->put($filename, $fobj, $rotate)
            if defined $fobj && $self->share;
    }

    #
    # If an error occurred, we have no choice but to emit a warning via warn().
    # Otherwise, the error would disappear, and we know they don't want to
    # silence us, or they would not try to open a logfile.
    #
    # Warn only once per filename though.
    #

    unless (defined $fobj) {
        my $prefix = $self->prefixing_string() || "$0: ";
        warn "${prefix}can't open logfile \"$filename\": $!\n"
            unless $self->warned->{$filename}++;
        return undef;
    }

    $self->{fd} = $fobj || 1;    # Avoid recursion in open if not defined

    #
    # Print the note, using ->write() now that $self->fd is recorded.
    #

    if (defined $note) {
        $note .= $self->crlf if $self->no_newline;
        $self->write(undef, $note);
    }

    return $fobj;
}

#
# ->close            -- defined
#
sub close {
    my $self = shift;
    my $fd = $self->fd;
    return unless ref $fd;

    $self->{fd} = 1;            # Prevents further opening from ->write
    unless ($self->share) {
        $fd->close;
        return;
    }

    #
    # A shared file is physically closed only when the last reference
    # to it is removed.
    #

    my $pool = Log::Agent::File_Pool::file_pool();
    $fd->close if $pool->remove($self->filename);
    return;
}

1;    # for require
__END__