From 57f2a927b30d209b35c4fc56c5c359553818f995 Mon Sep 17 00:00:00 2001
From: Jonathan Druart <jonathan.druart@biblibre.com>
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 = "[<date>] $LEVEL_STR->{$log_level}: <message>";
+    $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 .= '&amp;count=' . $results_per_page;
     $pasarParams .= '&amp;simple_query=' . $simple_query;
     $pasarParams .= '&amp;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(<FILE>) {
+        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