From 57f2a927b30d209b35c4fc56c5c359553818f995 Mon Sep 17 00:00:00 2001 From: Jonathan Druart Date: Tue, 5 Jun 2012 15:51:06 +0200 Subject: [PATCH 1/1] Bug 8190: C4::Logger, Logging module use C4::Logger qw/$log/; $log = C4::Logger->new; $log->debug("This is a debug message"); $log->info("This is an information"); $log->error("This is an error !"); The Logger constructor can take an hash reference with "file" and "level" to define a filepath or a log level. For a log level >= warning, a call stack is printed. Prerequisite: - set an environment variable LOG in your virtual host: SetEnv LOG /home/koha/var/log/opac.log - set a write flag for www-data on this file Please have a look at t/Logger.t for more details. --- C4/Installer/PerlDependencies.pm | 5 + C4/Logger.pm | 176 ++++++++++++++++++++ install_misc/debian.packages | 1 + installer/data/mysql/updatedatabase.pl | 9 + .../prog/en/modules/admin/preferences/admin.pref | 13 ++ opac/opac-search.pl | 4 + t/Logger.t | 95 +++++++++++ 7 files changed, 303 insertions(+), 0 deletions(-) create mode 100644 C4/Logger.pm create mode 100644 t/Logger.t diff --git a/C4/Installer/PerlDependencies.pm b/C4/Installer/PerlDependencies.pm index 8dcfd76..e661351 100644 --- a/C4/Installer/PerlDependencies.pm +++ b/C4/Installer/PerlDependencies.pm @@ -519,6 +519,11 @@ our $PERL_DEPS = { 'required' => '1', 'min_ver' => '0.09', }, + 'Log::LogLite' => { + usage => 'Core', + required => '1', + min_ver => '0.82', + }, }; 1; diff --git a/C4/Logger.pm b/C4/Logger.pm new file mode 100644 index 0000000..7813802 --- /dev/null +++ b/C4/Logger.pm @@ -0,0 +1,176 @@ +package C4::Logger; + +# Copyright 2012 Biblibre SARL +# +# 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 2 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, write to the Free Software Foundation, Inc., +# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +use Modern::Perl; +use Log::LogLite; + +use base 'Exporter'; +our @EXPORT_OK = qw($log); + +my $UNUSABLE_LOG_LEVEL = 1; +my $CRITICAL_LOG_LEVEL = 2; +my $ERROR_LOG_LEVEL = 3; +my $WARNING_LOG_LEVEL = 4; +my $NORMAL_LOG_LEVEL = 5; +my $INFO_LOG_LEVEL = 6; +my $DEBUG_LOG_LEVEL = 7; + +my $LEVEL_STR = { + $UNUSABLE_LOG_LEVEL => 'UNUS ', + $CRITICAL_LOG_LEVEL => 'CRIT ', + $ERROR_LOG_LEVEL => 'ERROR ', + $WARNING_LOG_LEVEL => 'WARN ', + $NORMAL_LOG_LEVEL => 'NORMAL', + $INFO_LOG_LEVEL => 'INFO ', + $DEBUG_LOG_LEVEL => 'DEBUG ', +}; + +use Data::Dumper; + +our $log = undef; + +sub new { + my ( $proto, $params ) = @_; + + return $log if $log and ( not defined $params->{file} or not defined $log->{FILE_PATH} or $params->{file} eq $log->{FILE_PATH} ); + my $class = ref($proto) || $proto; + my $self = {}; + my $LOG_PATH = defined $ENV{LOG} ? $ENV{LOG} : undef; + $self->{FILE_PATH} = defined $params->{file} ? $params->{file} : $LOG_PATH; + $self->{LEVEL} = defined $params->{level} ? $params->{level} : $INFO_LOG_LEVEL; + if ( not defined $self->{FILE_PATH} ) { + return bless($self, $class); + } + eval { + $self->{LOGGER} = Log::LogLite->new($self->{FILE_PATH}, $self->{LEVEL}); + }; + die "Log system is not correctly configured ($@)" if $@; + return bless( $self, $class ); +} + +sub write { + my ($self, $msg, $log_level, $dump, $cb) = @_; + + if ( not $self->{LOGGER} ) { + if($log_level <= $self->{LEVEL}) { + print STDERR "[" . localtime() . "] " + . "$LEVEL_STR->{$log_level}: " + . $msg + . ( $cb ? " (" . $cb . ")" : "" ) + . "\n"; + } + return; + } + my $template = "[] $LEVEL_STR->{$log_level}: "; + $template .= " (caller: $cb)" if $cb; + $template .= "\n"; + $self->{LOGGER}->template($template); + $msg = "\n" . Dumper $msg if $dump; + $self->{LOGGER}->write($msg, $log_level); +} + +sub unusable { + my ($self, $msg, $dump) = @_; + my $cb = $self->called_by(); + $self->write($msg, $UNUSABLE_LOG_LEVEL, $dump, $cb); +} + +sub critical { + my ($self, $msg, $dump) = @_; + my $cb = $self->called_by(); + $self->write($msg, $CRITICAL_LOG_LEVEL, $dump, $cb); +} + +sub error { + my ($self, $msg, $dump) = @_; + my $cb = $self->called_by(); + $self->write($msg, $ERROR_LOG_LEVEL, $dump, $cb); +} + +sub warning { + my ($self, $msg, $dump) = @_; + my $cb = $self->called_by(); + $self->write($msg, $WARNING_LOG_LEVEL, $dump, $cb); +} + +sub log { + my ($self, $msg, $dump) = @_; + $self->write($msg, $NORMAL_LOG_LEVEL, $dump); +} + +sub normal { + my ($self, $msg, $dump) = @_; + $self->write($msg, $NORMAL_LOG_LEVEL, $dump); +} + +sub info { + my ($self, $msg, $dump) = @_; + $self->write($msg, $INFO_LOG_LEVEL, $dump); +} + +sub debug { + my ($self, $msg, $dump) = @_; + $self->write($msg, $DEBUG_LOG_LEVEL, $dump); +} + +sub level { + my $self = shift; + + return $self->{LOGGER} + ? $self->{LOGGER}->level(@_) + : ($self->{LEVEL} = @_ ? shift : $self->{LEVEL}); +} + + +sub called_by { + my $self = shift; + my $depth = 2; + my $args; + my $pack; + my $file; + my $line; + my $subr; + my $has_args; + my $wantarray; + my $evaltext; + my $is_require; + my $hints; + my $bitmask; + my @subr; + my $str = ""; + while (1) { + ($pack, $file, $line, $subr, $has_args, $wantarray, $evaltext, + $is_require, $hints, $bitmask) = caller($depth); + unless (defined($subr)) { + last; + } + $depth++; + $line = (3) ? "$file:".$line."-->" : ""; + push(@subr, $line.$subr); + } + @subr = reverse(@subr); + foreach $subr (@subr) { + $str .= $subr; + $str .= " > "; + } + $str =~ s/ > $/: /; + return $str; +} # of called_by + +1; diff --git a/install_misc/debian.packages b/install_misc/debian.packages index 4406e3d..73969cc 100644 --- a/install_misc/debian.packages +++ b/install_misc/debian.packages @@ -56,6 +56,7 @@ liblist-moreutils-perl install liblocale-currency-format-perl install liblocale-gettext-perl install liblocale-po-perl install +liblog-loglite-perl install libmail-sendmail-perl install libmarc-charset-perl install libmarc-crosswalk-dublincore-perl install diff --git a/installer/data/mysql/updatedatabase.pl b/installer/data/mysql/updatedatabase.pl index 51a6486..f69ea34 100755 --- a/installer/data/mysql/updatedatabase.pl +++ b/installer/data/mysql/updatedatabase.pl @@ -5307,6 +5307,15 @@ if (C4::Context->preference("Version") < TransformToNum($DBversion)) { SetVersion ($DBversion); } +$DBversion = "3.09.00.XXX"; +if ( C4::Context->preference("Version") < TransformToNum($DBversion) ) { + $dbh->do(qq{ + INSERT IGNORE INTO systempreferences (variable,value,explanation,options,type) VALUES ('LogLevel','5','Set the level of logs. 1=Unusable, 2=Critical, 3=Error, 4=Warning, 5=Normal, 6=Info, 7=Debug','1|2|3|4|5|6|7','Choice'); + }); + print "Upgrade to $DBversion done (Add system preference LogLevel)\n"; + SetVersion($DBversion); +} + =head1 FUNCTIONS =head2 TableExists($table) diff --git a/koha-tmpl/intranet-tmpl/prog/en/modules/admin/preferences/admin.pref b/koha-tmpl/intranet-tmpl/prog/en/modules/admin/preferences/admin.pref index 08eb954..52fb278 100644 --- a/koha-tmpl/intranet-tmpl/prog/en/modules/admin/preferences/admin.pref +++ b/koha-tmpl/intranet-tmpl/prog/en/modules/admin/preferences/admin.pref @@ -104,3 +104,16 @@ Administration: Common Name: the Common Name emailAddress: the emailAddress - field for SSL client certificate authentication + Logger: + - + - Set the level + - pref: LogLevel + choices: + 1: 1- Unusable + 2: 2- Critical + 3: 3- Error + 4: 4- Warning + 5: 5- Normal + 6: 6- Info + 7: 7- Debug + - for logs diff --git a/opac/opac-search.pl b/opac/opac-search.pl index 5f3ad86..9cdab25 100755 --- a/opac/opac-search.pl +++ b/opac/opac-search.pl @@ -39,12 +39,15 @@ use C4::Tags qw(get_tags); use C4::Branch; # GetBranches use C4::SocialData; use C4::Ratings; +use C4::Logger qw/$log/; use POSIX qw(ceil floor strftime); use URI::Escape; use Storable qw(thaw freeze); use Business::ISBN; +$log = C4::Logger->new({level => C4::Context->preference("LogLevel")}); + my $DisplayMultiPlaceHold = C4::Context->preference("DisplayMultiPlaceHold"); # create a new CGI object # FIXME: no_undef_params needs to be tested @@ -474,6 +477,7 @@ elsif (C4::Context->preference('NoZebra')) { $pasarParams .= '&count=' . $results_per_page; $pasarParams .= '&simple_query=' . $simple_query; $pasarParams .= '&query_type=' . $query_type if ($query_type); + $log->info("OPAC: Search for $query"); eval { ($error, $results_hashref, $facets) = getRecords($query,$simple_query,\@sort_by,\@servers,$results_per_page,$offset,$expanded_facet,$branches,$query_type,$scan); }; diff --git a/t/Logger.t b/t/Logger.t new file mode 100644 index 0000000..417b8d2 --- /dev/null +++ b/t/Logger.t @@ -0,0 +1,95 @@ +#!/usr/bin/perl + +use utf8; +use Modern::Perl; +if ( not $ENV{LOG} ) { + usage(); + exit; +} + +use Test::More; +require C4::Context; +import C4::Context; +plan tests => 15; + +my $logfile = $ENV{LOG}; + +use_ok('C4::Logger'); +isnt(C4::Context->preference("LogLevel"), undef, "Check LogLevel syspref"); +use C4::Logger qw/$log/; +is($log, undef, "Check \$log is undef"); +$log = C4::Logger->new({level => 3}); +isnt($log, undef, "Check \$log is not undef"); + + +my @lines = (); +$log->error( "an error string"); +$log->normal( "a normal string"); +@lines = get_contains( $logfile ); +is(grep (/an error string/, @lines), 1, "check error string with level 3"); +is(grep (/a normal string/, @lines), 0, "check normal string with level 3"); +truncate_file($logfile); +$log->level(5); +$log->error( "an error string"); +$log->normal( "a normal string"); +test_calledby( "test calledby" ); +my $struct = { + a => "aaaaa", + b => "bbbbb", + c => "ccccc" +}; +$log->warning($struct, 1); +@lines = get_contains( $logfile ); +is(grep (/an error string/, @lines), 1, "check error string with level 5"); +is(grep (/a normal string/, @lines), 1, "check normal string with level 5"); +is(grep (/test_calledby/, @lines), 1, "check calledby string with level 5"); +is(grep (/WARN/, @lines), 1, "check WARN string with dump"); +is(grep (/VAR1/, @lines), 1, "check VAR1 string with dump"); +is(grep (/aaaaa/, @lines), 1, "check values aaaaa string with dump"); +is(5, $log->level, "check log level return"); + + +$ENV{LOG} = undef; +my $log_stderr_file = qq{/tmp/stderr.log}; +$log = undef; +$log = C4::Logger->new({level => 3}); +open(STDERR, ">>$log_stderr_file"); +$log->error( "an error string"); +$log->normal( "a normal string"); +@lines = get_contains( $log_stderr_file ); +is(grep (/an error string/, @lines), 1, "check error string with level 3"); +is(grep (/a normal string/, @lines), 0, "check normal string with level 3"); + +system( qq{rm $logfile} ); +system( qq{rm $log_stderr_file} ); + +sub get_contains { + my $filepath = shift; + my @lines; + open FILE, "<", $filepath or die "Can't open $filepath: $!"; + while() { + chomp; + push(@lines, $_); + } + close(FILE); + return @lines; +} + +sub truncate_file { + my $filepath = shift; + open FILE, ">", $filepath or die "Can't open $filepath: $!"; + truncate FILE, 0; + close FILE; +} + +sub test_calledby { + my $msg = shift; + $log->error($msg); +} + +sub usage { + warn "\n\n+==================================================+\n"; + warn qq{| You must call this test with a LOG env var like: |\n}; + warn qq{| LOG="/tmp/t1.log" prove t/Logguer.t |\n}; + warn "+==================================================+\n\n"; +} -- 1.7.7.3