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
  41 use C4::Context;
  42
  43 BEGIN {
  44     Log::Log4perl->wrapper_register(__PACKAGE__);
  45 }
  46
  47 =head2 get
  48
  49     Returns a logger object (based on log4perl).
  50     Category and interface hash parameter are optional.
  51     Normally, the category should follow the current package and the interface
  52     should be set correctly via C4::Context.
  53
  54 =cut
  55
  56 sub get {
  57     my ( $class, $params ) = @_;
  58     my $interface = $params ? ( $params->{interface} || C4::Context->interface ) : C4::Context->interface;
  59     my $category = $params ? ( $params->{category} || caller ) : caller;
  60     my $l4pcat = ( C4::Context->psgi_env ? 'plack-' : q{} ) . $interface . '.' . $category;
  61
  62     my $init = _init();
  63     my $self = {};
  64     if ($init) {
  65         $self->{logger} = Log::Log4perl->get_logger($l4pcat);
  66         $self->{cat}    = $l4pcat;
  67         $self->{logs}   = $init if ref $init;
  68     }
  69     bless $self, $class;
  70     return $self;
  71 }
  72
  73 =head2 put_mdc
  74
  75 my $foo = $logger->put_mdc('foo', $foo );
  76
  77 put_mdc sets global thread specific data that can be access later when generating log lines
  78 via the "%X{key}" placeholder in Log::Log4perl::Layout::PatternLayouts.
  79
  80 =cut
  81
  82 sub put_mdc {
  83     my ( $self, $key, $value ) = @_;
  84
  85     Log::Log4perl::MDC->put( $key, $value );
  86 }
  87
  88 =head2 get_mdc
  89
  90 my $foo = $logger->get_mdc('foo');
  91
  92 Retrieves the stored mdc value from the stored map.
  93
  94 =cut
  95
  96 sub get_mdc {
  97     my ( $self, $key ) = @_;
  98
  99     return Log::Log4perl::MDC->get( $key );
 100 }
 101
 102 =head2 clear_mdc
 103
 104 $logger->clear_mdc();
 105
 106 Removes *all* stored key/value pairs from the MDC map.
 107
 108 =cut
 109
 110 sub clear_mdc {
 111     my ( $self, $key ) = @_;
 112
 113     return Log::Log4perl::MDC->remove( $key );
 114 }
 115
 116 =head1 INTERNALS
 117
 118 =head2 AUTOLOAD
 119
 120     In order to prevent a crash when log4perl cannot write to Koha logfile,
 121     we check first before calling log4perl.
 122     If log4perl would add such a check, this would no longer be needed.
 123
 124 =cut
 125
 126 sub AUTOLOAD {
 127     my ( $self, $line ) = @_;
 128     my $method = $Koha::Logger::AUTOLOAD;
 129     $method =~ s/^Koha::Logger:://;
 130
 131     if ( $self->{logger}->can($method) ) {    #use log4perl
 132         return $self->{logger}->$method($line);
 133     }
 134     else {                                       # we should not really get here
 135         warn "ERROR: Unsupported method $method";
 136     }
 137     return;
 138 }
 139
 140 =head2 DESTROY
 141
 142     Dummy destroy to prevent call to AUTOLOAD
 143
 144 =cut
 145
 146 sub DESTROY { }
 147
 148 =head2 _init
 149
 150 =cut
 151
 152 sub _init {
 153
 154     my $log4perl_config =
 155           exists $ENV{"LOG4PERL_CONF"}
 156               && $ENV{'LOG4PERL_CONF'}
 157            && -s $ENV{"LOG4PERL_CONF"}
 158       # Check for web server level configuration first
 159       # In this case we ASSUME that you correctly arranged logfile
 160       # permissions. If not, log4perl will crash on you.
 161       ? $ENV{"LOG4PERL_CONF"}
 162       : C4::Context->config("log4perl_conf");
 163
 164     # This will explode with the relevant error message if something is wrong in the config file
 165     return Log::Log4perl->init_once($log4perl_config);
 166 }
 167
 168 =head2 debug_to_screen
 169
 170 Adds a new appender for the given logger that will log all DEBUG-and-higher messages to stderr.
 171 Useful for daemons.
 172
 173 =cut
 174
 175 sub debug_to_screen {
 176     my $self = shift;
 177
 178     return unless ( $self->{logger} );
 179
 180     my $appender = Log::Log4perl::Appender->new(
 181         'Log::Log4perl::Appender::Screen',
 182         stderr => 1,
 183         utf8 => 1,
 184         name => 'debug_to_screen' # We need a specific name to prevent duplicates
 185     );
 186
 187     $appender->threshold( $Log::Log4perl::DEBUG );
 188     $self->{logger}->add_appender( $appender );
 189     $self->{logger}->level( $Log::Log4perl::DEBUG );
 190 }
 191
 192 =head2 context
 193
 194 Mojolicous 8.23 added a "context" method, which Mojolicious will die
 195 on if it's missing from the logger.
 196
 197 Note: We are just preventing a crash here not returning a new context logger.
 198
 199 =cut
 200
 201 sub context {
 202     my ( $self, @context ) = @_;
 203     $self->{context} = \@context;
 204     return $self;
 205 }
 206
 207 =head1 AUTHOR
 208
 209 Kyle M Hall, E<lt>kyle@bywatersolutions.comE<gt>
 210 Marcel de Rooy, Rijksmuseum
 211
 212 =cut
 213
 214 1;
 215
 216 __END__