/[webpac]/trunk2/lib/WebPAC.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /trunk2/lib/WebPAC.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 398 - (show annotations)
Sat Jul 24 13:48:08 2004 UTC (19 years, 8 months ago) by dpavlin
File size: 19828 byte(s)
moved headline information into $webpac->{'headline'} after data_structure is
called. This makes headline desapier from output templates, and namebles new
template veriable 'headline' to contain headline.

1 package WebPAC;
2
3 use warnings;
4 use strict;
5
6 use Carp;
7 use Text::Iconv;
8 use Config::IniFiles;
9 use XML::Simple;
10 use Template;
11 use Log::Log4perl qw(get_logger :levels);
12
13 use Data::Dumper;
14
15 #my $LOOKUP_REGEX = '\[[^\[\]]+\]';
16 #my $LOOKUP_REGEX_SAVE = '\[([^\[\]]+)\]';
17 my $LOOKUP_REGEX = 'lookup{[^\{\}]+}';
18 my $LOOKUP_REGEX_SAVE = 'lookup{([^\{\}]+)}';
19
20 =head1 NAME
21
22 WebPAC - base class for WebPAC
23
24 =head1 DESCRIPTION
25
26 This module implements methods used by WebPAC.
27
28 =head1 METHODS
29
30 =head2 new
31
32 This will create new instance of WebPAC using configuration specified by C<config_file>.
33
34 my $webpac = new WebPAC(
35 config_file => 'name.conf',
36 [code_page => 'ISO-8859-2',]
37 );
38
39 Default C<code_page> is C<ISO-8859-2>.
40
41 It will also read configuration files
42 C<global.conf> (used by indexer and Web font-end)
43 and configuration file specified by C<config_file>
44 which describes databases to be indexed.
45
46 =cut
47
48 # mapping between data type and tag which specify
49 # format in XML file
50 my %type2tag = (
51 'isis' => 'isis',
52 # 'excel' => 'column',
53 # 'marc' => 'marc',
54 # 'feed' => 'feed'
55 );
56
57 sub new {
58 my $class = shift;
59 my $self = {@_};
60 bless($self, $class);
61
62 my $log_file = $self->{'log'} || "log.conf";
63 Log::Log4perl->init($log_file);
64
65 my $log = $self->_get_logger();
66
67 # fill in default values
68 # output codepage
69 $self->{'code_page'} = 'ISO-8859-2' if (! $self->{'code_page'});
70
71 #
72 # read global.conf
73 #
74 $log->debug("read 'global.conf'");
75
76 my $config = new Config::IniFiles( -file => 'global.conf' ) || $log->logcroak("can't open 'global.conf'");
77
78 # read global config parametars
79 foreach my $var (qw(
80 dbi_dbd
81 dbi_dsn
82 dbi_user
83 dbi_passwd
84 show_progress
85 my_unac_filter
86 output_template
87 )) {
88 $self->{'global_config'}->{$var} = $config->val('global', $var);
89 }
90
91 #
92 # read indexer config file
93 #
94
95 $self->{indexer_config_file} = new Config::IniFiles( -file => $self->{config_file} ) || $log->logcroak("can't open '",$self->{config_file},"'");
96
97 # create UTF-8 convertor for import_xml files
98 $self->{'utf2cp'} = Text::Iconv->new('UTF-8' ,$self->{'code_page'});
99
100 # create Template toolkit instance
101 $self->{'tt'} = Template->new(
102 INCLUDE_PATH => ($self->{'global_config_file'}->{'output_template'} || './output_template'),
103 # FILTERS => {
104 # 'foo' => \&foo_filter,
105 # },
106 EVAL_PERL => 1,
107 );
108
109 return $self;
110 }
111
112 =head2 open_isis
113
114 Open CDS/ISIS database using OpenIsis module and read all records to memory.
115
116 $webpac->open_isis(
117 filename => '/data/ISIS/ISIS',
118 code_page => '852',
119 limit_mfn => '500',
120 lookup => [ ... ],
121 );
122
123 By default, ISIS code page is assumed to be C<852>.
124
125 If optional parametar C<limit_mfn> is set, it will read just 500 records
126 from database in example above.
127
128 C<lookup> argument is an array of lookups to create. Each lookup must have C<key> and
129 C<val>. Optional parametar C<eval> is perl code to evaluate before storing
130 value in index.
131
132 lookup => [
133 { 'key' => 'd:v900', 'val' => 'v250^a' },
134 { 'eval' => '"v901^a" eq "Podruèje"',
135 'key' => 'pa:v561^4:v562^4:v461^1',
136 'val' => 'v900' },
137 ]
138
139 Returns number of last record read into memory (size of database, really).
140
141 =cut
142
143 sub open_isis {
144 my $self = shift;
145 my $arg = {@_};
146
147 my $log = $self->_get_logger();
148
149 $log->logcroak("need filename") if (! $arg->{'filename'});
150 my $code_page = $arg->{'code_page'} || '852';
151
152 use OpenIsis;
153
154 #$self->{'isis_code_page'} = $code_page;
155
156 # create Text::Iconv object
157 my $cp = Text::Iconv->new($code_page,$self->{'code_page'});
158
159 $log->info("reading ISIS database '",$arg->{'filename'},"'");
160
161 my $isis_db = OpenIsis::open($arg->{'filename'});
162
163 my $maxmfn = OpenIsis::maxRowid( $isis_db ) || 1;
164
165 $maxmfn = $self->{limit_mfn} if ($self->{limit_mfn});
166
167 $log->info("processing $maxmfn records...");
168
169 # read database
170 for (my $mfn = 1; $mfn <= $maxmfn; $mfn++) {
171
172 # read record
173 my $row = OpenIsis::read( $isis_db, $mfn );
174 foreach my $k (keys %{$row}) {
175 if ($k ne "mfn") {
176 foreach my $l (@{$row->{$k}}) {
177 $l = $cp->convert($l);
178 # has subfields?
179 my $val;
180 if ($l =~ m/\^/) {
181 foreach my $t (split(/\^/,$l)) {
182 next if (! $t);
183 $val->{substr($t,0,1)} = substr($t,1);
184 }
185 } else {
186 $val = $l;
187 }
188
189 push @{$self->{'data'}->{$mfn}->{$k}}, $val;
190 }
191 } else {
192 push @{$self->{'data'}->{$mfn}->{'000'}}, $mfn;
193 }
194
195 }
196
197 # create lookup
198 my $rec = $self->{'data'}->{$mfn};
199 $self->create_lookup($rec, @{$arg->{'lookup'}});
200
201 $self->progress_bar($mfn,$maxmfn);
202
203 }
204
205 $self->{'current_mfn'} = 1;
206 $self->{'last_pcnt'} = 0;
207
208 # store max mfn and return it.
209 return $self->{'max_mfn'} = $maxmfn;
210 }
211
212 =head2 fetch_rec
213
214 Fetch next record from database. It will also display progress bar (once
215 it's implemented, that is).
216
217 my $rec = $webpac->fetch_rec;
218
219 =cut
220
221 sub fetch_rec {
222 my $self = shift;
223
224 my $log = $self->_get_logger();
225
226 my $mfn = $self->{'current_mfn'}++ || $log->logconfess("it seems that you didn't load database!");
227
228 if ($mfn > $self->{'max_mfn'}) {
229 $self->{'current_mfn'} = $self->{'max_mfn'};
230 $log->debug("at EOF");
231 return;
232 }
233
234 $self->progress_bar($mfn,$self->{'max_mfn'});
235
236 return $self->{'data'}->{$mfn};
237 }
238
239 =head2 progress_bar
240
241 Draw progress bar on STDERR.
242
243 $webpac->progress_bar($current, $max);
244
245 =cut
246
247 sub progress_bar {
248 my $self = shift;
249
250 my ($curr,$max) = @_;
251
252 my $log = $self->_get_logger();
253
254 $log->logconfess("no current value!") if (! $curr);
255 $log->logconfess("no maximum value!") if (! $max);
256
257 if ($curr > $max) {
258 $max = $curr;
259 $log->debug("overflow to $curr");
260 }
261
262 $self->{'last_pcnt'} ||= 1;
263
264 $self->{'last_pcnt'} = $curr if ($curr < $self->{'last_pcnt'});
265
266 my $p = int($curr * 100 / $max);
267 if ($p != $self->{'last_pcnt'}) {
268 printf STDERR ("%5d / %5d [%-51s] %-2d %% \r",$curr,$max,"=" x ($p/2).">", $p );
269 $self->{'last_pcnt'} = $p;
270 }
271 }
272
273 =head2 open_import_xml
274
275 Read file from C<import_xml/> directory and parse it.
276
277 $webpac->open_import_xml(type => 'isis');
278
279 =cut
280
281 sub open_import_xml {
282 my $self = shift;
283
284 my $log = $self->_get_logger();
285
286 my $arg = {@_};
287 $log->logconfess("need type to load file from import_xml/") if (! $arg->{'type'});
288
289 $self->{'type'} = $arg->{'type'};
290
291 my $type_base = $arg->{'type'};
292 $type_base =~ s/_.*$//g;
293
294 $self->{'tag'} = $type2tag{$type_base};
295
296 $log->info("using type '",$self->{'type'},"' tag <",$self->{'tag'},">");
297
298 my $f = "./import_xml/".$self->{'type'}.".xml";
299 $log->logconfess("import_xml file '$f' doesn't exist!") if (! -e "$f");
300
301 $log->info("reading '$f'");
302
303 $self->{'import_xml_file'} = $f;
304
305 $self->{'import_xml'} = XMLin($f,
306 ForceArray => [ $self->{'tag'}, 'config', 'format' ],
307 );
308
309 $log->debug("import xml is ",sub { Dumper($self->{'import_xml'}) });
310
311 }
312
313 =head2 create_lookup
314
315 Create lookup from record using lookup definition.
316
317 $self->create_lookup($rec, @lookups);
318
319 Called internally by C<open_*> methods.
320
321 =cut
322
323 sub create_lookup {
324 my $self = shift;
325
326 my $log = $self->_get_logger();
327
328 my $rec = shift || $log->logconfess("need record to create lookup");
329 $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
330
331 foreach my $i (@_) {
332 if ($i->{'eval'}) {
333 my $eval = $self->fill_in($rec,$i->{'eval'});
334 my $key = $self->fill_in($rec,$i->{'key'});
335 my @val = $self->fill_in($rec,$i->{'val'});
336 if ($key && @val && eval $eval) {
337 $log->debug("stored $key = ",sub { join(" | ",@val) });
338 push @{$self->{'lookup'}->{$key}}, @val;
339 }
340 } else {
341 my $key = $self->fill_in($rec,$i->{'key'});
342 my @val = $self->fill_in($rec,$i->{'val'});
343 if ($key && @val) {
344 $log->debug("stored $key = ",sub { join(" | ",@val) });
345 push @{$self->{'lookup'}->{$key}}, @val;
346 }
347 }
348 }
349 }
350
351 =head2 get_data
352
353 Returns value from record.
354
355 my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);
356
357 Arguments are:
358 record reference C<$rec>,
359 field C<$f>,
360 optional subfiled C<$sf>,
361 index for repeatable values C<$i>.
362
363 Optinal variable C<$found> will be incremeted if there
364 is field.
365
366 Returns value or empty string.
367
368 =cut
369
370 sub get_data {
371 my $self = shift;
372
373 my ($rec,$f,$sf,$i,$found) = @_;
374
375 if ($$rec->{$f}) {
376 return '' if (! $$rec->{$f}->[$i]);
377 no strict 'refs';
378 if ($sf && $$rec->{$f}->[$i]->{$sf}) {
379 $$found++ if (defined($$found));
380 return $$rec->{$f}->[$i]->{$sf};
381 } elsif ($$rec->{$f}->[$i]) {
382 $$found++ if (defined($$found));
383 # it still might have subfield, just
384 # not specified, so we'll dump all
385 if ($$rec->{$f}->[$i] =~ /HASH/o) {
386 my $out;
387 foreach my $k (keys %{$$rec->{$f}->[$i]}) {
388 $out .= $$rec->{$f}->[$i]->{$k}." ";
389 }
390 return $out;
391 } else {
392 return $$rec->{$f}->[$i];
393 }
394 }
395 } else {
396 return '';
397 }
398 }
399
400 =head2 fill_in
401
402 Workhourse of all: takes record from in-memory structure of database and
403 strings with placeholders and returns string or array of with substituted
404 values from record.
405
406 my $text = $webpac->fill_in($rec,'v250^a');
407
408 Optional argument is ordinal number for repeatable fields. By default,
409 it's assume to be first repeatable field (fields are perl array, so first
410 element is 0).
411 Following example will read second value from repeatable field.
412
413 my $text = $webpac->fill_in($rec,'Title: v250^a',1);
414
415 This function B<does not> perform parsing of format to inteligenty skip
416 delimiters before fields which aren't used.
417
418 This method will automatically decode UTF-8 string to local code page
419 if needed.
420
421 =cut
422
423 sub fill_in {
424 my $self = shift;
425
426 my $log = $self->_get_logger();
427
428 my $rec = shift || $log->logconfess("need data record");
429 my $format = shift || $log->logconfess("need format to parse");
430 # iteration (for repeatable fields)
431 my $i = shift || 0;
432
433 # FIXME remove for speedup?
434 $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
435
436 if (utf8::is_utf8($format)) {
437 $format = $self->_x($format);
438 }
439
440 my $found = 0;
441
442 my $eval_code;
443 # remove eval{...} from beginning
444 $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
445
446 # do actual replacement of placeholders
447 $format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;
448
449 if ($found) {
450 $log->debug("format: $format");
451 if ($eval_code) {
452 my $eval = $self->fill_in($rec,$eval_code,$i);
453 return if (! $self->_eval($eval));
454 }
455 # do we have lookups?
456 if ($format =~ /$LOOKUP_REGEX/o) {
457 $log->debug("format '$format' has lookup");
458 return $self->lookup($format);
459 } else {
460 return $format;
461 }
462 } else {
463 return;
464 }
465 }
466
467 =head2 lookup
468
469 Perform lookups on format supplied to it.
470
471 my $text = $self->lookup('[v900]');
472
473 Lookups can be nested (like C<[d:[a:[v900]]]>).
474
475 =cut
476
477 sub lookup {
478 my $self = shift;
479
480 my $log = $self->_get_logger();
481
482 my $tmp = shift || $log->logconfess("need format");
483
484 if ($tmp =~ /$LOOKUP_REGEX/o) {
485 my @in = ( $tmp );
486
487 $log->debug("lookup for: ",$tmp);
488
489 my @out;
490 while (my $f = shift @in) {
491 if ($f =~ /$LOOKUP_REGEX_SAVE/o) {
492 my $k = $1;
493 if ($self->{'lookup'}->{$k}) {
494 foreach my $nv (@{$self->{'lookup'}->{$k}}) {
495 my $tmp2 = $f;
496 $tmp2 =~ s/lookup{$k}/$nv/g;
497 push @in, $tmp2;
498 }
499 } else {
500 undef $f;
501 }
502 } elsif ($f) {
503 push @out, $f;
504 }
505 }
506 $log->logconfess("return is array and it's not expected!") unless wantarray;
507 return @out;
508 } else {
509 return $tmp;
510 }
511 }
512
513 =head2 parse
514
515 Perform smart parsing of string, skipping delimiters for fields which aren't
516 defined. It can also eval code in format starting with C<eval{...}> and
517 return output or nothing depending on eval code.
518
519 my $text = $webpac->parse($rec,'eval{"v901^a" eq "Deskriptor"}descriptor: v250^a', $i);
520
521 =cut
522
523 sub parse {
524 my $self = shift;
525
526 my ($rec, $format_utf8, $i) = @_;
527
528 return if (! $format_utf8);
529
530 my $log = $self->_get_logger();
531
532 $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
533 $log->logconfess("need utf2cp Text::Iconv object!") if (! $self->{'utf2cp'});
534
535 $i = 0 if (! $i);
536
537 my $format = $self->_x($format_utf8) || $log->logconfess("can't convert '$format_utf8' from UTF-8 to ",$self->{'code_page'});
538
539 my @out;
540
541 $log->debug("format: $format");
542
543 my $eval_code;
544 # remove eval{...} from beginning
545 $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
546
547 my $prefix;
548 my $all_found=0;
549
550 while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))?//s) {
551
552 my $del = $1 || '';
553 $prefix ||= $del if ($all_found == 0);
554
555 my $found = 0;
556 my $tmp = $self->get_data(\$rec,$2,$3,$i,\$found);
557
558 if ($found) {
559 push @out, $del;
560 push @out, $tmp;
561 $all_found += $found;
562 }
563 }
564
565 return if (! $all_found);
566
567 my $out = join('',@out);
568
569 if ($out) {
570 # add rest of format (suffix)
571 $out .= $format;
572
573 # add prefix if not there
574 $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);
575
576 $log->debug("result: $out");
577 }
578
579 if ($eval_code) {
580 my $eval = $self->fill_in($rec,$eval_code,$i);
581 $log->debug("about to eval{",$eval,"} format: $out");
582 return if (! $self->_eval($eval));
583 }
584
585 return $out;
586 }
587
588 =head2 parse_to_arr
589
590 Similar to C<parse>, but returns array of all repeatable fields
591
592 my @arr = $webpac->parse_to_arr($rec,'v250^a');
593
594 =cut
595
596 sub parse_to_arr {
597 my $self = shift;
598
599 my ($rec, $format_utf8) = @_;
600
601 my $log = $self->_get_logger();
602
603 $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
604 return if (! $format_utf8);
605
606 my $i = 0;
607 my @arr;
608
609 while (my $v = $self->parse($rec,$format_utf8,$i++)) {
610 push @arr, $v;
611 }
612
613 $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
614
615 return @arr;
616 }
617
618 =head2 fill_in_to_arr
619
620 Similar to C<fill_in>, but returns array of all repeatable fields. Usable
621 for fields which have lookups, so they shouldn't be parsed but rather
622 C<fill_id>ed.
623
624 my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]');
625
626 =cut
627
628 sub fill_in_to_arr {
629 my $self = shift;
630
631 my ($rec, $format_utf8) = @_;
632
633 my $log = $self->_get_logger();
634
635 $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
636 return if (! $format_utf8);
637
638 my $i = 0;
639 my @arr;
640
641 while (my @v = $self->fill_in($rec,$format_utf8,$i++)) {
642 push @arr, @v;
643 }
644
645 $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
646
647 return @arr;
648 }
649
650
651 =head2 data_structure
652
653 Create in-memory data structure which represents layout from C<import_xml>.
654 It is used later to produce output.
655
656 my @ds = $webpac->data_structure($rec);
657
658 This method will also set C<$webpac->{'currnet_filename'}> if there is
659 <filename> tag in C<import_xml> and C<$webpac->{'headline'}> if there is
660 <headline> tag.
661
662 =cut
663
664 sub data_structure {
665 my $self = shift;
666
667 my $log = $self->_get_logger();
668
669 my $rec = shift;
670 $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
671
672 undef $self->{'currnet_filename'};
673 undef $self->{'headline'};
674
675 my @sorted_tags;
676 if ($self->{tags_by_order}) {
677 @sorted_tags = @{$self->{tags_by_order}};
678 } else {
679 @sorted_tags = sort { $self->_sort_by_order } keys %{$self->{'import_xml'}->{'indexer'}};
680 $self->{tags_by_order} = \@sorted_tags;
681 }
682
683 my @ds;
684
685 $log->debug("tags: ",sub { join(", ",@sorted_tags) });
686
687 foreach my $field (@sorted_tags) {
688
689 my $row;
690
691 #print "field $field [",$self->{'tag'},"] = ",Dumper($self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}});
692
693 foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {
694 my $format = $tag->{'value'} || $tag->{'content'};
695
696 $log->debug("format: $format");
697
698 my @v;
699 if ($format =~ /$LOOKUP_REGEX/o) {
700 @v = $self->fill_in_to_arr($rec,$format);
701 } else {
702 @v = $self->parse_to_arr($rec,$format);
703 }
704 next if (! @v);
705
706 # use format?
707 if ($tag->{'format_name'}) {
708 @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;
709 }
710
711 if ($field eq 'filename') {
712 $self->{'current_filename'} = join('',@v);
713 $log->debug("filename: ",$self->{'current_filename'});
714 } elsif ($field eq 'headline') {
715 $self->{'headline'} .= join('',@v);
716 $log->debug("headline: ",$self->{'headline'});
717 next; # don't return headline in data_structure!
718 }
719
720 # does tag have type?
721 if ($tag->{'type'}) {
722 push @{$row->{$tag->{'type'}}}, @v;
723 } else {
724 push @{$row->{'display'}}, @v;
725 push @{$row->{'swish'}}, @v;
726 }
727
728
729 }
730
731 if ($row) {
732 $row->{'tag'} = $field;
733
734 # TODO: name_sigular, name_plural
735 my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
736 $row->{'name'} = $name ? $self->_x($name) : $field;
737
738 push @ds, $row;
739
740 $log->debug("row $field: ",sub { Dumper($row) });
741 }
742
743 }
744
745 return @ds;
746
747 }
748
749 =head2 output
750
751 Create output from in-memory data structure using Template Toolkit template.
752
753 my $text = $webpac->output( template => 'text.tt', data => @ds );
754
755 =cut
756
757 sub output {
758 my $self = shift;
759
760 my $args = {@_};
761
762 my $log = $self->_get_logger();
763
764 $log->logconfess("need template name") if (! $args->{'template'});
765 $log->logconfess("need data array") if (! $args->{'data'});
766
767 my $out;
768
769 $self->{'tt'}->process(
770 $args->{'template'},
771 $args,
772 \$out
773 ) || confess $self->{'tt'}->error();
774
775 return $out;
776 }
777
778 =head2 apply_format
779
780 Apply format specified in tag with C<format_name="name"> and
781 C<format_delimiter=";;">.
782
783 my $text = $webpac->apply_format($format_name,$format_delimiter,$data);
784
785 Formats can contain C<lookup{...}> if you need them.
786
787 =cut
788
789 sub apply_format {
790 my $self = shift;
791
792 my ($name,$delimiter,$data) = @_;
793
794 my $log = $self->_get_logger();
795
796 if (! $self->{'import_xml'}->{'format'}->{$name}) {
797 $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});
798 return $data;
799 }
800
801 $log->warn("no delimiter for format $name") if (! $delimiter);
802
803 my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");
804
805 my @data = split(/\Q$delimiter\E/, $data);
806
807 my $out = sprintf($format, @data);
808 $log->debug("using format $name [$format] on $data to produce: $out");
809
810 if ($out =~ m/$LOOKUP_REGEX/o) {
811 return $self->lookup($out);
812 } else {
813 return $out;
814 }
815
816 }
817
818
819 #
820 #
821 #
822
823 =head1 INTERNAL METHODS
824
825 Here is a quick list of internal methods, mostly useful to turn debugging
826 on them (see L<LOGGING> below for explanation).
827
828 =cut
829
830 =head2 _eval
831
832 Internal function to eval code without C<strict 'subs'>.
833
834 =cut
835
836 sub _eval {
837 my $self = shift;
838
839 my $code = shift || return;
840
841 my $log = $self->_get_logger();
842
843 no strict 'subs';
844 my $ret = eval $code;
845 if ($@) {
846 $log->error("problem with eval code [$code]: $@");
847 }
848
849 $log->debug("eval: ",$code," [",$ret,"]");
850
851 return $ret || 0;
852 }
853
854 =head2 _sort_by_order
855
856 Sort xml tags data structure accoding to C<order=""> attribute.
857
858 =cut
859
860 sub _sort_by_order {
861 my $self = shift;
862
863 my $va = $self->{'import_xml'}->{'indexer'}->{$a}->{'order'} ||
864 $self->{'import_xml'}->{'indexer'}->{$a};
865 my $vb = $self->{'import_xml'}->{'indexer'}->{$b}->{'order'} ||
866 $self->{'import_xml'}->{'indexer'}->{$b};
867
868 return $va <=> $vb;
869 }
870
871 =head2 _get_logger
872
873 Get C<Log::Log4perl> object with a twist: domains are defined for each
874 method
875
876 my $log = $webpac->_get_logger();
877
878 =cut
879
880 sub _get_logger {
881 my $self = shift;
882
883 my $name = (caller(1))[3] || caller;
884 return get_logger($name);
885 }
886
887 =head2 _x
888
889 Convert string from UTF-8 to code page defined in C<import_xml>.
890
891 my $text = $webpac->_x('utf8 text');
892
893 =cut
894
895 sub _x {
896 my $self = shift;
897 my $utf8 = shift || return;
898
899 return $self->{'utf2cp'}->convert($utf8) ||
900 $self->_get_logger()->logwarn("can't convert '$utf8'");
901 }
902
903 #
904 #
905 #
906
907 =head1 LOGGING
908
909 Logging in WebPAC is performed by L<Log::Log4perl> with config file
910 C<log.conf>.
911
912 Methods defined above have different levels of logging, so
913 it's descriptions will be useful to turn (mostry B<debug> logging) on
914 or off to see why WabPAC isn't perforing as you expect it (it might even
915 be a bug!).
916
917 B<This is different from normal Log4perl behaviour>. To repeat, you can
918 also use method names, and not only classes (which are just few)
919 to filter logging.
920
921 =cut
922
923 1;

  ViewVC Help
Powered by ViewVC 1.1.26