/[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 374 by dpavlin, Sun Jun 20 16:57:52 2004 UTC revision 389 by dpavlin, Tue Jul 20 17:15:48 2004 UTC
# Line 198  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 228  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    }
272    
273  =head2 open_import_xml  =head2 open_import_xml
274    
275  Read file from C<import_xml/> directory and parse it.  Read file from C<import_xml/> directory and parse it.
# Line 254  sub open_import_xml { Line 293  sub open_import_xml {
293    
294          $self->{'tag'} = $type2tag{$type_base};          $self->{'tag'} = $type2tag{$type_base};
295    
296          $log->debug("using type '",$self->{'type'},"' tag <",$self->{'tag'},">") if ($self->{'debug'});          $log->info("using type '",$self->{'type'},"' tag <",$self->{'tag'},">");
297    
298          my $f = "./import_xml/".$self->{'type'}.".xml";          my $f = "./import_xml/".$self->{'type'}.".xml";
299          $log->logconfess("import_xml file '$f' doesn't exist!") if (! -e "$f");          $log->logconfess("import_xml file '$f' doesn't exist!") if (! -e "$f");
300    
301          $log->debug("reading '$f'") if ($self->{'debug'});          $log->info("reading '$f'");
302    
303            $self->{'import_xml_file'} = $f;
304    
305          $self->{'import_xml'} = XMLin($f,          $self->{'import_xml'} = XMLin($f,
306                  ForceArray => [ $self->{'tag'}, 'config', 'format' ],                  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  =head2 create_lookup
# Line 331  sub get_data { Line 374  sub get_data {
374    
375          if ($$rec->{$f}) {          if ($$rec->{$f}) {
376                  return '' if (! $$rec->{$f}->[$i]);                  return '' if (! $$rec->{$f}->[$i]);
377                    no strict 'refs';
378                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {
379                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
380                          return $$rec->{$f}->[$i]->{$sf};                          return $$rec->{$f}->[$i]->{$sf};
# Line 371  Following example will read second value Line 415  Following example will read second value
415  This function B<does not> perform parsing of format to inteligenty skip  This function B<does not> perform parsing of format to inteligenty skip
416  delimiters before fields which aren't used.  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  =cut
422    
423  sub fill_in {  sub fill_in {
# Line 386  sub fill_in { Line 433  sub fill_in {
433          # FIXME remove for speedup?          # FIXME remove for speedup?
434          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $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;          my $found = 0;
441    
442          my $eval_code;          my $eval_code;
# Line 483  sub parse { Line 534  sub parse {
534    
535          $i = 0 if (! $i);          $i = 0 if (! $i);
536    
537          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'});
538    
539          my @out;          my @out;
540    
# Line 650  sub data_structure { Line 701  sub data_structure {
701                          }                          }
702                          next if (! @v);                          next if (! @v);
703    
704                            # use format?
705                            if ($tag->{'format_name'}) {
706                                    @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;
707                            }
708    
709                          # does tag have type?                          # does tag have type?
710                          if ($tag->{'type'}) {                          if ($tag->{'type'}) {
711                                  push @{$row->{$tag->{'type'}}}, @v;                                  push @{$row->{$tag->{'type'}}}, @v;
# Line 667  sub data_structure { Line 723  sub data_structure {
723    
724                  if ($row) {                  if ($row) {
725                          $row->{'tag'} = $field;                          $row->{'tag'} = $field;
726    
727                            # TODO: name_sigular, name_plural
728                            my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
729                            $row->{'name'} = $name ? $self->_x($name) : $field;
730    
731                          push @ds, $row;                          push @ds, $row;
732    
733                          $log->debug("row $field: ",sub { Dumper($row) });                          $log->debug("row $field: ",sub { Dumper($row) });
# Line 707  sub output { Line 768  sub output {
768          return $out;          return $out;
769  }  }
770    
771    =head2 apply_format
772    
773    Apply format specified in tag with C<format_name="name"> and
774    C<format_delimiter=";;">.
775    
776     my $text = $webpac->apply_format($format_name,$format_delimiter,$data);
777    
778    Formats can contain C<lookup{...}> if you need them.
779    
780    =cut
781    
782    sub apply_format {
783            my $self = shift;
784    
785            my ($name,$delimiter,$data) = @_;
786    
787            my $log = $self->_get_logger();
788    
789            if (! $self->{'import_xml'}->{'format'}->{$name}) {
790                    $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});
791                    return $data;
792            }
793    
794            $log->warn("no delimiter for format $name") if (! $delimiter);
795    
796            my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");
797    
798            my @data = split(/\Q$delimiter\E/, $data);
799    
800            my $out = sprintf($format, @data);
801            $log->debug("using format $name [$format] on $data to produce: $out");
802    
803            if ($out =~ m/$LOOKUP_REGEX/o) {
804                    return $self->lookup($out);
805            } else {
806                    return $out;
807            }
808    
809    }
810    
811    
812  #  #
813  #  #
814  #  #
# Line 759  sub _sort_by_order { Line 861  sub _sort_by_order {
861          return $va <=> $vb;          return $va <=> $vb;
862  }  }
863    
864    =head2 _get_logger
865    
866    Get C<Log::Log4perl> object with a twist: domains are defined for each
867    method
868    
869     my $log = $webpac->_get_logger();
870    
871    =cut
872    
873  sub _get_logger {  sub _get_logger {
874          my $self = shift;          my $self = shift;
875    
# Line 766  sub _get_logger { Line 877  sub _get_logger {
877          return get_logger($name);          return get_logger($name);
878  }  }
879    
880    =head2 _x
881    
882    Convert string from UTF-8 to code page defined in C<import_xml>.
883    
884     my $text = $webpac->_x('utf8 text');
885    
886    =cut
887    
888    sub _x {
889            my $self = shift;
890            my $utf8 = shift || return;
891    
892            return $self->{'utf2cp'}->convert($utf8) ||
893                    $self->_get_logger()->logwarn("can't convert '$utf8'");
894    }
895    
896  #  #
897  #  #
898  #  #
Legend:
Removed from v.374  
changed lines
  Added in v.389
  ViewVC Help
Powered by ViewVC 1.1.26