1 package WebPAC::Common;
6 use Log::Log4perl qw(get_logger :levels);
10 WebPAC::Common - internal methods called from other WebPAC modules
18 our $VERSION = '0.01';
22 This module defines common functions, and is used as base for other, more
25 my $webpac = new WebPAC::Common(
27 'filter_name_1' => sub {
38 Workhourse of all: takes record from in-memory structure of database and
39 strings with placeholders and returns string or array of with substituted
42 my $text = $webpac->fill_in($rec,'v250^a');
44 Optional argument is ordinal number for repeatable fields. By default,
45 it's assume to be first repeatable field (fields are perl array, so first
47 Following example will read second value from repeatable field.
49 my $text = $webpac->fill_in($rec,'Title: v250^a',1);
51 This function B<does not> perform parsing of format to inteligenty skip
52 delimiters before fields which aren't used.
54 This method will automatically decode UTF-8 string to local code page
62 my $log = $self->_get_logger();
64 my $rec = shift || $log->logconfess("need data record");
65 my $format = shift || $log->logconfess("need format to parse");
66 # iteration (for repeatable fields)
69 $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));
71 # FIXME remove for speedup?
72 $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
74 if (utf8::is_utf8($format)) {
75 $format = $self->_x($format);
81 # remove eval{...} from beginning
82 $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
85 # remove filter{...} from beginning
86 $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
88 # do actual replacement of placeholders
90 $format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;
91 # non-repeatable fields
92 $format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found)/ges;
95 $log->debug("format: $format");
97 my $eval = $self->fill_in($rec,$eval_code,$i);
98 return if (! $self->_eval($eval));
100 if ($filter_name && $self->{'filter'}->{$filter_name}) {
101 $log->debug("filter '$filter_name' for $format");
102 $format = $self->{'filter'}->{$filter_name}->($format);
103 return unless(defined($format));
104 $log->debug("filter result: $format");
106 # do we have lookups?
107 if ($self->{'lookup'}) {
108 return $self->lookup($format);
120 Returns value from record.
122 my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);
125 record reference C<$rec>,
127 optional subfiled C<$sf>,
128 index for repeatable values C<$i>.
130 Optinal variable C<$found> will be incremeted if there
133 Returns value or empty string.
140 my ($rec,$f,$sf,$i,$found) = @_;
143 return '' if (! $$rec->{$f}->[$i]);
145 if ($sf && $$rec->{$f}->[$i]->{$sf}) {
146 $$found++ if (defined($$found));
147 return $$rec->{$f}->[$i]->{$sf};
148 } elsif ($$rec->{$f}->[$i]) {
149 $$found++ if (defined($$found));
150 # it still might have subfield, just
151 # not specified, so we'll dump all
152 if ($$rec->{$f}->[$i] =~ /HASH/o) {
154 foreach my $k (keys %{$$rec->{$f}->[$i]}) {
155 $out .= $$rec->{$f}->[$i]->{$k}." ";
159 return $$rec->{$f}->[$i];
170 Draw progress bar on STDERR.
172 $webpac->progress_bar($current, $max);
179 my ($curr,$max) = @_;
181 my $log = $self->_get_logger();
183 $log->logconfess("no current value!") if (! $curr);
184 $log->logconfess("no maximum value!") if (! $max);
188 $log->debug("overflow to $curr");
191 $self->{'last_pcnt'} ||= 1;
192 $self->{'start_t'} ||= time();
194 my $p = int($curr * 100 / $max) || 1;
197 if ($p < $self->{'last_pcnt'}) {
198 $self->{'last_pcnt'} = $p;
199 $self->{'start_t'} = time();
202 if ($p != $self->{'last_pcnt'}) {
205 my $rate = ($curr / ($t - $self->{'start_t'} || 1));
206 my $eta = ($max-$curr) / ($rate || 1);
207 printf STDERR ("%5d [%-38s] %-5d %0.1f/s %s\r",$curr,"=" x ($p/3)."$p%>", $max, $rate, $self->fmt_time($eta));
208 $self->{'last_pcnt'} = $p;
209 $self->{'last_curr'} = $curr;
211 print STDERR "\n" if ($p == 100);
216 Format time (in seconds) for display.
218 print $webpac->fmt_time(time());
220 This method is called by L<progress_bar> to display remaining time.
230 my ($ss,$mm,$hh) = gmtime($t);
231 $out .= "${hh}h" if ($hh);
232 $out .= sprintf("%02d:%02d", $mm,$ss);
233 $out .= " " if ($hh == 0);
241 =head1 INTERNAL METHODS
243 Here is a quick list of internal methods, mostly useful to turn debugging
244 on them (see L<LOGGING> below for explanation).
250 Internal function to eval code without C<strict 'subs'>.
257 my $code = shift || return;
259 my $log = $self->_get_logger();
262 my $ret = eval $code;
264 $log->error("problem with eval code [$code]: $@");
267 $log->debug("eval: ",$code," [",$ret,"]");
269 return $ret || undef;
272 =head2 _sort_by_order
274 Sort xml tags data structure accoding to C<order=""> attribute.
281 my $va = $self->{'import_xml'}->{'indexer'}->{$a}->{'order'} ||
282 $self->{'import_xml'}->{'indexer'}->{$a};
283 my $vb = $self->{'import_xml'}->{'indexer'}->{$b}->{'order'} ||
284 $self->{'import_xml'}->{'indexer'}->{$b};
291 Convert string from UTF-8 to code page defined in C<import_xml>.
293 my $text = $webpac->_x('utf8 text');
295 Default application code page is C<ISO-8859-2>. You will probably want to
296 change that when creating new instance of object based on this one.
302 my $utf8 = shift || return;
304 # create UTF-8 convertor for import_xml files
305 $self->{'utf2cp'} ||= Text::Iconv->new('UTF-8' ,$self->{'code_page'} || 'ISO-8859-2');
307 return $self->{'utf2cp'}->convert($utf8) ||
308 $self->_get_logger()->logwarn("can't convert '$utf8'");
313 This function will init C<Log::Log4perl> using provided configuration file.
315 $webpac->_init_logger('/path/to/log.conf');
317 If no path to configuration file is given, dummy empty configuration
326 Log::Log4perl->init($file);
329 Log::Log4perl->init( \$conf );
336 Get C<Log::Log4perl> object with a twist: domains are defined for each
339 my $log = $webpac->_get_logger();
346 $self->{'_logger_ok'} ||= $self->_init_logger;
348 my $name = (caller(1))[3] || caller;
349 return get_logger($name);
355 Logging in WebPAC is performed by L<Log::Log4perl> with config file
358 Methods defined above have different levels of logging, so
359 it's descriptions will be useful to turn (mostry B<debug> logging) on
360 or off to see why WabPAC isn't perforing as you expect it (it might even
363 B<This is different from normal Log4perl behaviour>. To repeat, you can
364 also use method names, and not only classes (which are just few)