View | Details | Raw Unified | Return to bug 13413
Collapse All | Expand All

(-)a/Koha/Log.pm (+405 lines)
Line 0 Link Here
1
package Koha::Log;
2
3
# Copyright 2014 Catalyst IT
4
#
5
# This file is part of Koha.
6
#
7
# Koha is free software; you can redistribute it and/or modify it
8
# under the terms of the GNU General Public License as published by
9
# the Free Software Foundation; either version 3 of the License, or
10
# (at your option) any later version.
11
#
12
# Koha is distributed in the hope that it will be useful, but
13
# WITHOUT ANY WARRANTY; without even the implied warranty of
14
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15
# GNU General Public License for more details.
16
#
17
# You should have received a copy of the GNU General Public License
18
# along with Koha; if not, see <http://www.gnu.org/licenses>.
19
20
use Modern::Perl;
21
use Log::Contextual qw(set_logger with_logger);
22
use Exporter::Declare;
23
use base 'Log::Contextual';
24
25
exports qw(with_debug with_logger create_logger set_default_logger);
26
27
=head1 NAME
28
29
Koha::Log - Logging for Koha
30
31
=head1 SYNOPSIS
32
33
  # Main script
34
  use Koha::Log;
35
  # optionally
36
  Koha::Log::set_default_logger('File', {filename => $LOG_FILE});
37
38
  log_error { "Error" };
39
  log_warn { "Warn" };
40
  log_info { "Info" };
41
42
  # Some module
43
  use Koha::Log;
44
  log_error { "Error" };
45
46
=head1 DESCRIPTION
47
48
  This is a combination of Log::Contextual and customised Log:Dispatcher
49
  Why?
50
  1. Because it uses code blocks to log, so complex debugging can be left in
51
     without any performance penalty
52
  2. Some useful things can be done
53
54
  Out of the box it logs to STDERR
55
56
=head1 LOG LEVELS
57
58
  We support log levels of debug info warn error fatal
59
  Not sure how useful is fatal;
60
  trace level is TODO
61
62
  Log functions are log_I<level>
63
64
=head1 Log::Contextual FUNCTIONS
65
66
By default, log_* functions are exported. For the full list see C<Log::Contextual>
67
68
=cut
69
70
my $default_logger;
71
72
sub arg_default_logger {
73
    return $_[1] || ($default_logger ||= create_logger());
74
}
75
sub arg_levels { [qw(debug trace info warn error fatal)] }
76
sub default_import { ':log' }
77
78
=head1 FUNCTIONS
79
80
=head2 create_logger( Sink1 => {params}, Sink2 => {params} )
81
82
  If no sinks are given, Stderr is assumed
83
84
=head3 Sinks
85
86
Sinks are C<Log::Dispatch::*> module names, eg File, Syslog etc
87
We added two more:
88
  C<Stdout> which is a shortcut for Screen stderr => 0
89
  C<Stderr> which is a shortcut for Screen stderr => 1
90
91
  Default sink parameters:
92
    C<min_level> - if env KOHA_DEBUG is set to true valu then 'debug' else 'info'
93
    C<name>      - lower case sink module name
94
95
  Filename rules for C<File>) sink:
96
    Filenames with absolute paths are honoured
97
    otherwise files are placed in koha config logdir
98
99
  Default C<facility> parameter for C<Syslog>) sink is I<user>
100
101
=cut
102
103
sub create_logger {
104
    my %sink_defs = @_ ? @_ : (Stderr => {});
105
    my $logger = Koha::Log::Dispatch->new;
106
    while (my ($sink, $params) = each %sink_defs) {
107
        $logger->add_sink($sink, $params);
108
    }
109
    return $logger;
110
}
111
112
=head1 DEFAULT LOGGER FUNCTIONS
113
114
Following functions operate on the default logger.
115
Default logger should be used most of the time.
116
117
=head2 set_default_logger( Sink1 => {params}, Sink2 => {params} )
118
119
  Calls C<create_logger()> and sets it as the default.
120
  Should probably be used only in the main script.
121
122
=cut
123
124
sub set_default_logger {
125
    $default_logger = create_logger(@_);
126
    set_logger($default_logger);
127
}
128
129
sub restore_default_logger {
130
    set_logger($default_logger);
131
}
132
133
=head2 add_sink( Sink, {params}, $force )
134
=head2 remove_sink( sink_name )
135
=head2 with_debug { code...} Sink1 [ => {params}], Sink2 ...
136
137
  C<Koha::Log::Dispatch> method proxies, called on the default logger
