/[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

Annotation of /trunk2/lib/WebPAC.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 373 - (hide annotations)
Sun Jun 20 15:49:09 2004 UTC (16 years, 3 months ago) by dpavlin
File size: 16513 byte(s)
a lot more logging, lookups are now working as expected (and documented)

1 dpavlin 354 package WebPAC;
2 dpavlin 352
3 dpavlin 367 use warnings;
4     use strict;
5    
6 dpavlin 352 use Carp;
7 dpavlin 353 use Text::Iconv;
8     use Config::IniFiles;
9 dpavlin 363 use XML::Simple;
10 dpavlin 370 use Template;
11 dpavlin 372 use Log::Log4perl qw(get_logger :levels);
12 dpavlin 352
13 dpavlin 358 use Data::Dumper;
14    
15 dpavlin 373 #my $LOOKUP_REGEX = '\[[^\[\]]+\]';
16     #my $LOOKUP_REGEX_SAVE = '\[([^\[\]]+)\]';
17     my $LOOKUP_REGEX = 'lookup{[^\{\}]+}';
18     my $LOOKUP_REGEX_SAVE = 'lookup{([^\{\}]+)}';
19    
20 dpavlin 352 =head1 NAME
21    
22 dpavlin 354 WebPAC - base class for WebPAC
23 dpavlin 352
24     =head1 DESCRIPTION
25    
26 dpavlin 354 This module implements methods used by WebPAC.
27 dpavlin 352
28     =head1 METHODS
29    
30     =head2 new
31    
32 dpavlin 354 This will create new instance of WebPAC using configuration specified by C<config_file>.
33 dpavlin 352
34 dpavlin 354 my $webpac = new WebPAC(
35 dpavlin 352 config_file => 'name.conf',
36     [code_page => 'ISO-8859-2',]
37     );
38    
39     Default C<code_page> is C<ISO-8859-2>.
40    
41 dpavlin 353 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 dpavlin 352 =cut
47    
48 dpavlin 363 # 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 dpavlin 352 sub new {
58     my $class = shift;
59     my $self = {@_};
60     bless($self, $class);
61    
62 dpavlin 372 my $log_file = $self->{'log'} || "log.conf";
63     Log::Log4perl->init($log_file);
64    
65     my $log = $self->_get_logger();
66    
67 dpavlin 352 # fill in default values
68     # output codepage
69     $self->{'code_page'} = 'ISO-8859-2' if (! $self->{'code_page'});
70    
71 dpavlin 353 #
72     # read global.conf
73     #
74 dpavlin 372 $log->debug("read 'global.conf'");
75 dpavlin 352
76 dpavlin 372 my $config = new Config::IniFiles( -file => 'global.conf' ) || $log->logcroak("can't open 'global.conf'");
77 dpavlin 352
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 dpavlin 370 output_template
87 dpavlin 352 )) {
88 dpavlin 370 $self->{'global_config'}->{$var} = $config->val('global', $var);
89 dpavlin 352 }
90    
91 dpavlin 353 #
92     # read indexer config file
93     #
94 dpavlin 352
95 dpavlin 372 $self->{indexer_config_file} = new Config::IniFiles( -file => $self->{config_file} ) || $log->logcroak("can't open '",$self->{config_file},"'");
96 dpavlin 352
97 dpavlin 370 # create UTF-8 convertor for import_xml files
98 dpavlin 366 $self->{'utf2cp'} = Text::Iconv->new('UTF-8' ,$self->{'code_page'});
99 dpavlin 370
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 dpavlin 352 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 dpavlin 353 If optional parametar C<limit_mfn> is set, it will read just 500 records
126     from database in example above.
127 dpavlin 352
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 dpavlin 367 Returns number of last record read into memory (size of database, really).
140    
141 dpavlin 352 =cut
142    
143     sub open_isis {
144     my $self = shift;
145     my $arg = {@_};
146    
147 dpavlin 372 my $log = $self->_get_logger();
148    
149     $log->logcroak("need filename") if (! $arg->{'filename'});
150 dpavlin 352 my $code_page = $arg->{'code_page'} || '852';
151    
152 dpavlin 353 use OpenIsis;
153    
154 dpavlin 352 #$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 dpavlin 372 $log->info("reading ISIS database '",$arg->{'filename'},"'");
160 dpavlin 363
161 dpavlin 352 my $isis_db = OpenIsis::open($arg->{'filename'});
162    
163     my $maxmfn = OpenIsis::maxRowid( $isis_db ) || 1;
164    
165 dpavlin 357 $maxmfn = $self->{limit_mfn} if ($self->{limit_mfn});
166    
167 dpavlin 372 $log->info("processing $maxmfn records...");
168 dpavlin 363
169 dpavlin 352 # 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     }
192    
193     }
194    
195     # create lookup
196 dpavlin 355 my $rec = $self->{'data'}->{$mfn};
197     $self->create_lookup($rec, @{$arg->{'lookup'}});
198 dpavlin 352
199     }
200    
201 dpavlin 362 $self->{'current_mfn'} = 1;
202    
203 dpavlin 352 # store max mfn and return it.
204     return $self->{'max_mfn'} = $maxmfn;
205     }
206    
207 dpavlin 362 =head2 fetch_rec
208    
209     Fetch next record from database. It will also display progress bar (once
210     it's implemented, that is).
211    
212     my $rec = $webpac->fetch_rec;
213    
214     =cut
215    
216     sub fetch_rec {
217     my $self = shift;
218    
219 dpavlin 372 my $log = $self->_get_logger();
220 dpavlin 362
221 dpavlin 372 my $mfn = $self->{'current_mfn'}++ || $log->logconfess("it seems that you didn't load database!");
222    
223 dpavlin 362 if ($mfn > $self->{'max_mfn'}) {
224     $self->{'current_mfn'} = $self->{'max_mfn'};
225 dpavlin 373 $log->debug("at EOF");
226 dpavlin 362 return;
227     }
228    
229     return $self->{'data'}->{$mfn};
230     }
231    
232 dpavlin 363 =head2 open_import_xml
233    
234     Read file from C<import_xml/> directory and parse it.
235    
236     $webpac->open_import_xml(type => 'isis');
237    
238     =cut
239    
240     sub open_import_xml {
241     my $self = shift;
242    
243 dpavlin 372 my $log = $self->_get_logger();
244    
245 dpavlin 363 my $arg = {@_};
246 dpavlin 372 $log->logconfess("need type to load file from import_xml/") if (! $arg->{'type'});
247 dpavlin 363
248 dpavlin 366 $self->{'type'} = $arg->{'type'};
249 dpavlin 363
250 dpavlin 366 my $type_base = $arg->{'type'};
251 dpavlin 363 $type_base =~ s/_.*$//g;
252    
253 dpavlin 366 $self->{'tag'} = $type2tag{$type_base};
254    
255 dpavlin 372 $log->debug("using type '",$self->{'type'},"' tag <",$self->{'tag'},">") if ($self->{'debug'});
256 dpavlin 366
257     my $f = "./import_xml/".$self->{'type'}.".xml";
258 dpavlin 372 $log->logconfess("import_xml file '$f' doesn't exist!") if (! -e "$f");
259 dpavlin 363
260 dpavlin 372 $log->debug("reading '$f'") if ($self->{'debug'});
261 dpavlin 363
262     $self->{'import_xml'} = XMLin($f,
263 dpavlin 366 ForceArray => [ $self->{'tag'}, 'config', 'format' ],
264 dpavlin 363 );
265    
266     }
267    
268 dpavlin 355 =head2 create_lookup
269    
270     Create lookup from record using lookup definition.
271    
272 dpavlin 367 $self->create_lookup($rec, @lookups);
273    
274     Called internally by C<open_*> methods.
275    
276 dpavlin 355 =cut
277    
278     sub create_lookup {
279     my $self = shift;
280    
281 dpavlin 372 my $log = $self->_get_logger();
282 dpavlin 355
283 dpavlin 372 my $rec = shift || $log->logconfess("need record to create lookup");
284     $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
285    
286 dpavlin 355 foreach my $i (@_) {
287     if ($i->{'eval'}) {
288     my $eval = $self->fill_in($rec,$i->{'eval'});
289     my $key = $self->fill_in($rec,$i->{'key'});
290     my @val = $self->fill_in($rec,$i->{'val'});
291     if ($key && @val && eval $eval) {
292 dpavlin 373 $log->debug("stored $key = ",sub { join(" | ",@val) });
293 dpavlin 355 push @{$self->{'lookup'}->{$key}}, @val;
294     }
295     } else {
296     my $key = $self->fill_in($rec,$i->{'key'});
297     my @val = $self->fill_in($rec,$i->{'val'});
298     if ($key && @val) {
299 dpavlin 373 $log->debug("stored $key = ",sub { join(" | ",@val) });
300 dpavlin 355 push @{$self->{'lookup'}->{$key}}, @val;
301     }
302     }
303     }
304     }
305    
306 dpavlin 356 =head2 get_data
307    
308     Returns value from record.
309    
310 dpavlin 367 my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);
311 dpavlin 356
312     Arguments are:
313     record reference C<$rec>,
314     field C<$f>,
315     optional subfiled C<$sf>,
316     index for repeatable values C<$i>.
317    
318 dpavlin 367 Optinal variable C<$found> will be incremeted if there
319 dpavlin 356 is field.
320    
321     Returns value or empty string.
322    
323     =cut
324    
325     sub get_data {
326     my $self = shift;
327    
328     my ($rec,$f,$sf,$i,$found) = @_;
329 dpavlin 367
330 dpavlin 356 if ($$rec->{$f}) {
331 dpavlin 367 return '' if (! $$rec->{$f}->[$i]);
332 dpavlin 356 if ($sf && $$rec->{$f}->[$i]->{$sf}) {
333     $$found++ if (defined($$found));
334     return $$rec->{$f}->[$i]->{$sf};
335     } elsif ($$rec->{$f}->[$i]) {
336     $$found++ if (defined($$found));
337 dpavlin 366 # it still might have subfield, just
338     # not specified, so we'll dump all
339     if ($$rec->{$f}->[$i] =~ /HASH/o) {
340     my $out;
341     foreach my $k (keys %{$$rec->{$f}->[$i]}) {
342     $out .= $$rec->{$f}->[$i]->{$k}." ";
343     }
344     return $out;
345     } else {
346     return $$rec->{$f}->[$i];
347     }
348 dpavlin 356 }
349     } else {
350     return '';
351     }
352     }
353    
354 dpavlin 352 =head2 fill_in
355    
356     Workhourse of all: takes record from in-memory structure of database and
357     strings with placeholders and returns string or array of with substituted
358     values from record.
359    
360 dpavlin 367 my $text = $webpac->fill_in($rec,'v250^a');
361 dpavlin 352
362     Optional argument is ordinal number for repeatable fields. By default,
363 dpavlin 353 it's assume to be first repeatable field (fields are perl array, so first
364     element is 0).
365     Following example will read second value from repeatable field.
366 dpavlin 352
367 dpavlin 367 my $text = $webpac->fill_in($rec,'Title: v250^a',1);
368 dpavlin 353
369     This function B<does not> perform parsing of format to inteligenty skip
370     delimiters before fields which aren't used.
371    
372 dpavlin 352 =cut
373    
374 dpavlin 372 sub fill_in {
375 dpavlin 371 my $self = shift;
376    
377 dpavlin 372 my $log = $self->_get_logger();
378 dpavlin 371
379 dpavlin 372 my $rec = shift || $log->logconfess("need data record");
380     my $format = shift || $log->logconfess("need format to parse");
381 dpavlin 352 # iteration (for repeatable fields)
382     my $i = shift || 0;
383    
384     # FIXME remove for speedup?
385 dpavlin 372 $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
386 dpavlin 352
387     my $found = 0;
388    
389 dpavlin 359 my $eval_code;
390     # remove eval{...} from beginning
391     $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
392    
393 dpavlin 352 # do actual replacement of placeholders
394 dpavlin 373 $format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;
395 dpavlin 352
396 dpavlin 353 if ($found) {
397 dpavlin 373 $log->debug("format: $format");
398 dpavlin 359 if ($eval_code) {
399     my $eval = $self->fill_in($rec,$eval_code,$i);
400 dpavlin 371 return if (! $self->_eval($eval));
401 dpavlin 359 }
402 dpavlin 353 # do we have lookups?
403 dpavlin 373 if ($format =~ /$LOOKUP_REGEX/o) {
404     $log->debug("format '$format' has lookup");
405 dpavlin 353 return $self->lookup($format);
406     } else {
407     return $format;
408     }
409 dpavlin 352 } else {
410     return;
411     }
412     }
413    
414     =head2 lookup
415    
416 dpavlin 355 Perform lookups on format supplied to it.
417 dpavlin 352
418 dpavlin 367 my $text = $self->lookup('[v900]');
419 dpavlin 352
420 dpavlin 355 Lookups can be nested (like C<[d:[a:[v900]]]>).
421    
422 dpavlin 352 =cut
423    
424     sub lookup {
425     my $self = shift;
426    
427 dpavlin 372 my $log = $self->_get_logger();
428 dpavlin 352
429 dpavlin 372 my $tmp = shift || $log->logconfess("need format");
430    
431 dpavlin 373 if ($tmp =~ /$LOOKUP_REGEX/o) {
432 dpavlin 352 my @in = ( $tmp );
433 dpavlin 372
434     $log->debug("lookup for: ",$tmp);
435    
436 dpavlin 352 my @out;
437     while (my $f = shift @in) {
438 dpavlin 373 if ($f =~ /$LOOKUP_REGEX_SAVE/o) {
439 dpavlin 352 my $k = $1;
440     if ($self->{'lookup'}->{$k}) {
441     foreach my $nv (@{$self->{'lookup'}->{$k}}) {
442     my $tmp2 = $f;
443 dpavlin 373 $tmp2 =~ s/lookup{$k}/$nv/g;
444 dpavlin 352 push @in, $tmp2;
445     }
446     } else {
447     undef $f;
448     }
449     } elsif ($f) {
450     push @out, $f;
451     }
452     }
453 dpavlin 373 $log->logconfess("return is array and it's not expected!") unless wantarray;
454 dpavlin 352 return @out;
455     } else {
456     return $tmp;
457     }
458     }
459    
460 dpavlin 356 =head2 parse
461    
462     Perform smart parsing of string, skipping delimiters for fields which aren't
463     defined. It can also eval code in format starting with C<eval{...}> and
464     return output or nothing depending on eval code.
465    
466 dpavlin 367 my $text = $webpac->parse($rec,'eval{"v901^a" eq "Deskriptor"}descriptor: v250^a', $i);
467 dpavlin 356
468     =cut
469    
470     sub parse {
471     my $self = shift;
472    
473 dpavlin 366 my ($rec, $format_utf8, $i) = @_;
474 dpavlin 356
475 dpavlin 366 return if (! $format_utf8);
476    
477 dpavlin 372 my $log = $self->_get_logger();
478 dpavlin 358
479 dpavlin 372 $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
480     $log->logconfess("need utf2cp Text::Iconv object!") if (! $self->{'utf2cp'});
481    
482 dpavlin 358 $i = 0 if (! $i);
483    
484 dpavlin 372 my $format = $self->{'utf2cp'}->convert($format_utf8) || $log->logconfess("can't convert '$format_utf8' from UTF-8 to ",$self->{'code_page'});
485 dpavlin 366
486 dpavlin 356 my @out;
487    
488 dpavlin 373 $log->debug("format: $format");
489    
490 dpavlin 356 my $eval_code;
491     # remove eval{...} from beginning
492     $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
493    
494 dpavlin 358 my $prefix;
495     my $all_found=0;
496 dpavlin 356
497 dpavlin 373 while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))?//s) {
498 dpavlin 356
499 dpavlin 358 my $del = $1 || '';
500 dpavlin 359 $prefix ||= $del if ($all_found == 0);
501 dpavlin 358
502     my $found = 0;
503     my $tmp = $self->get_data(\$rec,$2,$3,$i,\$found);
504    
505 dpavlin 356 if ($found) {
506 dpavlin 358 push @out, $del;
507     push @out, $tmp;
508     $all_found += $found;
509 dpavlin 356 }
510     }
511    
512 dpavlin 358 return if (! $all_found);
513 dpavlin 356
514 dpavlin 373 my $out = join('',@out);
515 dpavlin 358
516 dpavlin 373 if ($out) {
517     # add rest of format (suffix)
518     $out .= $format;
519 dpavlin 367
520 dpavlin 373 # add prefix if not there
521     $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);
522    
523     $log->debug("result: $out");
524     }
525    
526 dpavlin 359 if ($eval_code) {
527     my $eval = $self->fill_in($rec,$eval_code,$i);
528 dpavlin 373 $log->debug("about to eval{",$eval,"} format: $out");
529 dpavlin 371 return if (! $self->_eval($eval));
530 dpavlin 359 }
531    
532 dpavlin 358 return $out;
533 dpavlin 356 }
534    
535 dpavlin 367 =head2 parse_to_arr
536    
537     Similar to C<parse>, but returns array of all repeatable fields
538    
539     my @arr = $webpac->parse_to_arr($rec,'v250^a');
540    
541     =cut
542    
543     sub parse_to_arr {
544     my $self = shift;
545    
546     my ($rec, $format_utf8) = @_;
547    
548 dpavlin 372 my $log = $self->_get_logger();
549    
550     $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
551 dpavlin 367 return if (! $format_utf8);
552    
553     my $i = 0;
554     my @arr;
555    
556     while (my $v = $self->parse($rec,$format_utf8,$i++)) {
557     push @arr, $v;
558     }
559    
560 dpavlin 373 $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
561    
562 dpavlin 367 return @arr;
563     }
564    
565 dpavlin 373 =head2 fill_in_to_arr
566    
567     Similar to C<fill_in>, but returns array of all repeatable fields. Usable
568     for fields which have lookups, so they shouldn't be parsed but rather
569     C<fill_id>ed.
570    
571     my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]');
572    
573     =cut
574    
575     sub fill_in_to_arr {
576     my $self = shift;
577    
578     my ($rec, $format_utf8) = @_;
579    
580     my $log = $self->_get_logger();
581    
582     $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
583     return if (! $format_utf8);
584    
585     my $i = 0;
586     my @arr;
587    
588     while (my @v = $self->fill_in($rec,$format_utf8,$i++)) {
589     push @arr, @v;
590     }
591    
592     $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
593    
594     return @arr;
595     }
596    
597    
598 dpavlin 366 =head2 data_structure
599    
600     Create in-memory data structure which represents layout from C<import_xml>.
601     It is used later to produce output.
602    
603 dpavlin 368 my @ds = $webpac->data_structure($rec);
604 dpavlin 366
605     =cut
606    
607 dpavlin 372 sub data_structure {
608 dpavlin 366 my $self = shift;
609    
610 dpavlin 372 my $log = $self->_get_logger();
611 dpavlin 366
612     my $rec = shift;
613 dpavlin 372 $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
614 dpavlin 366
615     my @sorted_tags;
616     if ($self->{tags_by_order}) {
617     @sorted_tags = @{$self->{tags_by_order}};
618     } else {
619     @sorted_tags = sort { $self->_sort_by_order } keys %{$self->{'import_xml'}->{'indexer'}};
620     $self->{tags_by_order} = \@sorted_tags;
621     }
622    
623 dpavlin 368 my @ds;
624 dpavlin 366
625 dpavlin 373 $log->debug("tags: ",sub { join(", ",@sorted_tags) });
626    
627 dpavlin 366 foreach my $field (@sorted_tags) {
628    
629     my $row;
630    
631     #print "field $field [",$self->{'tag'},"] = ",Dumper($self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}});
632    
633     foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {
634 dpavlin 373 my $format = $tag->{'value'} || $tag->{'content'};
635 dpavlin 366
636 dpavlin 373 $log->debug("format: $format");
637    
638     my @v;
639     if ($format =~ /$LOOKUP_REGEX/o) {
640     @v = $self->fill_in_to_arr($rec,$format);
641     } else {
642     @v = $self->parse_to_arr($rec,$format);
643     }
644 dpavlin 367 next if (! @v);
645 dpavlin 366
646     # does tag have type?
647     if ($tag->{'type'}) {
648 dpavlin 367 push @{$row->{$tag->{'type'}}}, @v;
649 dpavlin 366 } else {
650 dpavlin 367 push @{$row->{'display'}}, @v;
651     push @{$row->{'swish'}}, @v;
652 dpavlin 366 }
653 dpavlin 373
654 dpavlin 366 }
655    
656 dpavlin 368 if ($row) {
657     $row->{'tag'} = $field;
658     push @ds, $row;
659 dpavlin 373 $log->debug("row $field: ",sub { Dumper($row) });
660 dpavlin 368 }
661 dpavlin 366
662     }
663    
664 dpavlin 370 return @ds;
665 dpavlin 366
666     }
667    
668 dpavlin 370 =head2 output
669    
670     Create output from in-memory data structure using Template Toolkit template.
671    
672     my $text = $webpac->output( template => 'text.tt', data => @ds );
673    
674     =cut
675    
676     sub output {
677     my $self = shift;
678    
679     my $args = {@_};
680    
681 dpavlin 372 my $log = $self->_get_logger();
682 dpavlin 370
683 dpavlin 372 $log->logconfess("need template name") if (! $args->{'template'});
684     $log->logconfess("need data array") if (! $args->{'data'});
685    
686 dpavlin 370 my $out;
687    
688     $self->{'tt'}->process(
689     $args->{'template'},
690     $args,
691     \$out
692     ) || confess $self->{'tt'}->error();
693    
694     return $out;
695     }
696    
697 dpavlin 372 #
698     #
699     #
700    
701     =head1 INTERNAL METHODS
702    
703     Here is a quick list of internal methods, mostly useful to turn debugging
704     on them (see L<LOGGING> below for explanation).
705    
706     =cut
707    
708     =head2 _eval
709    
710     Internal function to eval code without C<strict 'subs'>.
711    
712     =cut
713    
714     sub _eval {
715     my $self = shift;
716    
717     my $code = shift || return;
718    
719     my $log = $self->_get_logger();
720    
721     no strict 'subs';
722     my $ret = eval $code;
723     if ($@) {
724     $log->error("problem with eval code [$code]: $@");
725     }
726    
727     $log->debug("eval: ",$code," [",$ret,"]");
728    
729     return $ret || 0;
730     }
731    
732     =head2 _sort_by_order
733    
734     Sort xml tags data structure accoding to C<order=""> attribute.
735    
736     =cut
737    
738     sub _sort_by_order {
739     my $self = shift;
740    
741     my $va = $self->{'import_xml'}->{'indexer'}->{$a}->{'order'} ||
742     $self->{'import_xml'}->{'indexer'}->{$a};
743     my $vb = $self->{'import_xml'}->{'indexer'}->{$b}->{'order'} ||
744     $self->{'import_xml'}->{'indexer'}->{$b};
745    
746     return $va <=> $vb;
747     }
748    
749     sub _get_logger {
750     my $self = shift;
751    
752     my @c = caller(1);
753     return get_logger($c[3]);
754     }
755    
756     #
757     #
758     #
759    
760     =head1 LOGGING
761    
762     Logging in WebPAC is performed by L<Log::Log4perl> with config file
763     C<log.conf>.
764    
765     Methods defined above have different levels of logging, so
766     it's descriptions will be useful to turn (mostry B<debug> logging) on
767     or off to see why WabPAC isn't perforing as you expect it (it might even
768     be a bug!).
769    
770     B<This is different from normal Log4perl behaviour>. To repeat, you can
771     also use method names, and not only classes (which are just few)
772     to filter logging.
773    
774     =cut
775    
776 dpavlin 352 1;

  ViewVC Help
Powered by ViewVC 1.1.26