File Coverage

blib/lib/Tie/Syslog.pm

Criterion	Covered	Total	%
statement	95	112	84.8
branch	27	52	51.9
condition	1	3	33.3
subroutine	18	22	81.8
pod	1	1	100.0
total	142	190	74.7

package Tie::Syslog;

$Tie::Syslog::VERSION = '2.04.03';

use 5.006;
use strict;
use warnings;
use Carp qw/carp croak confess/;
use Sys::Syslog qw/:standard :macros/;

# ------------------------------------------------------------------------------
# Define all default handle-tying subs, so that they can be autoloaded if
# necessary.
use subs qw(
    TIEHANDLE
    WRITE
    PRINT
    PRINTF
    READ
    READLINE
    GETC
    CLOSE
    OPEN
    BINMODE
    EOF
    TELL
    SEEK
    UNTIE
    FILENO
);

# --- 'Public' Globals - DEFAULTS ----------------------------------------------
$Tie::Syslog::ident = (split '/', $0)[-1];
$Tie::Syslog::logopt = 'pid,ndelay';

# --- 'Private' Globals --------------------------------------------------------
my @mandatory_opts = ('facility', 'priority');
# Since calling openlog() twice for the same facility makes it croak, we will
# keep a list of already-open-facility-connections. This will also be useful to
# know if we must call closelog().
my %open_connections;


# ------------------------------------------------------------------------------
# 'Private' functions
# ------------------------------------------------------------------------------

########################
# sub _parse_config(@) #
########################
# This sub is responsible of setting up the configuration for the subsequent
# openlog() and syslog() calls. It returns a reference to a hash that contains
# configuration parameters for our Tie::Syslog object.
sub _parse_config(@) {

    my $params;

    if (ref($_[0]) eq 'HASH') {
        # New-style configuration
        # Copy values so we don't risk changing an existing reference.
        # NOTE: this configuration has no defaults defined. 'priority' and
        # 'facility' must be explicitly set.
        $params = {
            %{ shift() },
        };
    } else {
        # Old-style configuration, parameters are:
        # 'facility.loglevel', 'identity', 'logopt', 'setlogsock options'
        # Old-style config provided local0.error as default, in case nothing
        # else was specified. We keep this defaults only for old-style config.
        my ($facility, $priority) =
            @_ ? split '\.', shift : ('LOG_LOCAL0', 'LOG_ERR');
        $Tie::Syslog::ident  = shift if @_;
        $Tie::Syslog::logopt = shift if @_;
        # There can still be one option: socket type for setlogsock. Since we
        # do not call setlogsock (according to Sys::Syslog rules), we
        # may (safely?) ignore this option.
        $params = {
            facility => $facility,
            priority => $priority,
        };
    }

    # Normalize names
    for ('facility', 'priority') {
        next unless $params->{ $_ };
        $params->{ $_ } =  uc( $params->{ $_ } );
        $params->{ $_ } =~ s/EMERGENCY/EMERG/;
        $params->{ $_ } =~ s/ERROR/ERR/;
        $params->{ $_ } =~ s/CRITICAL/CRIT/;
        $params->{ $_ } =  'LOG_' . $params->{ $_ }
            unless $params->{ $_ } =~ /^LOG_/;
    }

    return $params;
}

# ------------------------------------------------------------------------------
# Accessors/mutators
# ------------------------------------------------------------------------------

# Because writing $self->facility() is better than writing $self->{'facility'}
for my $opt (@mandatory_opts) {
    no strict 'refs';
    *$opt = sub {
        my $self = shift;
        $self->{$opt} = shift if @_;
        return $self->{$opt};
    };
}

# ------------------------------------------------------------------------------
# Handle tying methods - see 'perldoc perltie' and 'perldoc Tie::Handle'
# ------------------------------------------------------------------------------