138
139
=cut
140
141
sub add_sink {
142
    $default_logger->add_sink(@_);
143
}
144
145
sub remove_sink {
146
    my ($sink_name) = @_;
147
    $default_logger->remove( lc $sink_name );
148
}
149
150
sub with_debug (&@) {
151
    my $code = \&{shift @_};
152
    $default_logger->with_debug($code, @_);
153
}
154
155
package Koha::Log::Dispatch;
156
157
=head1 LOGGER CLASS
158
159
C<create_logger()> returns a loger class based on C<Log::Dispatch>
160
161
=cut
162
163
use Modern::Perl;
164
use Carp;
165
use Class::Load 'load_class';
166
167
use C4::Context;
168
169
use base 'Log::Dispatch';
170
171
my %ALL_LOGGER_PARAMS = (
172
    newline   => 1,
173
    min_level => $ENV{KOHA_DEBUG} ? 'debug' : 'info',
174
);
175
176
my %LOGGER_PARAMS = (
177
    Stdout => {stderr => 0},
178
    Stderr => {stderr => 1},
179
    Syslog => {facility => 'user'},
180
);
181
182
=head1 LOGGER METHODS
183
184
=head2 outputs()
185
186
  Returns hashref {sink_name => sink_object...}
187
188
=cut
189
190
sub outputs {
191
    my $self = shift;
192
    return $self->{outputs};
193
}
194
195
=head2 set_level(log_level, @sink_names)
196
197
  Sets  (minimum) log level for all named sinks (outputs)
198
  If no named sinks are specified, all associated sinks are affected.
199
200
=cut
201
202
sub set_level {
203
    my $self = shift;
204
    my $level = shift or croak "No level specified";
205
206
    my @outputs = @_ ? map ($self->output($_), @_) : values (%{ $self->outputs });
207
    $_->{min_level} = $_->_level_as_number($level) foreach @outputs;
208
}
209
210
=head2 get_levels()
211
212
  Returns hashref {sink_name => log_level...}
213
214
=cut
215
216
sub get_levels {
217
    my $self = shift;
218
219
    my @outputs = @_ ? map ($self->output($_), @_) : values (%{ $self->outputs });
220
    return { map { $_->name => $_->min_level } @outputs };
221
}
222
223
=head2 add_sink( Sink, {params}, $force )
224
225
  Creates a C<Log::Dispatch::Sink> object, and calls C<add()>
226
  If sink with the name altready exists it returns, unless $force is true,
227
  in which case existing sink is replaced with a new one.
228
229
=cut
230
231
sub add_sink {
232
    my $self = shift;
233
    my ($sink, $params, $force) = @_;
234
235
    my $sink_params = $LOGGER_PARAMS{$sink} || {};
236
    my $sink_name = $params->{name} ||= lc $sink;
237
238
    if ( $self->output($sink_name) ) {
239
        return unless $force;
240
        $self->remove( $sink_name );
241
    }
242
243
    $params ||= {};
244
    if (my $filename = $params->{filename}) {
245
        $params->{filename} = C4::Context->config("logdir") . "/$filename"
246
          unless $filename =~ m!^[/.]!o;
247
    }
248
249
    $sink = 'Screen' if $sink eq 'Stdout' || $sink eq 'Stderr';
250
    my $sink_class = "Log::Dispatch::$sink";
251
    load_class $sink_class;
252
    $self->add( $sink_class->new( %ALL_LOGGER_PARAMS, %$sink_params, %$params ) );
253
    return $sink_name;
254
}
255
256
=head2 with_debug( code_ref, Sink1 [ => {params}], Sink2 ... )
257
258
  Executes code within a debug context
259
  If Sink => params are given, those are used for debug logging in addition
260
  to eny existing sinks with debug level. Otherwise all associated sinks
261
  (outputs) are upgraded temporarily to debug level.
262
263
  See B<ADVANCED USAGE> below
264
265
=cut
266
267
sub with_debug {
268
    my $self = shift;
269
    my $code = shift;
270
271
    my $current_levels = $self->get_levels;
272
273
    my @sink;
274
    my @extra_logger;
275
    if (@_) {
276
        while (my $sink = shift @_) {
277
            # next if ref $sink;
278
            my $params = {};
279
            $params = shift @_ if ref $_[0];
280
            my $sink_name = $params->{name} || lc $sink;
281
            unless ($self->output($sink_name)) {
282
                $params->{min_level} = 'debug';
283
                $self->add_sink($sink, $params);
284
                push @extra_logger, $sink_name;
285
            }
286
            push @sink, $sink_name;
287
        }
288
    }
289
    else {
290
        @sink = keys %$current_levels;
291
    }
292
    $self->set_level('debug', @sink);
293
    $code->();
294
    $self->remove($_) foreach @extra_logger;
295
    while (my ($name, $level) = each %$current_levels) {
296
        $self->set_level($level, $name);
297
    }
298
}
299
300
301
=head1 USAGE
302
303
  The simplest example:
304
305
  use Koha::Log;
306
  do things();
307
  log_info { "This will show in STDERR" };
308
  log_debug { "This will not show in STDERR" };
309
310
  A less simple example:
311
312
  use Koha::Log qw(:log set_default_logger)
313
  my %sinks = (
314
    'File'   => {filename => 'my.log'},
315
  );
316
  set_default_logger(%sinks);
317
318
  # In a module down below
319
  use Koha::Log;
320
  do things();
321
  log_info { "This will show in my.log" };
322
  log_debug { "This will not show in my.log" };
323
324
  An example with multiple sinks:
325
326
  use Koha::Log qw(:log set_default_logger)
