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