Koha/Logger.pm

   1 package Koha::Logger;
   2
   3 # Copyright 2015 ByWater Solutions
   4 # kyle@bywatersolutions.com
   5 #
   6 # This file is part of Koha.
   7 #
   8 # Koha is free software; you can redistribute it and/or modify it
   9 # under the terms of the GNU General Public License as published by
  10 # the Free Software Foundation; either version 3 of the License, or
  11 # (at your option) any later version.
  12 #
  13 # Koha is distributed in the hope that it will be useful, but
  14 # WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  16 # GNU General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public License
  19 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  20
  21 =head1 NAME
  22
  23 Koha::Logger
  24
  25 =head1 SYNOPSIS
  26
  27     use Koha::Logger;
  28
  29     my $logger = Koha::Logger->get;
  30     $logger->warn( 'WARNING: Serious error encountered' );
  31     $logger->debug( 'I thought that this code was not used' );
  32
  33 =head1 FUNCTIONS
  34
  35 =cut
  36
  37 use Modern::Perl;
  38
  39 use Log::Log4perl;
  40 use Carp;
  41
  42 use C4::Context;
  43
  44 BEGIN {
  45     Log::Log4perl->wrapper_register(__PACKAGE__);
  46 }
  47
  48 =head2 get
  49
  50     Returns a logger object (based on log4perl).
  51     Category and interface hash parameter are optional.
  52     Normally, the category should follow the current package and the interface
  53     should be set correctly via C4::Context.
  54
  55 =cut
  56
  57 sub get {
  58     my ( $class, $params ) = @_;
  59     my $interface = $params ? ( $params->{interface} || C4::Context->interface ) : C4::Context->interface;
  60     my $category = $params ? ( $params->{category} || caller ) : caller;
  61     my $l4pcat = $interface . '.' . $category;
  62
  63     my $init = _init();
  64     my $self = {};
  65     if ($init) {
  66         $self->{logger} = Log::Log4perl->get_logger($l4pcat);
  67         $self->{cat}    = $l4pcat;
  68         $self->{logs}   = $init if ref $init;
  69     }
  70     bless $self, $class;
  71     return $self;
  72 }
  73
  74 =head1 INTERNALS
  75
  76 =head2 AUTOLOAD
  77
  78     In order to prevent a crash when log4perl cannot write to Koha logfile,
  79     we check first before calling log4perl.
  80     If log4perl would add such a check, this would no longer be needed.
  81
  82 =cut
  83
  84 sub AUTOLOAD {
  85     my ( $self, $line ) = @_;
  86     my $method = $Koha::Logger::AUTOLOAD;
  87     $method =~ s/^Koha::Logger:://;
  88
  89     if ( !exists $self->{logger} ) {
  90
  91         #do not use log4perl; no print to stderr
  92     }
  93     elsif ( !$self->_recheck_logfile ) {
  94         warn "Log file not writable for log4perl";
  95         warn "$method: $line" if $line;
  96     }
  97     elsif ( $self->{logger}->can($method) ) {    #use log4perl
  98         $self->{logger}->$method($line);
  99         return 1;
 100     }
 101     else {                                       # we should not really get here
 102         warn "ERROR: Unsupported method $method";
 103     }
 104     return;
 105 }
 106
 107 =head2 DESTROY
 108
 109     Dummy destroy to prevent call to AUTOLOAD
 110
 111 =cut
 112
 113 sub DESTROY { }
 114
 115 =head2 _init, _recheck_logfile
 116
 117 =cut
 118
 119 sub _init {
 120
 121     my $log4perl_config =
 122           exists $ENV{"LOG4PERL_CONF"}
 123               && $ENV{'LOG4PERL_CONF'}
 124            && -s $ENV{"LOG4PERL_CONF"}
 125       # Check for web server level configuration first
 126       # In this case we ASSUME that you correctly arranged logfile
 127       # permissions. If not, log4perl will crash on you.
 128       ? $ENV{"LOG4PERL_CONF"}
 129       : C4::Context->config("log4perl_conf");
 130
 131     # This will explode with the relevant error message if something is wrong in the config file
 132     return Log::Log4perl->init_once($log4perl_config);
 133 }
 134
 135 sub _recheck_logfile {    # recheck saved logfile when logging message
 136     my $self = shift;
 137
 138     return 1 if !exists $self->{logs};    # remember? your own responsibility
 139     my $opac = $self->{cat} =~ /^OPAC/;
 140     my $log;
 141     foreach ( @{ $self->{logs} } ) {
 142         $log = $_ if $opac && /^OPAC:/ || !$opac && /^INTRANET:/;
 143         last if $log;
 144     }
 145     $log =~ s/^(OPAC|INTRANET)://;
 146     return -w $log;
 147 }
 148
 149 =head2 debug_to_screen
 150
 151 Adds a new appender for the given logger that will log all DEBUG-and-higher messages to stderr.
 152 Useful for daemons.
 153
 154 =cut
 155
 156 sub debug_to_screen {
 157     my $self = shift;
 158
 159     return unless ( $self->{logger} );
 160
 161     my $appender = Log::Log4perl::Appender->new(
 162         'Log::Log4perl::Appender::Screen',
 163         stderr => 1,
 164         utf8 => 1,
 165         name => 'debug_to_screen' # We need a specific name to prevent duplicates
 166     );
 167
 168     $appender->threshold( $Log::Log4perl::DEBUG );
 169     $self->{logger}->add_appender( $appender );
 170     $self->{logger}->level( $Log::Log4perl::DEBUG );
 171 }
 172
 173 =head1 AUTHOR
 174
 175 Kyle M Hall, E<lt>kyle@bywatersolutions.comE<gt>
 176 Marcel de Rooy, Rijksmuseum
 177
 178 =cut
 179
 180 1;
 181
 182 __END__