--- trunk/lib/WebPAC/Common.pm 2005/07/16 11:07:38 3 +++ trunk/lib/WebPAC/Common.pm 2005/07/16 20:35:30 10 @@ -17,6 +17,227 @@ our $VERSION = '0.01'; +=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); + +This function B perform parsing of format to inteligenty skip +delimiters before fields which aren't used. + +This method will automatically decode UTF-8 string to local code page +if needed. + +=cut + +sub fill_in { + my $self = shift; + + 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->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999)); + + # FIXME remove for speedup? + $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o); + + if (utf8::is_utf8($format)) { + $format = $self->_x($format); + } + + 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 ($self->{'lookup'}) { + return $self->lookup($format); + } else { + return $format; + } + } else { + return; + } +} + + +=head2 get_data + +Returns value from record. + + my $text = $self->get_data(\$rec,$f,$sf,$i,\$found); + +Arguments are: +record reference C<$rec>, +field C<$f>, +optional subfiled C<$sf>, +index for repeatable values C<$i>. + +Optinal variable C<$found> will be incremeted if there +is field. + +Returns value or empty string. + +=cut + +sub get_data { + 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 ''; + } +} + + +=head2 progress_bar + +Draw progress bar on STDERR. + + $webpac->progress_bar($current, $max); + +=cut + +sub progress_bar { + my $self = shift; + + my ($curr,$max) = @_; + + my $log = $self->_get_logger(); + + $log->logconfess("no current value!") if (! $curr); + $log->logconfess("no maximum value!") if (! $max); + + if ($curr > $max) { + $max = $curr; + $log->debug("overflow to $curr"); + } + + $self->{'last_pcnt'} ||= 1; + $self->{'start_t'} ||= time(); + + 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 fmt_time + +Format time (in seconds) for display. + + print $webpac->fmt_time(time()); + +This method is called by L to display remaining time. + +=cut + +sub fmt_time { + my $self = shift; + + 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 Here is a quick list of internal methods, mostly useful to turn debugging @@ -93,6 +314,10 @@ $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 flag, it will turn logging to debug level. + =cut sub _init_logger { @@ -102,6 +327,19 @@ Log::Log4perl->init($file); } else { my $conf = q( ); + if ($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_ + } Log::Log4perl->init( \$conf ); } }