lib/WebPAC/Common.pm

package WebPAC::Common;

use warnings;
use strict;

use Log::Log4perl qw(get_logger :levels);

=head1 NAME

WebPAC::Common - internal methods called from other WebPAC modules

=head1 VERSION

Version 0.01

=cut

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<does not> 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<progress_bar> 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
on them (see L<LOGGING> below for explanation).

=cut

=head2 _eval

Internal function to eval code without C<strict 'subs'>.

=cut

sub _eval {
        my $self = shift;

        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 $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 created. If any mode which inherits from this one is called
with C<debug> flag, it will turn logging to debug level.

=cut

sub _init_logger {
        my $self = shift;
        my $file = shift;
        if ($file) {
                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 );
        }
}


=head2 _get_logger

Get C<Log::Log4perl> object with a twist: domains are defined for each
method

 my $log = $webpac->_get_logger();

=cut

sub _get_logger {
        my $self = shift;

        $self->{'_logger_ok'} ||= $self->_init_logger;

        my $name = (caller(1))[3] || caller;
        return get_logger($name);
}


=head1 LOGGING

Logging in WebPAC is performed by L<Log::Log4perl> with config file
C<log.conf>.

Methods defined above have different levels of logging, so
it's descriptions will be useful to turn (mostry B<debug> logging) on
or off to see why WabPAC isn't perforing as you expect it (it might even
be a bug!).

B<This is different from normal Log4perl behaviour>. To repeat, you can
also use method names, and not only classes (which are just few)
to filter logging.


