Koha-clms/Koha/Logger.pm

package Koha::Logger;

# Copyright 2015 ByWater Solutions
# kyle@bywatersolutions.com
#
# This file is part of Koha.
#
# Koha is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or
# (at your option) any later version.
#
# Koha is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Koha; if not, see <http://www.gnu.org/licenses>.

=head1 NAME

Koha::Logger

=head1 SYNOPSIS

    use Koha::Logger;

    my $logger = Koha::Logger->get;
    $logger->warn( 'WARNING: Serious error encountered' );
    $logger->debug( 'I thought that this code was not used' );

=head1 FUNCTIONS

=cut

use Modern::Perl;

use Log::Log4perl;
use Carp;

use C4::Context;

BEGIN {
    Log::Log4perl->wrapper_register(__PACKAGE__);
}

=head2 get

    Returns a logger object (based on log4perl).
    Category and interface hash parameter are optional.
    Normally, the category should follow the current package and the interface
    should be set correctly via C4::Context.

=cut

sub get {
    my ( $class, $params ) = @_;
    my $interface = $params ? ( $params->{interface} || C4::Context->interface ) : C4::Context->interface;
    my $category = $params ? ( $params->{category} || caller ) : caller;
    my $l4pcat = $interface . '.' . $category;

    my $init = _init();
    my $self = {};
    if ($init) {
        $self->{logger} = Log::Log4perl->get_logger($l4pcat);
        $self->{cat}    = $l4pcat;
        $self->{logs}   = $init if ref $init;
    }
    bless $self, $class;
    return $self;
}

=head1 INTERNALS

=head2 AUTOLOAD

    In order to prevent a crash when log4perl cannot write to Koha logfile,
    we check first before calling log4perl.
    If log4perl would add such a check, this would no longer be needed.

=cut

sub AUTOLOAD {
    my ( $self, $line ) = @_;
    my $method = $Koha::Logger::AUTOLOAD;
    $method =~ s/^Koha::Logger:://;

    if ( !exists $self->{logger} ) {

        #do not use log4perl; no print to stderr
    }
    elsif ( !$self->_recheck_logfile ) {
        warn "Log file not writable for log4perl";
        warn "$method: $line" if $line;
    }
    elsif ( $self->{logger}->can($method) ) {    #use log4perl
        $self->{logger}->$method($line);
        return 1;
    }
    else {                                       # we should not really get here
        warn "ERROR: Unsupported method $method";
    }
    return;
}

=head2 DESTROY

    Dummy destroy to prevent call to AUTOLOAD

=cut

sub DESTROY { }

=head2 _init, _check_conf and _recheck_logfile

=cut

sub _init {
    my $rv;
    if ( exists $ENV{"LOG4PERL_CONF"} and $ENV{'LOG4PERL_CONF'} and -s $ENV{"LOG4PERL_CONF"} ) {

        # Check for web server level configuration first
        # In this case we ASSUME that you correctly arranged logfile
        # permissions. If not, log4perl will crash on you.
        # We will not parse apache files here.
        Log::Log4perl->init_once( $ENV{"LOG4PERL_CONF"} );
    }
    elsif ( C4::Context->config("log4perl_conf") ) {

        # Now look in the koha conf file. We only check the permissions of
        # the default logfiles. For the rest, we again ASSUME that
        # you arranged file permissions.
        my $conf = C4::Context->config("log4perl_conf");
        if ( $rv = _check_conf($conf) ) {
            Log::Log4perl->init_once($conf);
            return $rv;
        }
        else {
            return 0;
        }
    }
    else {
        # This means that you do not use log4perl currently.
        # We will not be forcing it.
        return 0;
    }
    return 1;    # if we make it here, log4perl did not crash :)
}

sub _check_conf {    # check logfiles in log4perl config (at initialization)
    my $file = shift;
    return if !-r $file;
    open my $fh, '<', $file;
    my @lines = <$fh>;
    close $fh;
    my @logs;
    foreach my $l (@lines) {
        if ( $l =~ /(OPAC|INTRANET)\.filename\s*=\s*(.*)\s*$/i ) {

            # we only check the two default logfiles, skipping additional ones
            return if !-w $2;
            push @logs, $1 . ':' . $2;
        }
    }
    return if !@logs;    # we should find one
    return \@logs;
}

sub _recheck_logfile {    # recheck saved logfile when logging message
    my $self = shift;

    return 1 if !exists $self->{logs};    # remember? your own responsibility
    my $opac = $self->{cat} =~ /^OPAC/;
    my $log;
    foreach ( @{ $self->{logs} } ) {
        $log = $_ if $opac && /^OPAC:/ || !$opac && /^INTRANET:/;
        last if $log;
    }
    $log =~ s/^(OPAC|INTRANET)://;
    return -w $log;
}

=head2 debug_to_screen

Adds a new appender for the given logger that will log all DEBUG-and-higher messages to stderr.
Useful for daemons.

=cut

sub debug_to_screen {
    my $self = shift;

    return unless ( $self->{logger} );

    my $appender = Log::Log4perl::Appender->new(
        'Log::Log4perl::Appender::Screen',
        stderr => 1,
        utf8 => 1,
        name => 'debug_to_screen' # We need a specific name to prevent duplicates
    );

    $appender->threshold( $Log::Log4perl::DEBUG );
    $self->{logger}->add_appender( $appender );
    $self->{logger}->level( $Log::Log4perl::DEBUG );
}

=head1 AUTHOR

Kyle M Hall, E<lt>kyle@bywatersolutions.comE<gt>
Marcel de Rooy, Rijksmuseum

=cut

1;

__END__