File Coverage

blib/lib/No/Worries/Syslog.pm

Criterion	Covered	Total	%
statement	58	96	60.4
branch	10	34	29.4
condition	0	3	0.0
subroutine	13	22	59.0
pod	8	8	100.0
total	89	163	54.6

#+##############################################################################
#                                                                              #
# File: No/Worries/Syslog.pm                                                   #
#                                                                              #
# Description: syslog handling without worries                                 #
#                                                                              #
#-##############################################################################

#
# module definition
#

package No::Worries::Syslog;
use strict;
use warnings;
use 5.005; # need the four-argument form of substr()
our $VERSION  = "1.6";
our $REVISION = sprintf("%d.%02d", q$Revision: 1.24 $ =~ /(\d+)\.(\d+)/);

#
# used modules
#

use Encode qw();
use No::Worries::Die qw(dief);
use No::Worries::Export qw(export_control);
use No::Worries::Log qw();
use No::Worries::String qw(string_trim);
use Params::Validate qw(validate :types);
use Sys::Syslog qw(openlog closelog syslog);
use URI::Escape qw(uri_escape);

#
# global variables
#

our($MaximumLength, $SplitLines);

#
# open a "connection" to syslog via openlog()
#

my %syslog_open_options = (
    ident    => { optional => 1, type => SCALAR, regex => qr/^[\w\-\.\/]+$/ },
    option   => { optional => 1, type => SCALAR, regex => qr/^\w+(,\w+)*$/ },
    facility => { optional => 1, type => SCALAR, regex => qr/^\w+$/ },
);

sub syslog_open (@) {
    my(%option);

    %option = validate(@_, \%syslog_open_options) if @_;
    # defaults which may differ from Sys::Syslog
    $option{option} = "ndelay,pid" unless $option{option};
    # we do not allow "nofatal" as this clashes with our error handling
    $option{option} =~ s/\bnofatal\b//g if $option{option};
    # simply call openlog() now...
    eval { openlog($option{ident}, $option{option}, $option{facility}) };
    dief("cannot openlog(): %s", $@) if $@;
}

#
# close a "connection" to syslog via closelog()
#

sub syslog_close () {
    # simply call closelog()
    eval { closelog() };
    dief("cannot closelog(): %s", $@) if $@;
}

#
# sanitize a string so that it can safely be given to syslog
#

sub syslog_sanitize ($) {
    my($string) = @_;
    my($flags, $tmp);

    $flags = "";
    # 1: try to UTF-8 encode it if it has the UTF-8 flag set
    if (Encode::is_utf8($string)) {
        # we use Encode::FB_DEFAULT to replace invalid characters
        local $@ = ""; # preserve $@!
        $tmp = Encode::encode("UTF-8", $string, Encode::FB_DEFAULT);
        unless ($tmp eq $string) {
            # encoded is indeed different, use it
            $string = $tmp;
            $flags .= "U";
        }
    }
    # 2: silently trim trailing spaces and replace tabs
    $string =~ s/\s+$//;
    $string =~ s/\t/    /g;
    # 3: try to URI escape non-printable characters plus # % \ `
    $tmp = uri_escape($string, q{\x00-\x1f\x7f-\xff\x23\x25\x5c\x60});
    unless ($tmp eq $string) {
        # escaped is indeed different, use it
        $string = $tmp;
        $flags .= "E";
    }
    # 4: truncate if it is too long, taking into acount the possible flags
    $tmp = length($string) - $MaximumLength + 4;
    if ($tmp > 0) {
        substr($string, $MaximumLength - 4, $tmp, "");
        $flags .= "T";
    }
    # 5: append the flags to keep track of what happened to the string
    $string .= "#$flags" if $flags;
    # that should be enough...
    return($string);
}

#
# handy wrappers around syslog()
#

sub _syslog_any ($$@) {
    my($priority, $prefix, $message, @arguments) = @_;
    my($separator, $string);

    $message = sprintf($message, @arguments) if @arguments;
    $message = string_trim($message);
    $separator = " ";
    if ($SplitLines and $message =~ /\n/) {
        # multiple syslog entries
        foreach my $line (split(/\n/, $message)) {
            $string = syslog_sanitize("[$prefix]$separator$line");
            eval { syslog($priority, $string) };
            dief("cannot syslog(): %s", $@) if $@;
            $separator = "+";
        }
    } else {
        # one syslog entry
        $string = syslog_sanitize("[$prefix]$separator$message");
        eval { syslog($priority, $string) };
        dief("cannot syslog(): %s", $@) if $@;
    }
}

sub syslog_error   ($@) { _syslog_any("err",     "ERROR",   @_) }
sub syslog_warning ($@) { _syslog_any("warning", "WARNING", @_) }
sub syslog_info    ($@) { _syslog_any("info",    "INFO",    @_) }
sub syslog_debug   ($@) { _syslog_any("debug",   "DEBUG",   @_) }

#
# No::Worries::Log-compatible handler
#

sub log2syslog ($) {
    my($info) = @_;

    if ($info->{level} eq "error") {
        syslog_error($info->{message});
    } elsif ($info->{level} eq "warning") {
        syslog_warning($info->{message});
    } elsif ($info->{level} eq "info") {
        syslog_info($info->{message});
    } else {
        syslog_debug($info->{message}); # for debug _and_ trace
    }
    return(1);
}

#
# module initialization
#

$MaximumLength = 1000;
$SplitLines = 1;

#
# export control
#

sub import : method {
    my($pkg, %exported);

    $pkg = shift(@_);
    grep($exported{$_}++,
         map("syslog_$_", qw(open close sanitize error warning info debug)));
    $exported{"log2syslog"} = sub { $No::Worries::Log::Handler = \&log2syslog };
    export_control(scalar(caller()), $pkg, \%exported, @_);
}

1;

__DATA__