1	dpavlin	3	package WebPAC::Common;
2
3			use warnings;
4			use strict;
5
6			use Log::Log4perl qw(get_logger :levels);
7
8			=head1 NAME
9
10			WebPAC::Common - internal methods called from other WebPAC modules
11
12			=head1 VERSION
13
14			Version 0.01
15
16			=cut
17
18			our $VERSION = '0.01';
19
20	dpavlin	6	=head1 SYNOPSYS
21	dpavlin	4
22	dpavlin	6	This module defines common functions, and is used as base for other, more
23			specific modules.
24
25			my $webpac = new WebPAC::Common(
26			filter => {
27			'filter_name_1' => sub {
28			# filter code
29			return length($_);
30			}, ...
31			},
32			}
33
34	dpavlin	4	=head1 FUNCTIONS
35
36			=head2 fill_in
37
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
40			values from record.
41
42			my $text = $webpac->fill_in($rec,'v250^a');
43
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
46			element is 0).
47			Following example will read second value from repeatable field.
48
49			my $text = $webpac->fill_in($rec,'Title: v250^a',1);
50
51			This function B<does not> perform parsing of format to inteligenty skip
52			delimiters before fields which aren't used.
53
54			This method will automatically decode UTF-8 string to local code page
55			if needed.
56
57			=cut
58
59			sub fill_in {
60			my $self = shift;
61
62			my $log = $self->_get_logger();
63
64			my $rec = shift \|\| $log->logconfess("need data record");
65			my $format = shift \|\| $log->logconfess("need format to parse");
66			# iteration (for repeatable fields)
67			my $i = shift \|\| 0;
68
69			$log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} \|\| 9999));
70
71			# FIXME remove for speedup?
72			$log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
73
74			if (utf8::is_utf8($format)) {
75			$format = $self->_x($format);
76			}
77
78			my $found = 0;
79
80			my $eval_code;
81			# remove eval{...} from beginning
82			$eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
83
84			my $filter_name;
85			# remove filter{...} from beginning
86			$filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
87
88			# do actual replacement of placeholders
89			# repeatable fields
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;
93
94			if ($found) {
95			$log->debug("format: $format");
96			if ($eval_code) {
97			my $eval = $self->fill_in($rec,$eval_code,$i);
98			return if (! $self->_eval($eval));
99			}
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");
105			}
106			# do we have lookups?
107	dpavlin	7	if ($self->{'lookup'}) {
108	dpavlin	4	return $self->lookup($format);
109			} else {
110			return $format;
111			}
112			} else {
113			return;
114			}
115			}
116
117
118			=head2 get_data
119
120			Returns value from record.
121
122			my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);
123
124			Arguments are:
125			record reference C<$rec>,
126			field C<$f>,
127			optional subfiled C<$sf>,
128			index for repeatable values C<$i>.
129
130			Optinal variable C<$found> will be incremeted if there
131			is field.
132
133			Returns value or empty string.
134
135			=cut
136
137			sub get_data {
138			my $self = shift;
139
140			my ($rec,$f,$sf,$i,$found) = @_;
141
142			if ($$rec->{$f}) {
143			return '' if (! $$rec->{$f}->[$i]);
144			no strict 'refs';
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) {
153			my $out;
154			foreach my $k (keys %{$$rec->{$f}->[$i]}) {
155			$out .= $$rec->{$f}->[$i]->{$k}." ";
156			}
157			return $out;
158			} else {
159			return $$rec->{$f}->[$i];
160			}
161			}
162			} else {
163			return '';
164			}
165			}
166
167
168	dpavlin	9	=head2 progress_bar
169
170			Draw progress bar on STDERR.
171
172			$webpac->progress_bar($current, $max);
173
174			=cut
175
176			sub progress_bar {
177			my $self = shift;
178
179			my ($curr,$max) = @_;
180
181			my $log = $self->_get_logger();
182
183			$log->logconfess("no current value!") if (! $curr);
184			$log->logconfess("no maximum value!") if (! $max);
185
186			if ($curr > $max) {
187			$max = $curr;
188			$log->debug("overflow to $curr");
189			}
190
191			$self->{'last_pcnt'} \|\|= 1;
192			$self->{'start_t'} \|\|= time();
193
194			my $p = int($curr * 100 / $max) \|\| 1;
195
196			# reset on re-run
197			if ($p < $self->{'last_pcnt'}) {
198			$self->{'last_pcnt'} = $p;
199			$self->{'start_t'} = time();
200			}
201
202			if ($p != $self->{'last_pcnt'}) {
203
204			my $t = time();
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;
210			}
211			print STDERR "\n" if ($p == 100);
212			}
213
214			=head2 fmt_time
215
216			Format time (in seconds) for display.
217
218			print $webpac->fmt_time(time());
219
220			This method is called by L<progress_bar> to display remaining time.
221
222			=cut
223
224			sub fmt_time {
225			my $self = shift;
226
227			my $t = shift \|\| 0;
228			my $out = "";
229
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);
234			return $out;
235			}
236
237			#
238			#
239			#
240
241	dpavlin	3	=head1 INTERNAL METHODS
242
243			Here is a quick list of internal methods, mostly useful to turn debugging
244			on them (see L<LOGGING> below for explanation).
245
246			=cut
247
248			=head2 _eval
249
250			Internal function to eval code without C<strict 'subs'>.
251
252			=cut
253
254			sub _eval {
255			my $self = shift;
256
257			my $code = shift \|\| return;
258
259			my $log = $self->_get_logger();
260
261			no strict 'subs';
262			my $ret = eval $code;
263			if ($@) {
264			$log->error("problem with eval code [$code]: $@");
265			}
266
267			$log->debug("eval: ",$code," [",$ret,"]");
268
269			return $ret \|\| undef;
270			}
271
272			=head2 _sort_by_order
273
274			Sort xml tags data structure accoding to C<order=""> attribute.
275
276			=cut
277
278			sub _sort_by_order {
279			my $self = shift;
280
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};
285
286			return $va <=> $vb;
287			}
288
289			=head2 _x
290
291			Convert string from UTF-8 to code page defined in C<import_xml>.
292
293			my $text = $webpac->_x('utf8 text');
294
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.
297
298			=cut
299
300			sub _x {
301			my $self = shift;
302			my $utf8 = shift \|\| return;
303
304			# create UTF-8 convertor for import_xml files
305			$self->{'utf2cp'} \|\|= Text::Iconv->new('UTF-8' ,$self->{'code_page'} \|\| 'ISO-8859-2');
306
307			return $self->{'utf2cp'}->convert($utf8) \|\|
308			$self->_get_logger()->logwarn("can't convert '$utf8'");
309			}
310
311			=head2 _init_logger
312
313			This function will init C<Log::Log4perl> using provided configuration file.
314
315			$webpac->_init_logger('/path/to/log.conf');
316
317	dpavlin	6	If no path to configuration file is given, dummy empty configuration
318	dpavlin	10	will be created. If any mode which inherits from this one is called
319			with C<debug> flag, it will turn logging to debug level.
320	dpavlin	6
321	dpavlin	3	=cut
322
323			sub _init_logger {
324			my $self = shift;
325			my $file = shift;
326			if ($file) {
327			Log::Log4perl->init($file);
328			} else {
329			my $conf = q( );
330	dpavlin	10	if ($self->{'debug'}) {
331			$conf = << '_log4perl_';
332
333			log4perl.rootLogger=INFO, SCREEN
334
335			log4perl.logger.WebPAC.=DEBUG
336
337			log4perl.appender.SCREEN=Log::Log4perl::Appender::Screen
338			log4perl.appender.SCREEN.layout=PatternLayout
339			log4perl.appender.SCREEN.layout.ConversionPattern=%d %p> %F{1}:%L %M - %m%n
340
341			_log4perl_
342			}
343	dpavlin	3	Log::Log4perl->init( \$conf );
344			}
345			}
346
347
348			=head2 _get_logger
349
350			Get C<Log::Log4perl> object with a twist: domains are defined for each
351			method
352
353			my $log = $webpac->_get_logger();
354
355			=cut
356
357			sub _get_logger {
358			my $self = shift;
359
360			$self->{'_logger_ok'} \|\|= $self->_init_logger;
361
362			my $name = (caller(1))[3] \|\| caller;
363			return get_logger($name);
364			}
365
366
367			=head1 LOGGING
368
369			Logging in WebPAC is performed by L<Log::Log4perl> with config file
370			C<log.conf>.
371
372			Methods defined above have different levels of logging, so
373			it's descriptions will be useful to turn (mostry B<debug> logging) on
374			or off to see why WabPAC isn't perforing as you expect it (it might even
375			be a bug!).
376
377			B<This is different from normal Log4perl behaviour>. To repeat, you can
378			also use method names, and not only classes (which are just few)
379			to filter logging.
380
381