use warnings;
use strict;
-use Log::Log4perl qw(get_logger :levels);
+use Log::Log4perl qw/get_logger :levels/;
+use Time::HiRes qw/time/;
+
+# If ture, enable logging debug
+my $log_debug = 0;
=head1 NAME
=head1 VERSION
-Version 0.01
+Version 0.02
=cut
-our $VERSION = '0.01';
+our $VERSION = '0.02';
-=head1 INTERNAL METHODS
+=head1 SYNOPSYS
-Here is a quick list of internal methods, mostly useful to turn debugging
-on them (see L<LOGGING> below for explanation).
+This module defines common functions, and is used as base for other, more
+specific modules.
-=cut
+=head1 FUNCTIONS
-=head2 _eval
+=head2 progress_bar
-Internal function to eval code without C<strict 'subs'>.
+Draw progress bar on STDERR.
+
+ $webpac->progress_bar($current, $max);
=cut
-sub _eval {
+sub progress_bar {
my $self = shift;
- my $code = shift || return;
+ my ($curr,$max) = @_;
my $log = $self->_get_logger();
- no strict 'subs';
- my $ret = eval $code;
- if ($@) {
- $log->error("problem with eval code [$code]: $@");
+ $log->logconfess("no current value!") if (! $curr);
+ $log->logconfess("no maximum value!") if (! $max);
+
+ if ($curr > $max) {
+ $max = $curr;
+ $log->debug("overflow to $curr");
}
- $log->debug("eval: ",$code," [",$ret,"]");
+ $self->{'last_pcnt'} ||= 1;
+ $self->{'start_t'} ||= time();
- return $ret || undef;
+ my $p = int($curr * 100 / $max) || 1;
+
+ # reset on re-run
+ if ($p < $self->{'last_pcnt'}) {
+ $self->{'last_pcnt'} = $p;
+ $self->{'start_t'} = time();
+ }
+
+ if ($p != $self->{'last_pcnt'}) {
+
+ my $t = time();
+ my $rate = ($curr / ($t - $self->{'start_t'} || 1));
+ my $eta = ($max-$curr) / ($rate || 1);
+ printf STDERR ("%5d [%-38s] %-5d %0.1f/s %s\r",$curr,"=" x ($p/3)."$p%>", $max, $rate, $self->fmt_time($eta));
+ $self->{'last_pcnt'} = $p;
+ $self->{'last_curr'} = $curr;
+ }
+ print STDERR "\n" if ($p == 100);
}
-=head2 _sort_by_order
+=head2 fmt_time
-Sort xml tags data structure accoding to C<order=""> attribute.
+Format time (in seconds) for display.
+
+ print $webpac->fmt_time(time());
+
+This method is called by L<progress_bar> to display remaining time.
=cut
-sub _sort_by_order {
+sub fmt_time {
my $self = shift;
- my $va = $self->{'import_xml'}->{'indexer'}->{$a}->{'order'} ||
- $self->{'import_xml'}->{'indexer'}->{$a};
- my $vb = $self->{'import_xml'}->{'indexer'}->{$b}->{'order'} ||
- $self->{'import_xml'}->{'indexer'}->{$b};
+ my $t = shift || 0;
+ my $out = "";
- return $va <=> $vb;
+ my ($ss,$mm,$hh) = gmtime($t);
+ $out .= "${hh}h" if ($hh);
+ $out .= sprintf("%02d:%02d", $mm,$ss);
+ $out .= " " if ($hh == 0);
+ return $out;
}
-=head2 _x
+#
+#
+#
-Convert string from UTF-8 to code page defined in C<import_xml>.
+=head1 INTERNAL METHODS
- my $text = $webpac->_x('utf8 text');
+Here is a quick list of internal methods, mostly useful to turn debugging
+on them (see L<LOGGING> below for explanation).
-Default application code page is C<ISO-8859-2>. You will probably want to
-change that when creating new instance of object based on this one.
+=cut
+
+=head2 _eval
+
+Internal function to eval code without C<strict 'subs'>.
=cut
-sub _x {
+sub _eval {
my $self = shift;
- my $utf8 = shift || return;
- # create UTF-8 convertor for import_xml files
- $self->{'utf2cp'} ||= Text::Iconv->new('UTF-8' ,$self->{'code_page'} || 'ISO-8859-2');
+ my $code = shift || return;
+
+ my $log = $self->_get_logger();
+
+ no strict 'subs';
+ my $ret = eval $code;
+ if ($@) {
+ $log->error("problem with eval code [$code]: $@");
+ }
+
+ $log->debug("eval: ",$code," [",$ret,"]");
- return $self->{'utf2cp'}->convert($utf8) ||
- $self->_get_logger()->logwarn("can't convert '$utf8'");
+ return $ret || undef;
}
=head2 _init_logger
$webpac->_init_logger('/path/to/log.conf');
+If no path to configuration file is given, dummy empty configuration
+will be created. If any mode which inherits from this one is called
+with C<debug> flag, it will turn logging to debug level.
+
+This function will also read C<log_conf> value from current object and try
+to read that as configuration file if it exists, if it doesn't it will
+fallback to default C<conf/log.conf>.
+
+You can disable all logging by adding C<no_log> to constructor of WebPAC
+object. Object in C<Test::Exception> class will disable logging
+automatically.
+
=cut
sub _init_logger {
my $self = shift;
my $file = shift;
- if ($file) {
+ $file ||= $self->{'log_conf'};
+ $file = 'conf/log.conf';
+ my $name = (caller(2))[3] || caller;
+
+ my $conf = q( );
+ if ($self->{'no_log'}) {
+ warn "# $name disabled logging\n" if ($log_debug);
+ } elsif ($self->{'debug'}) {
+ $conf = << '_log4perl_';
+
+log4perl.rootLogger=INFO, SCREEN
+
+log4perl.logger.WebPAC.=DEBUG
+
+log4perl.appender.SCREEN=Log::Log4perl::Appender::Screen
+log4perl.appender.SCREEN.layout=PatternLayout
+log4perl.appender.SCREEN.layout.ConversionPattern=%d %p> %F{1}:%L %M - %m%n
+
+_log4perl_
+ warn "# $name is using debug logger\n" if ($log_debug);
+ } elsif ($name =~ m/Test::Exception/o) {
+ warn "# disabled logging for Text::Exception\n" if ($log_debug);
+ } elsif (-e $file) {
+ warn "# $name is using $file logger\n" if ($log_debug);
Log::Log4perl->init($file);
+ return 1;
} else {
- my $conf = q( );
- Log::Log4perl->init( \$conf );
+ warn "# $name is using null logger\n" if ($log_debug);
}
+ Log::Log4perl->init( \$conf );
+
+ return 1;
}
sub _get_logger {
my $self = shift;
- $self->{'_logger_ok'} ||= $self->_init_logger;
+ my $name = (caller(2))[3] || caller;
+ $self->{'_logger_'} ||= $self->_init_logger;
- my $name = (caller(1))[3] || caller;
- return get_logger($name);
+ my $log = get_logger( $name );
+ warn "# get_logger( $name ) level ", $log->level, "\n" if ($log_debug);
+ return $log;
}
+=head2 _log
+
+Quick cludge to make logging object available to scripts which
+use webpac line this:
+
+ my $log = _new WebPAC::Common()->_get_logger();
+
+=cut
+
+sub _new {
+ my $class = shift;
+ my $self = {@_};
+ bless($self, $class);
+
+ $self ? return $self : return undef;
+}
+
=head1 LOGGING
Logging in WebPAC is performed by L<Log::Log4perl> with config file
projects / webpac2 / blobdiff