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

Diff of /trunk2/lib/WebPAC.pm

Parent Directory | Revision Log | View Patch Patch

-revision 374 by dpavlin,
Sun Jun 20 16:57:52 2004 UTC
+revision 418 by dpavlin,
Thu Sep  9 18:08:38 2004 UTC
 Line 169 
 sub open_isis {
          # read database
          for (my $mfn = 1; $mfn <= $maxmfn; $mfn++) {
+                 $log->debug("mfn: $mfn\n");
                  # read record
                  my $row = OpenIsis::read( $isis_db, $mfn );
                  foreach my $k (keys %{$row}) {
-Line 195 
 sub open_isis {
+Line 198 
 sub open_isis {
                  }
                  # create lookup
-                 my $rec = $self->{'data'}->{$mfn};
+                 my $rec = $self->{'data'}->{$mfn} || $log->confess("record $mfn empty?");
                  $self->create_lookup($rec, @{$arg->{'lookup'}});
+                 $self->progress_bar($mfn,$maxmfn);
          }
          $self->{'current_mfn'} = 1;
+         $self->{'last_pcnt'} = 0;
+         $log->debug("max mfn: $maxmfn");
          # store max mfn and return it.
          return $self->{'max_mfn'} = $maxmfn;
-Line 228 
 sub fetch_rec {
+Line 236 
 sub fetch_rec {
                  return;
          }
+         $self->progress_bar($mfn,$self->{'max_mfn'});
          return $self->{'data'}->{$mfn};
  }
+ =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->{'last_pcnt'} = $curr if ($curr < $self->{'last_pcnt'});
+         my $p = int($curr * 100 / $max);
+         if ($p != $self->{'last_pcnt'}) {
+                 printf STDERR ("%5d / %5d [%-51s] %-2d %% \r",$curr,$max,"=" x ($p/2).">", $p );
+                 $self->{'last_pcnt'} = $p;
+         }
+         print STDERR "\n" if ($p == 100);
+ }
  =head2 open_import_xml
  Read file from C<import_xml/> directory and parse it.
-Line 254 
 sub open_import_xml {
+Line 299 
 sub open_import_xml {
          $self->{'tag'} = $type2tag{$type_base};
-         $log->debug("using type '",$self->{'type'},"' tag <",$self->{'tag'},">") if ($self->{'debug'});
+         $log->info("using type '",$self->{'type'},"' tag <",$self->{'tag'},">");
          my $f = "./import_xml/".$self->{'type'}.".xml";
          $log->logconfess("import_xml file '$f' doesn't exist!") if (! -e "$f");
-         $log->debug("reading '$f'") if ($self->{'debug'});
+         $log->info("reading '$f'");
+         $self->{'import_xml_file'} = $f;
          $self->{'import_xml'} = XMLin($f,
                  ForceArray => [ $self->{'tag'}, 'config', 'format' ],
          );
+         $log->debug("import xml is ",sub { Dumper($self->{'import_xml'}) });
  }
  =head2 create_lookup
-Line 286 
 sub create_lookup {
+Line 335 
 sub create_lookup {
          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
          foreach my $i (@_) {
-                 if ($i->{'eval'}) {
+                 $log->logconfess("need key") unless defined($i->{'key'});
-                         my $eval = $self->fill_in($rec,$i->{'eval'});
+                 $log->logconfess("need val") unless defined($i->{'val'});
-                         my $key = $self->fill_in($rec,$i->{'key'});
-                         my @val = $self->fill_in($rec,$i->{'val'});
+                 if (defined($i->{'eval'})) {
-                         if ($key && @val && eval $eval) {
+                         # eval first, so we can skip fill_in for key and val
+                         my $eval = $self->fill_in($rec,$i->{'eval'}) || next;
+                         if ($self->_eval($eval)) {
+                                 my $key = $self->fill_in($rec,$i->{'key'}) || next;
+                                 my @val = $self->fill_in($rec,$i->{'val'}) || next;
                                  $log->debug("stored $key = ",sub { join(" | ",@val) });
                                  push @{$self->{'lookup'}->{$key}}, @val;
                          }
                  } else {
-                         my $key = $self->fill_in($rec,$i->{'key'});
+                         my $key = $self->fill_in($rec,$i->{'key'}) || next;
-                         my @val = $self->fill_in($rec,$i->{'val'});
+                         my @val = $self->fill_in($rec,$i->{'val'}) || next;
-                         if ($key && @val) {
+                         $log->debug("stored $key = ",sub { join(" | ",@val) });
-                                 $log->debug("stored $key = ",sub { join(" | ",@val) });
+                         push @{$self->{'lookup'}->{$key}}, @val;
-                                 push @{$self->{'lookup'}->{$key}}, @val;
-                         }
                  }
          }
  }
-Line 331 
 sub get_data {
+Line 382 
 sub get_data {
          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};
-Line 371 
 Following example will read second value
+Line 423 
 Following example will read second value
  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 {
-Line 386 
 sub fill_in {
+Line 441 
 sub fill_in {
          # 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;
-Line 483 
 sub parse {
+Line 542 
 sub parse {
          $i = 0 if (! $i);
-         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'});
          my @out;
-Line 605 
 It is used later to produce output.
+Line 664 
 It is used later to produce output.
   my @ds = $webpac->data_structure($rec);
  This method will also set C<$webpac->{'currnet_filename'}> if there is
- <filename> tag in C<import_xml>.
+ <filename> tag in C<import_xml> and C<$webpac->{'headline'}> if there is
+ <headline> tag.
  =cut
-Line 618 
 sub data_structure {
+Line 678 
 sub data_structure {
          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
          undef $self->{'currnet_filename'};
+         undef $self->{'headline'};
          my @sorted_tags;
          if ($self->{tags_by_order}) {
-Line 650 
 sub data_structure {
+Line 711 
 sub data_structure {
                          }
                          next if (! @v);
+                         # use format?
+                         if ($tag->{'format_name'}) {
+                                 @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;
+                         }
+                         if ($field eq 'filename') {
+                                 $self->{'current_filename'} = join('',@v);
+                                 $log->debug("filename: ",$self->{'current_filename'});
+                         } elsif ($field eq 'headline') {
+                                 $self->{'headline'} .= join('',@v);
+                                 $log->debug("headline: ",$self->{'headline'});
+                                 next; # don't return headline in data_structure!
+                         }
                          # does tag have type?
                          if ($tag->{'type'}) {
                                  push @{$row->{$tag->{'type'}}}, @v;
-Line 658 
 sub data_structure {
+Line 733 
 sub data_structure {
                                  push @{$row->{'swish'}}, @v;
                          }
-                         if ($field eq 'filename') {
-                                 $self->{'current_filename'} = join('',@v);
-                                 $log->debug("filename: ",$self->{'current_filename'});
-                         }
                  }
                  if ($row) {
                          $row->{'tag'} = $field;
+                         # TODO: name_sigular, name_plural
+                         my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
+                         $row->{'name'} = $name ? $self->_x($name) : $field;
                          push @ds, $row;
                          $log->debug("row $field: ",sub { Dumper($row) });
-Line 707 
 sub output {
+Line 783 
 sub output {
          return $out;
  }
+ =head2 output_file
+ Create output from in-memory data structure using Template Toolkit template
+ to a file.
+  $webpac->output_file(
+         file => 'out.txt',
+         template => 'text.tt',
+         data => @ds
+  );
+ =cut
+ sub output_file {
+         my $self = shift;
+         my $args = {@_};
+         my $log = $self->_get_logger();
+         $log->logconfess("need file name") if (! $args->{'file'});
+         $log->debug("creating file ",$args->{'file'});
+         open(my $fh, ">", $args->{'file'}) || $log->logdie("can't open output file '$self->{'file'}': $!");
+         print $fh $self->output(
+                 template => $args->{'template'},
+                 data => $args->{'data'},
+         ) || $log->logdie("print: $!");
+         close($fh) || $log->logdie("close: $!");
+ }
+ =head2 apply_format
+ Apply format specified in tag with C<format_name="name"> and
+ C<format_delimiter=";;">.
+  my $text = $webpac->apply_format($format_name,$format_delimiter,$data);
+ Formats can contain C<lookup{...}> if you need them.
+ =cut
+ sub apply_format {
+         my $self = shift;
+         my ($name,$delimiter,$data) = @_;
+         my $log = $self->_get_logger();
+         if (! $self->{'import_xml'}->{'format'}->{$name}) {
+                 $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});
+                 return $data;
+         }
+         $log->warn("no delimiter for format $name") if (! $delimiter);
+         my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");
+         my @data = split(/\Q$delimiter\E/, $data);
+         my $out = sprintf($format, @data);
+         $log->debug("using format $name [$format] on $data to produce: $out");
+         if ($out =~ m/$LOOKUP_REGEX/o) {
+                 return $self->lookup($out);
+         } else {
+                 return $out;
+         }
+ }
  #
  #
  #
-Line 759 
 sub _sort_by_order {
+Line 908 
 sub _sort_by_order {
          return $va <=> $vb;
  }
+ =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;
-Line 766 
 sub _get_logger {
+Line 924 
 sub _get_logger {
          return get_logger($name);
  }
+ =head2 _x
+ Convert string from UTF-8 to code page defined in C<import_xml>.
+  my $text = $webpac->_x('utf8 text');
+ =cut
+ sub _x {
+         my $self = shift;
+         my $utf8 = shift || return;
+         return $self->{'utf2cp'}->convert($utf8) ||
+                 $self->_get_logger()->logwarn("can't convert '$utf8'");
+ }
  #
  #
  #

 Legend:



Removed from v.374
 


changed lines


 
Added in v.418
 Legend:



Removed from v.374
 


changed lines


 
Added in v.418
-Removed from v.374
+Added in v.418

	ViewVC Help
Powered by ViewVC 1.1.26