[Koha-patches] [PATCH] bug_13413: Koha::Log - logging for Koha
Srdjan
srdjan at catalyst.net.nz
Mon Mar 2 02:45:51 CET 2015
---
Koha/Log.pm | 405 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
debian/control | 2 +
t/Koha_Log.t | 77 +++++++++++
3 files changed, 484 insertions(+)
create mode 100644 Koha/Log.pm
create mode 100755 t/Koha_Log.t
diff --git a/Koha/Log.pm b/Koha/Log.pm
new file mode 100644
index 0000000..78b8183
--- /dev/null
+++ b/Koha/Log.pm
@@ -0,0 +1,405 @@
+package Koha::Log;
+
+# Copyright 2014 Catalyst IT
+#
+# 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>.
+
+use Modern::Perl;
+use Log::Contextual qw(set_logger with_logger);
+use Exporter::Declare;
+use base 'Log::Contextual';
+
+exports qw(with_debug with_logger create_logger set_default_logger);
+
+=head1 NAME
+
+Koha::Log - Logging for Koha
+
+=head1 SYNOPSIS
+
+ # Main script
+ use Koha::Log;
+ # optionally
+ Koha::Log::set_default_logger('File', {filename => $LOG_FILE});
+
+ log_error { "Error" };
+ log_warn { "Warn" };
+ log_info { "Info" };
+
+ # Some module
+ use Koha::Log;
+ log_error { "Error" };
+
+=head1 DESCRIPTION
+
+ This is a combination of Log::Contextual and customised Log:Dispatcher
+ Why?
+ 1. Because it uses code blocks to log, so complex debugging can be left in
+ without any performance penalty
+ 2. Some useful things can be done
+
+ Out of the box it logs to STDERR
+
+=head1 LOG LEVELS
+
+ We support log levels of debug info warn error fatal
+ Not sure how useful is fatal;
+ trace level is TODO
+
+ Log functions are log_I<level>
+
+=head1 Log::Contextual FUNCTIONS
+
+By default, log_* functions are exported. For the full list see C<Log::Contextual>
+
+=cut
+
+my $default_logger;
+
+sub arg_default_logger {
+ return $_[1] || ($default_logger ||= create_logger());
+}
+sub arg_levels { [qw(debug trace info warn error fatal)] }
+sub default_import { ':log' }
+
+=head1 FUNCTIONS
+
+=head2 create_logger( Sink1 => {params}, Sink2 => {params} )
+
+ If no sinks are given, Stderr is assumed
+
+=head3 Sinks
+
+Sinks are C<Log::Dispatch::*> module names, eg File, Syslog etc
+We added two more:
+ C<Stdout> which is a shortcut for Screen stderr => 0
+ C<Stderr> which is a shortcut for Screen stderr => 1
+
+ Default sink parameters:
+ C<min_level> - if env KOHA_DEBUG is set to true valu then 'debug' else 'info'
+ C<name> - lower case sink module name
+
+ Filename rules for C<File>) sink:
+ Filenames with absolute paths are honoured
+ otherwise files are placed in koha config logdir
+
+ Default C<facility> parameter for C<Syslog>) sink is I<user>
+
+=cut
+
+sub create_logger {
+ my %sink_defs = @_ ? @_ : (Stderr => {});
+ my $logger = Koha::Log::Dispatch->new;
+ while (my ($sink, $params) = each %sink_defs) {
+ $logger->add_sink($sink, $params);
+ }
+ return $logger;
+}
+
+=head1 DEFAULT LOGGER FUNCTIONS
+
+Following functions operate on the default logger.
+Default logger should be used most of the time.
+
+=head2 set_default_logger( Sink1 => {params}, Sink2 => {params} )
+
+ Calls C<create_logger()> and sets it as the default.
+ Should probably be used only in the main script.
+
+=cut
+
+sub set_default_logger {
+ $default_logger = create_logger(@_);
+ set_logger($default_logger);
+}
+
+sub restore_default_logger {
+ set_logger($default_logger);
+}
+
+=head2 add_sink( Sink, {params}, $force )
+=head2 remove_sink( sink_name )
+=head2 with_debug { code...} Sink1 [ => {params}], Sink2 ...
+
+ C<Koha::Log::Dispatch> method proxies, called on the default logger
+
+=cut
+
+sub add_sink {
+ $default_logger->add_sink(@_);
+}
+
+sub remove_sink {
+ my ($sink_name) = @_;
+ $default_logger->remove( lc $sink_name );
+}
+
+sub with_debug (&@) {
+ my $code = \&{shift @_};
+ $default_logger->with_debug($code, @_);
+}
+
+package Koha::Log::Dispatch;
+
+=head1 LOGGER CLASS
+
+C<create_logger()> returns a loger class based on C<Log::Dispatch>
+
+=cut
+
+use Modern::Perl;
+use Carp;
+use Class::Load 'load_class';
+
+use C4::Context;
+
+use base 'Log::Dispatch';
+
+my %ALL_LOGGER_PARAMS = (
+ newline => 1,
+ min_level => $ENV{KOHA_DEBUG} ? 'debug' : 'info',
+);
+
+my %LOGGER_PARAMS = (
+ Stdout => {stderr => 0},
+ Stderr => {stderr => 1},
+ Syslog => {facility => 'user'},
+);
+
+=head1 LOGGER METHODS
+
+=head2 outputs()
+
+ Returns hashref {sink_name => sink_object...}
+
+=cut
+
+sub outputs {
+ my $self = shift;
+ return $self->{outputs};
+}
+
+=head2 set_level(log_level, @sink_names)
+
+ Sets (minimum) log level for all named sinks (outputs)
+ If no named sinks are specified, all associated sinks are affected.
+
+=cut
+
+sub set_level {
+ my $self = shift;
+ my $level = shift or croak "No level specified";
+
+ my @outputs = @_ ? map ($self->output($_), @_) : values (%{ $self->outputs });
+ $_->{min_level} = $_->_level_as_number($level) foreach @outputs;
+}
+
+=head2 get_levels()
+
+ Returns hashref {sink_name => log_level...}
+
+=cut
+
+sub get_levels {
+ my $self = shift;
+
+ my @outputs = @_ ? map ($self->output($_), @_) : values (%{ $self->outputs });
+ return { map { $_->name => $_->min_level } @outputs };
+}
+
+=head2 add_sink( Sink, {params}, $force )
+
+ Creates a C<Log::Dispatch::Sink> object, and calls C<add()>
+ If sink with the name altready exists it returns, unless $force is true,
+ in which case existing sink is replaced with a new one.
+
+=cut
+
+sub add_sink {
+ my $self = shift;
+ my ($sink, $params, $force) = @_;
+
+ my $sink_params = $LOGGER_PARAMS{$sink} || {};
+ my $sink_name = $params->{name} ||= lc $sink;
+
+ if ( $self->output($sink_name) ) {
+ return unless $force;
+ $self->remove( $sink_name );
+ }
+
+ $params ||= {};
+ if (my $filename = $params->{filename}) {
+ $params->{filename} = C4::Context->config("logdir") . "/$filename"
+ unless $filename =~ m!^[/.]!o;
+ }
+
+ $sink = 'Screen' if $sink eq 'Stdout' || $sink eq 'Stderr';
+ my $sink_class = "Log::Dispatch::$sink";
+ load_class $sink_class;
+ $self->add( $sink_class->new( %ALL_LOGGER_PARAMS, %$sink_params, %$params ) );
+ return $sink_name;
+}
+
+=head2 with_debug( code_ref, Sink1 [ => {params}], Sink2 ... )
+
+ Executes code within a debug context
+ If Sink => params are given, those are used for debug logging in addition
+ to eny existing sinks with debug level. Otherwise all associated sinks
+ (outputs) are upgraded temporarily to debug level.
+
+ See B<ADVANCED USAGE> below
+
+=cut
+
+sub with_debug {
+ my $self = shift;
+ my $code = shift;
+
+ my $current_levels = $self->get_levels;
+
+ my @sink;
+ my @extra_logger;
+ if (@_) {
+ while (my $sink = shift @_) {
+ # next if ref $sink;
+ my $params = {};
+ $params = shift @_ if ref $_[0];
+ my $sink_name = $params->{name} || lc $sink;
+ unless ($self->output($sink_name)) {
+ $params->{min_level} = 'debug';
+ $self->add_sink($sink, $params);
+ push @extra_logger, $sink_name;
+ }
+ push @sink, $sink_name;
+ }
+ }
+ else {
+ @sink = keys %$current_levels;
+ }
+ $self->set_level('debug', @sink);
+ $code->();
+ $self->remove($_) foreach @extra_logger;
+ while (my ($name, $level) = each %$current_levels) {
+ $self->set_level($level, $name);
+ }
+}
+
+
+=head1 USAGE
+
+ The simplest example:
+
+ use Koha::Log;
+ do things();
+ log_info { "This will show in STDERR" };
+ log_debug { "This will not show in STDERR" };
+
+ A less simple example:
+
+ use Koha::Log qw(:log set_default_logger)
+ my %sinks = (
+ 'File' => {filename => 'my.log'},
+ );
+ set_default_logger(%sinks);
+
+ # In a module down below
+ use Koha::Log;
+ do things();
+ log_info { "This will show in my.log" };
+ log_debug { "This will not show in my.log" };
+
+ An example with multiple sinks:
+
+ use Koha::Log qw(:log set_default_logger)
+ my %sinks = (
+ 'Stderr' => {min_level => 'debug'},
+ 'Syslog' => {},
+ 'File' => {filename => 'my.log'},
+ );
+ set_default_logger(%sinks);
+
+ # In a module down below
+ use Koha::Log;
+ do things();
+ log_info { "This will show everywhere" };
+ log_debug { "This will show in STDERR" };
+
+ Enable debug messages:
+ KOHA_DEBUG=1 some_koha_script.pl
+
+ or in Apache:
+ SetEnv KOHA_DEBUG=1
+
+=cut
+
+=head1 ADVANCED USAGE
+
+ Enable debug messages just for a piece of code:
+
+ use Koha::Log qw(:log set_default_logger)
+ my %sinks = (
+ 'File' => {filename => 'my.log'},
+ );
+ set_default_logger(%sinks);
+
+ # In a module down below
+ use Koha::Log qw(:log with_debug)
+ do things();
+ log_debug { "This will not show" };
+ ...
+ with_debug {
+ do other_things();
+ log_debug {"This will show"};
+ };
+
+ This will make the block surounded by with_debug {} output debug to my.log
+ Alternatively:
+
+ with_debug {
+ do other_things();
+ log_debug {"This will show"};
+ } 'Stderr';
+
+ will leave my.log at 'info' level, and output debug (and other log levels) to STDERR.
+
+ Special logging:
+
+ use Koha::Log qw(:log set_default_logger)
+ my %sinks = (
+ 'File' => {filename => 'my.log'},
+ );
+ set_default_logger(%sinks);
+
+ # In a module down below
+ use Koha::Log qw(:log create_logger with_logger)
+ do things();
+ log_warn { "This will show in my.log" };
+ ...
+ my $special_logger = create_logger('File' => {filename => 'my_special.log});
+ with_logger $special_logger => sub {
+ log_warn { "This will show in my_special.log" };
+ };
+
+ This will make the block surounded by with_debug {} output debug to my.log
+
+=head1 TO DO
+
+ * Add support for Email and possibly other sinks
+ * Integrate C4::Log
+
+=cut
+
+1;
diff --git a/debian/control b/debian/control
index 96a6650..f16bbab 100644
--- a/debian/control
+++ b/debian/control
@@ -65,6 +65,7 @@ Build-Depends: libalgorithm-checkdigits-perl,
liblocale-currency-format-perl,
liblocale-maketext-lexicon-perl,
liblocale-po-perl,
+ liblog-contextual-perl,
liblwp-protocol-https-perl|libwww-perl (<6.02), libio-socket-ssl-perl,
libmail-sendmail-perl,
libmarc-charset-perl,
@@ -263,6 +264,7 @@ Depends: libalgorithm-checkdigits-perl,
liblocale-currency-format-perl,
liblocale-maketext-lexicon-perl,
liblocale-po-perl,
+ liblog-contextual-perl,
liblwp-protocol-https-perl|libwww-perl (<6.02), libio-socket-ssl-perl,
libmail-sendmail-perl,
libmarc-charset-perl,
diff --git a/t/Koha_Log.t b/t/Koha_Log.t
new file mode 100755
index 0000000..2446a78
--- /dev/null
+++ b/t/Koha_Log.t
@@ -0,0 +1,77 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use autodie;
+
+use Test::More tests => 6;
+use Test::Output;
+
+my $LOG_FILE = '/tmp/koha_log_test.log';
+my $DEBUG_LOG_FILE = '/tmp/koha_log_debug.log';
+my $SPECIAL_LOG_FILE = '/tmp/koha_log_special.log';
+
+BEGIN {
+ use_ok('Koha::Log', ":log", "with_logger", "with_debug", "create_logger", "set_default_logger");
+}
+
+my %sinks = (
+ 'Stderr' => {},
+ 'Stdout' => {min_level => 'debug'},
+ 'Syslog' => {},
+ 'File' => {filename => $LOG_FILE},
+);
+
+remove_log_files();
+
+set_default_logger(%sinks);
+
+my $expect = join '', map "$_\n", "Error", "Warn", "Info", "Koha::Log::Test::test()";
+my $expect_debug = join '', map "$_\n", "Debug1", "Debug2", "Debug3";
+
+stdout_is { stderr_is {
+ log_error { "Error" };
+ log_warn { "Warn" };
+ log_info { "Info" };
+
+ Koha::Log::Test::test();
+
+ log_debug {"Debug1"};
+ with_debug {
+ log_debug {"Debug2"};
+ } 'Stderr', 'File', {filename => $DEBUG_LOG_FILE, name => 'debug'};
+ log_debug {"Debug3"};
+
+ my $special_logger = create_logger('File' => {filename => $SPECIAL_LOG_FILE});
+ with_logger $special_logger => sub {
+ log_info { "Special" };
+ };
+
+ log_info { "Last" };
+} $expect."Debug2\n"."Last\n", "logged to stderr" } $expect.$expect_debug."Last\n", "logged to stdout";
+
+check_log($LOG_FILE, $expect."Last\n");
+check_log($DEBUG_LOG_FILE, "Debug2\n");
+check_log($SPECIAL_LOG_FILE, "Special\n");
+
+remove_log_files();
+
+sub check_log {
+ my ($file, $content) = @_;
+
+ open (my $log, "<", $file);
+ my $logged = join '', <$log>;
+ is ($logged, $content, "logged to file $file");
+}
+
+sub remove_log_files {
+ -f $_ && unlink $_ foreach $LOG_FILE, $DEBUG_LOG_FILE, $SPECIAL_LOG_FILE;
+}
+
+package Koha::Log::Test;
+
+use Koha::Log;
+
+sub test {
+ log_info { "Koha::Log::Test::test()" };
+}
--
1.9.1
More information about the Koha-patches
mailing list