327
  my %sinks = (
328
    'Stderr' => {min_level => 'debug'},
329
    'Syslog' => {},
330
    'File'   => {filename => 'my.log'},
331
  );
332
  set_default_logger(%sinks);
333
334
  # In a module down below
335
  use Koha::Log;
336
  do things();
337
  log_info { "This will show everywhere" };
338
  log_debug { "This will show in STDERR" };
339
340
  Enable debug messages:
341
    KOHA_DEBUG=1 some_koha_script.pl
342
343
  or in Apache:
344
    SetEnv KOHA_DEBUG=1
345
346
=cut
347
348
=head1 ADVANCED USAGE
349
350
  Enable debug messages just for a piece of code:
351
352
  use Koha::Log qw(:log set_default_logger)
353
  my %sinks = (
354
    'File'   => {filename => 'my.log'},
355
  );
356
  set_default_logger(%sinks);
357
358
  # In a module down below
359
  use Koha::Log qw(:log with_debug)
360
  do things();
361
  log_debug { "This will not show" };
362
  ...
363
  with_debug {
364
      do other_things();
365
      log_debug {"This will show"};
366
  };
367
368
  This will make the block surounded by with_debug {} output debug to my.log
369
  Alternatively:
370
371
  with_debug {
372
      do other_things();
373
      log_debug {"This will show"};
374
  } 'Stderr';
375
376
  will leave my.log at 'info' level, and output debug (and other log levels) to STDERR.
377
378
  Special logging:
379
380
  use Koha::Log qw(:log set_default_logger)
381
  my %sinks = (
382
    'File'   => {filename => 'my.log'},
383
  );
384
  set_default_logger(%sinks);
385
386
  # In a module down below
387
  use Koha::Log qw(:log create_logger with_logger)
388
  do things();
389
  log_warn { "This will show in my.log" };
390
  ...
391
  my $special_logger = create_logger('File' => {filename => 'my_special.log});
392
  with_logger $special_logger => sub {
393
      log_warn { "This will show in my_special.log" };
394
  };
395
396
  This will make the block surounded by with_debug {} output debug to my.log
397
398
=head1 TO DO
399
400
  * Add support for Email and possibly other sinks
401
  * Integrate C4::Log
402
403
=cut
404
405
1;
(-)a/t/Koha_Log.t (-1 / +77 lines)
Line 0 Link Here
0
- 
1
#!/usr/bin/perl
2
3
use strict;
4
use warnings;
5
use autodie;
6
7
use Test::More tests => 6;
8
use Test::Output;
9
10
my $LOG_FILE = '/tmp/koha_log_test.log';
11
my $DEBUG_LOG_FILE = '/tmp/koha_log_debug.log';
12
my $SPECIAL_LOG_FILE = '/tmp/koha_log_special.log';
13
14
BEGIN {
15
    use_ok('Koha::Log', ":log", "with_logger", "with_debug", "create_logger", "set_default_logger");
16
}
17
18
my %sinks = (
19
    'Stderr' => {},
20
    'Stdout' => {min_level => 'debug'},
21
    'Syslog' => {},
22
    'File'   => {filename => $LOG_FILE},
23
);
24
25
remove_log_files();
26
27
set_default_logger(%sinks);
28
29
my $expect = join '', map "$_\n", "Error", "Warn", "Info", "Koha::Log::Test::test()";
30
my $expect_debug = join '', map "$_\n", "Debug1", "Debug2", "Debug3";
31
32
stdout_is { stderr_is {
33
    log_error { "Error" };
34
    log_warn { "Warn" };
35
    log_info { "Info" };
36
37
    Koha::Log::Test::test();
38
39
    log_debug {"Debug1"};
40
    with_debug {
41
        log_debug {"Debug2"};
42
    } 'Stderr', 'File', {filename => $DEBUG_LOG_FILE, name => 'debug'};
43
    log_debug {"Debug3"};
44
45
    my $special_logger = create_logger('File' => {filename => $SPECIAL_LOG_FILE});
46
    with_logger $special_logger => sub {
47
        log_info { "Special" };
48
    };
49
50
    log_info { "Last" };
51
} $expect."Debug2\n"."Last\n", "logged to stderr" } $expect.$expect_debug."Last\n", "logged to stdout";
52
53
check_log($LOG_FILE, $expect."Last\n");
54
check_log($DEBUG_LOG_FILE, "Debug2\n");
55
check_log($SPECIAL_LOG_FILE, "Special\n");
56
57
remove_log_files();
58
59
sub check_log {
60
    my ($file, $content) = @_;
61
62
    open (my $log, "<", $file);
63
    my $logged = join '', <$log>;
64
    is ($logged, $content, "logged to file $file");
65
}
66
67
sub remove_log_files {
68
    -f $_ && unlink $_ foreach $LOG_FILE, $DEBUG_LOG_FILE, $SPECIAL_LOG_FILE;
69
}
70
71
package Koha::Log::Test;
72
73
use Koha::Log;
74
75
sub test {
76
    log_info { "Koha::Log::Test::test()" };
77
}

Return to bug 13413