# This is the method called by the 'tie' function.
# It returns a hash reference blessed to Tie::Syslog package.
sub TIEHANDLE {
    my $self;

    # Set log mask as permissive as possible - masking will be done at syslog
    # level
    eval {
        setlogmask(
            LOG_MASK(LOG_EMERG)|
            LOG_MASK(LOG_ALERT)|
            LOG_MASK(LOG_CRIT)|
            LOG_MASK(LOG_ERR)|
            LOG_MASK(LOG_WARNING)|
            LOG_MASK(LOG_NOTICE)|
            LOG_MASK(LOG_INFO)|
            LOG_MASK(LOG_DEBUG)
        );
    };
    carp "Call to setlogmask() failed: $@"
        if $@;

    # See if we were called as an instance method, or as a class method.
    # In the first case, we provide a copy-constructor that takes the invocant
    # as a prototype and uses the same configuration.
    if (my $pkg = ref($_[0])) {
        # Use a copy-constructor, providing support for
        # single-parameter-override via the @_
        my $prototype = shift;
        my $other_parameters = _parse_config @_;
        $self = bless {
                %$prototype,
                %$other_parameters,
            }, $pkg;
    } else {
        # Called as a class method
        $pkg = shift;

        my $parameters = _parse_config @_;

        $self = bless $parameters, $pkg;
    }

    # Check for all mandatory values
    for (@mandatory_opts) {
        croak "You must provide value for '$_' option"
            unless $self->{$_};
    }

    # Now openlog() if needed, by calling our own open()
    $self->OPEN();

    # Finally return
    return $self;
}

sub OPEN {
    # Ignore any parameter passed, since we just call openlog() with parameters
    # got from initialization
    my $self = shift;
    my $f = $self->facility;
    eval {
        openlog($Tie::Syslog::ident, $Tie::Syslog::logopt, $self->facility)
            unless $open_connections{ $f };
    };
    croak "openlog() failed with errors: $@"
        if $@;
    $open_connections{ $f } = 1;
    return $self->{'is_open'} = 1;
}

# Usually, we should have just one connection to syslog. It may happen, though,
# that multiple connections have been established, if multiple facilities have
# been used (but please NOTE that this is AGAINST Sys::Syslog rules).
# In the latter case, closelog() will just close the last connection, which may
# be completely unrelated to the handle we're closing here. In case of multiple
# connections, just skip closelog().
sub CLOSE {
    my $self = shift;
    return 1 unless $self->{'is_open'};
    $self->{'is_open'} = 0;
    unless (scalar(keys(%open_connections)) > 1) {
        eval {
            closelog();
        };
        croak "Call to closelog() failed with errors: $@"
            if $@;
        delete $open_connections{ $self->facility };
    }
    return 1;
}

sub PRINT {
    my $self = shift;
    carp "Cannot PRINT to a closed filehandle!" unless $self->{'is_open'};
    eval { syslog $self->facility."|".$self->priority, "@_" };
    croak "PRINT failed with errors: $@"
        if $@;
}

sub PRINTF {
    my $self = shift;
    carp "Cannot PRINTF to a closed filehandle!" unless $self->{'is_open'};
    my $format = shift;
    eval { syslog $self->facility."|".$self->priority, $format, @_ };
    croak "PRINTF failed with errors: $@"
        if $@;
}

# Provide a fallback method for write
sub WRITE {
    my $self = shift;
    my $string = shift;
    my $length = shift || length $string;
    my $offset = shift; # Ignored

    $self->PRINT(substr($string, 0, $length));

    return $length;
}

# This peeks a little into Sys:Syslog internals, so it might break sooner or
# later. Expect this to happen.
#   fileno() of socket if available
#   -1 if we have an open handle
#   undef if we're not connected
# When Sys::Syslog uses 'native' connection, *Sys::Syslog::SYSLOG is not
# defined, and $Sys::Syslog::connected is a lexical, so it's not accessible
# by us. In other words, we have to try and guess.
sub FILENO {
    my $self = shift;
    my $fd = fileno(*Sys::Syslog::SYSLOG);
    return defined($fd) ? $fd
        : $self->{'is_open'} ? -1 : undef;
}

sub DESTROY {
    my $self = shift;
    return 1 unless $self;
    $self->CLOSE();
    undef $self;
}

sub UNTIE {
    my $self = shift;
    return 1 unless $self;
    $self->DESTROY;
}


# ------------------------------------------------------------------------------
# Provide a graceful fallback for not(-yet?)-implemented methods
# ------------------------------------------------------------------------------
sub AUTOLOAD {
    my $self = shift;
    my $name = (split '::', our $AUTOLOAD)[-1];
    return if $name eq 'DESTROY';

    my $err = "$name operation not (yet?) supported";

    # See if errors are fatals
    my $errors_are_fatal = ref($self) ? $self->{'errors_are_fatal'} : 1;
    confess $err if $errors_are_fatal;

    # Install a handler for this operation if errors are nonfatal
    {
        no strict 'refs';
        *$name = sub {
            print "$name operation not (yet?) supported";
        }
    }

    $self->$name;
}


# ------------------------------------------------------------------------------
# Compatibility with Tie::Syslog v1.x
# ------------------------------------------------------------------------------
# die() and warn() print to STDERR
sub ExtendedSTDERR {
    return 1;
}

'End of Tie::Syslog'
__END__