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';
-
-#my $LOOKUP_REGEX = '\[[^\[\]]+\]';
-#my $LOOKUP_REGEX_SAVE = '\[([^\[\]]+)\]';
-my $LOOKUP_REGEX = 'lookup{[^\{\}]+}';
-my $LOOKUP_REGEX_SAVE = 'lookup{([^\{\}]+)}';
+our $VERSION = '0.02';
=head1 SYNOPSYS
This module defines common functions, and is used as base for other, more
specific modules.
- my $webpac = new WebPAC::Common(
- filter => {
- 'filter_name_1' => sub {
- # filter code
- return length($_);
- }, ...
- },
- }
-
=head1 FUNCTIONS
-=head2 fill_in
-
-Workhourse of all: takes record from in-memory structure of database and
-strings with placeholders and returns string or array of with substituted
-values from record.
-
- my $text = $webpac->fill_in($rec,'v250^a');
-
-Optional argument is ordinal number for repeatable fields. By default,
-it's assume to be first repeatable field (fields are perl array, so first
-element is 0).
-Following example will read second value from repeatable field.
-
- my $text = $webpac->fill_in($rec,'Title: v250^a',1);
+=head2 progress_bar
-This function B<does not> perform parsing of format to inteligenty skip
-delimiters before fields which aren't used.
+Draw progress bar on STDERR.
-This method will automatically decode UTF-8 string to local code page
-if needed.
+ $webpac->progress_bar($current, $max);
=cut
-sub fill_in {
+sub progress_bar {
my $self = shift;
+ my ($curr,$max) = @_;
+
my $log = $self->_get_logger();
- my $rec = shift || $log->logconfess("need data record");
- my $format = shift || $log->logconfess("need format to parse");
- # iteration (for repeatable fields)
- my $i = shift || 0;
+ $log->logconfess("no current value!") if (! $curr);
+ $log->logconfess("no maximum value!") if (! $max);
- $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));
+ if ($curr > $max) {
+ $max = $curr;
+ $log->debug("overflow to $curr");
+ }
- # FIXME remove for speedup?
- $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
+ $self->{'last_pcnt'} ||= 1;
+ $self->{'start_t'} ||= time();
- if (utf8::is_utf8($format)) {
- $format = $self->_x($format);
- }
+ my $p = int($curr * 100 / $max) || 1;
- my $found = 0;
-
- my $eval_code;
- # remove eval{...} from beginning
- $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
-
- my $filter_name;
- # remove filter{...} from beginning
- $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
-
- # do actual replacement of placeholders
- # repeatable fields
- $format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;
- # non-repeatable fields
- $format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found)/ges;
-
- if ($found) {
- $log->debug("format: $format");
- if ($eval_code) {
- my $eval = $self->fill_in($rec,$eval_code,$i);
- return if (! $self->_eval($eval));
- }
- if ($filter_name && $self->{'filter'}->{$filter_name}) {
- $log->debug("filter '$filter_name' for $format");
- $format = $self->{'filter'}->{$filter_name}->($format);
- return unless(defined($format));
- $log->debug("filter result: $format");
- }
- # do we have lookups?
- if ($format =~ /$LOOKUP_REGEX/o) {
- $log->debug("format '$format' has lookup");
- return $self->lookup($format);
- } else {
- return $format;
- }
- } else {
- return;
+ # reset on re-run
+ if ($p < $self->{'last_pcnt'}) {
+ $self->{'last_pcnt'} = $p;
+ $self->{'start_t'} = time();
}
-}
-
-=head2 get_data
+ if ($p != $self->{'last_pcnt'}) {
-Returns value from record.
+ 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);
+}
- my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);
+=head2 fmt_time
-Arguments are:
-record reference C<$rec>,
-field C<$f>,
-optional subfiled C<$sf>,
-index for repeatable values C<$i>.
+Format time (in seconds) for display.
-Optinal variable C<$found> will be incremeted if there
-is field.
+ print $webpac->fmt_time(time());
-Returns value or empty string.
+This method is called by L<progress_bar> to display remaining time.
=cut
-sub get_data {
+sub fmt_time {
my $self = shift;
- my ($rec,$f,$sf,$i,$found) = @_;
-
- if ($$rec->{$f}) {
- return '' if (! $$rec->{$f}->[$i]);
- no strict 'refs';
- if ($sf && $$rec->{$f}->[$i]->{$sf}) {
- $$found++ if (defined($$found));
- return $$rec->{$f}->[$i]->{$sf};
- } elsif ($$rec->{$f}->[$i]) {
- $$found++ if (defined($$found));
- # it still might have subfield, just
- # not specified, so we'll dump all
- if ($$rec->{$f}->[$i] =~ /HASH/o) {
- my $out;
- foreach my $k (keys %{$$rec->{$f}->[$i]}) {
- $out .= $$rec->{$f}->[$i]->{$k}." ";
- }
- return $out;
- } else {
- return $$rec->{$f}->[$i];
- }
- }
- } else {
- return '';
- }
+ my $t = shift || 0;
+ my $out = "";
+
+ my ($ss,$mm,$hh) = gmtime($t);
+ $out .= "${hh}h" if ($hh);
+ $out .= sprintf("%02d:%02d", $mm,$ss);
+ $out .= " " if ($hh == 0);
+ return $out;
}
+#
+#
+#
=head1 INTERNAL METHODS
return $ret || undef;
}
-=head2 _sort_by_order
-
-Sort xml tags data structure accoding to C<order=""> attribute.
-
-=cut
-
-sub _sort_by_order {
- 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};
-
- return $va <=> $vb;
-}
-
-=head2 _x
-
-Convert string from UTF-8 to code page defined in C<import_xml>.
-
- my $text = $webpac->_x('utf8 text');
-
-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
-
-sub _x {
- 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');
-
- return $self->{'utf2cp'}->convert($utf8) ||
- $self->_get_logger()->logwarn("can't convert '$utf8'");
-}
-
=head2 _init_logger
This function will init C<Log::Log4perl> using provided configuration file.
$webpac->_init_logger('/path/to/log.conf');
If no path to configuration file is given, dummy empty configuration
-will be create.
+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