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

Diff of /trunk2/lib/WebPAC.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 373 by dpavlin, Sun Jun 20 15:49:09 2004 UTC revision 412 by dpavlin, Tue Sep 7 18:01:36 2004 UTC
# Line 188  sub open_isis { Line 188  sub open_isis {
188    
189                                          push @{$self->{'data'}->{$mfn}->{$k}}, $val;                                          push @{$self->{'data'}->{$mfn}->{$k}}, $val;
190                                  }                                  }
191                            } else {
192                                    push @{$self->{'data'}->{$mfn}->{'000'}}, $mfn;
193                          }                          }
194    
195                  }                  }
# Line 196  sub open_isis { Line 198  sub open_isis {
198                  my $rec = $self->{'data'}->{$mfn};                  my $rec = $self->{'data'}->{$mfn};
199                  $self->create_lookup($rec, @{$arg->{'lookup'}});                  $self->create_lookup($rec, @{$arg->{'lookup'}});
200    
201                    $self->progress_bar($mfn,$maxmfn);
202    
203          }          }
204    
205          $self->{'current_mfn'} = 1;          $self->{'current_mfn'} = 1;
206            $self->{'last_pcnt'} = 0;
207    
208          # store max mfn and return it.          # store max mfn and return it.
209          return $self->{'max_mfn'} = $maxmfn;          return $self->{'max_mfn'} = $maxmfn;
# Line 226  sub fetch_rec { Line 231  sub fetch_rec {
231                  return;                  return;
232          }          }
233    
234            $self->progress_bar($mfn,$self->{'max_mfn'});
235    
236          return $self->{'data'}->{$mfn};          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            print STDERR "\n" if ($p == 100);
272    }
273    
274  =head2 open_import_xml  =head2 open_import_xml
275    
276  Read file from C<import_xml/> directory and parse it.  Read file from C<import_xml/> directory and parse it.
# Line 252  sub open_import_xml { Line 294  sub open_import_xml {
294    
295          $self->{'tag'} = $type2tag{$type_base};          $self->{'tag'} = $type2tag{$type_base};
296    
297          $log->debug("using type '",$self->{'type'},"' tag <",$self->{'tag'},">") if ($self->{'debug'});          $log->info("using type '",$self->{'type'},"' tag <",$self->{'tag'},">");
298    
299          my $f = "./import_xml/".$self->{'type'}.".xml";          my $f = "./import_xml/".$self->{'type'}.".xml";
300          $log->logconfess("import_xml file '$f' doesn't exist!") if (! -e "$f");          $log->logconfess("import_xml file '$f' doesn't exist!") if (! -e "$f");
301    
302          $log->debug("reading '$f'") if ($self->{'debug'});          $log->info("reading '$f'");
303    
304            $self->{'import_xml_file'} = $f;
305    
306          $self->{'import_xml'} = XMLin($f,          $self->{'import_xml'} = XMLin($f,
307                  ForceArray => [ $self->{'tag'}, 'config', 'format' ],                  ForceArray => [ $self->{'tag'}, 'config', 'format' ],
308          );          );
309    
310            $log->debug("import xml is ",sub { Dumper($self->{'import_xml'}) });
311    
312  }  }
313    
314  =head2 create_lookup  =head2 create_lookup
# Line 329  sub get_data { Line 375  sub get_data {
375    
376          if ($$rec->{$f}) {          if ($$rec->{$f}) {
377                  return '' if (! $$rec->{$f}->[$i]);                  return '' if (! $$rec->{$f}->[$i]);
378                    no strict 'refs';
379                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {
380                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
381                          return $$rec->{$f}->[$i]->{$sf};                          return $$rec->{$f}->[$i]->{$sf};
# Line 369  Following example will read second value Line 416  Following example will read second value
416  This function B<does not> perform parsing of format to inteligenty skip  This function B<does not> perform parsing of format to inteligenty skip
417  delimiters before fields which aren't used.  delimiters before fields which aren't used.
418    
419    This method will automatically decode UTF-8 string to local code page
420    if needed.
421    
422  =cut  =cut
423    
424  sub fill_in {  sub fill_in {
# Line 384  sub fill_in { Line 434  sub fill_in {
434          # FIXME remove for speedup?          # FIXME remove for speedup?
435          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
436    
437            if (utf8::is_utf8($format)) {
438                    $format = $self->_x($format);
439            }
440    
441          my $found = 0;          my $found = 0;
442    
443          my $eval_code;          my $eval_code;
# Line 481  sub parse { Line 535  sub parse {
535    
536          $i = 0 if (! $i);          $i = 0 if (! $i);
537    
538          my $format = $self->{'utf2cp'}->convert($format_utf8) || $log->logconfess("can't convert '$format_utf8' from UTF-8 to ",$self->{'code_page'});          my $format = $self->_x($format_utf8) || $log->logconfess("can't convert '$format_utf8' from UTF-8 to ",$self->{'code_page'});
539    
540          my @out;          my @out;
541    
# Line 602  It is used later to produce output. Line 656  It is used later to produce output.
656    
657   my @ds = $webpac->data_structure($rec);   my @ds = $webpac->data_structure($rec);
658    
659    This method will also set C<$webpac->{'currnet_filename'}> if there is
660    <filename> tag in C<import_xml> and C<$webpac->{'headline'}> if there is
661    <headline> tag.
662    
663  =cut  =cut
664    
665  sub data_structure {  sub data_structure {
# Line 612  sub data_structure { Line 670  sub data_structure {
670          my $rec = shift;          my $rec = shift;
671          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
672    
673            undef $self->{'currnet_filename'};
674            undef $self->{'headline'};
675    
676          my @sorted_tags;          my @sorted_tags;
677          if ($self->{tags_by_order}) {          if ($self->{tags_by_order}) {
678                  @sorted_tags = @{$self->{tags_by_order}};                  @sorted_tags = @{$self->{tags_by_order}};
# Line 643  sub data_structure { Line 704  sub data_structure {
704                          }                          }
705                          next if (! @v);                          next if (! @v);
706    
707                            # use format?
708                            if ($tag->{'format_name'}) {
709                                    @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;
710                            }
711    
712                            if ($field eq 'filename') {
713                                    $self->{'current_filename'} = join('',@v);
714                                    $log->debug("filename: ",$self->{'current_filename'});
715                            } elsif ($field eq 'headline') {
716                                    $self->{'headline'} .= join('',@v);
717                                    $log->debug("headline: ",$self->{'headline'});
718                                    next; # don't return headline in data_structure!
719                            }
720    
721                          # does tag have type?                          # does tag have type?
722                          if ($tag->{'type'}) {                          if ($tag->{'type'}) {
723                                  push @{$row->{$tag->{'type'}}}, @v;                                  push @{$row->{$tag->{'type'}}}, @v;
# Line 651  sub data_structure { Line 726  sub data_structure {
726                                  push @{$row->{'swish'}}, @v;                                  push @{$row->{'swish'}}, @v;
727                          }                          }
728    
729    
730                  }                  }
731    
732                  if ($row) {                  if ($row) {
733                          $row->{'tag'} = $field;                          $row->{'tag'} = $field;
734    
735                            # TODO: name_sigular, name_plural
736                            my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
737                            $row->{'name'} = $name ? $self->_x($name) : $field;
738    
739                          push @ds, $row;                          push @ds, $row;
740    
741                          $log->debug("row $field: ",sub { Dumper($row) });                          $log->debug("row $field: ",sub { Dumper($row) });
742                  }                  }
743    
# Line 694  sub output { Line 776  sub output {
776          return $out;          return $out;
777  }  }
778    
779    =head2 output_file
780    
781    Create output from in-memory data structure using Template Toolkit template
782    to a file.
783    
784     $webpac->output_file(
785            file => 'out.txt',
786            template => 'text.tt',
787            data => @ds
788     );
789    
790    =cut
791    
792    sub output_file {
793            my $self = shift;
794    
795            my $args = {@_};
796    
797            my $log = $self->_get_logger();
798    
799            $log->logconfess("need file name") if (! $args->{'file'});
800    
801            $log->debug("creating file ",$args->{'file'});
802    
803            open(my $fh, ">", $args->{'file'}) || $log->logdie("can't open output file '$self->{'file'}': $!");
804            print $fh $self->output(
805                    template => $args->{'template'},
806                    data => $args->{'data'},
807            ) || $log->logdie("print: $!");
808            close($fh) || $log->logdie("close: $!");
809    }
810    
811    =head2 apply_format
812    
813    Apply format specified in tag with C<format_name="name"> and
814    C<format_delimiter=";;">.
815    
816     my $text = $webpac->apply_format($format_name,$format_delimiter,$data);
817    
818    Formats can contain C<lookup{...}> if you need them.
819    
820    =cut
821    
822    sub apply_format {
823            my $self = shift;
824    
825            my ($name,$delimiter,$data) = @_;
826    
827            my $log = $self->_get_logger();
828    
829            if (! $self->{'import_xml'}->{'format'}->{$name}) {
830                    $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});
831                    return $data;
832            }
833    
834            $log->warn("no delimiter for format $name") if (! $delimiter);
835    
836            my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");
837    
838            my @data = split(/\Q$delimiter\E/, $data);
839    
840            my $out = sprintf($format, @data);
841            $log->debug("using format $name [$format] on $data to produce: $out");
842    
843            if ($out =~ m/$LOOKUP_REGEX/o) {
844                    return $self->lookup($out);
845            } else {
846                    return $out;
847            }
848    
849    }
850    
851    
852  #  #
853  #  #
854  #  #
# Line 746  sub _sort_by_order { Line 901  sub _sort_by_order {
901          return $va <=> $vb;          return $va <=> $vb;
902  }  }
903    
904    =head2 _get_logger
905    
906    Get C<Log::Log4perl> object with a twist: domains are defined for each
907    method
908    
909     my $log = $webpac->_get_logger();
910    
911    =cut
912    
913  sub _get_logger {  sub _get_logger {
914          my $self = shift;          my $self = shift;
915    
916          my @c = caller(1);          my $name = (caller(1))[3] || caller;
917          return get_logger($c[3]);          return get_logger($name);
918    }
919    
920    =head2 _x
921    
922    Convert string from UTF-8 to code page defined in C<import_xml>.
923    
924     my $text = $webpac->_x('utf8 text');
925    
926    =cut
927    
928    sub _x {
929            my $self = shift;
930            my $utf8 = shift || return;
931    
932            return $self->{'utf2cp'}->convert($utf8) ||
933                    $self->_get_logger()->logwarn("can't convert '$utf8'");
934  }  }
935    
936  #  #
Legend:
Removed from v.373  
changed lines
  Added in v.412
  ViewVC Help
Powered by ViewVC 1.1.26