/[webpac2]/trunk/lib/WebPAC/Common.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 /trunk/lib/WebPAC/Common.pm

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

revision 7 by dpavlin, Sat Jul 16 16:00:19 2005 UTC revision 16 by dpavlin, Sun Jul 17 11:37:07 2005 UTC
# Line 3  package WebPAC::Common; Line 3  package WebPAC::Common;
3  use warnings;  use warnings;
4  use strict;  use strict;
5    
6  use Log::Log4perl qw(get_logger :levels);  use Log::Log4perl qw/get_logger :levels/;
7    use Time::HiRes qw/time/;
8    
9  =head1 NAME  =head1 NAME
10    
# Line 22  our $VERSION = '0.01'; Line 23  our $VERSION = '0.01';
23  This module defines common functions, and is used as base for other, more  This module defines common functions, and is used as base for other, more
24  specific modules.  specific modules.
25    
  my $webpac = new WebPAC::Common(  
         filter => {  
                 'filter_name_1' => sub {  
                         # filter code  
                         return length($_);  
                 }, ...  
         },  
   }  
   
26  =head1 FUNCTIONS  =head1 FUNCTIONS
27    
28  =head2 fill_in  =head2 progress_bar
   
 Workhourse of all: takes record from in-memory structure of database and  
 strings with placeholders and returns string or array of with substituted  
 values from record.  
   
  my $text = $webpac->fill_in($rec,'v250^a');  
29    
30  Optional argument is ordinal number for repeatable fields. By default,  Draw progress bar on STDERR.
 it's assume to be first repeatable field (fields are perl array, so first  
 element is 0).  
 Following example will read second value from repeatable field.  
31    
32   my $text = $webpac->fill_in($rec,'Title: v250^a',1);   $webpac->progress_bar($current, $max);
   
 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.  
33    
34  =cut  =cut
35    
36  sub fill_in {  sub progress_bar {
37          my $self = shift;          my $self = shift;
38    
39            my ($curr,$max) = @_;
40    
41          my $log = $self->_get_logger();          my $log = $self->_get_logger();
42    
43          my $rec = shift || $log->logconfess("need data record");          $log->logconfess("no current value!") if (! $curr);
44          my $format = shift || $log->logconfess("need format to parse");          $log->logconfess("no maximum value!") if (! $max);
         # iteration (for repeatable fields)  
         my $i = shift || 0;  
45    
46          $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));          if ($curr > $max) {
47                    $max = $curr;
48                    $log->debug("overflow to $curr");
49            }
50    
51            $self->{'last_pcnt'} ||= 1;
52            $self->{'start_t'} ||= time();
53    
54          # FIXME remove for speedup?          my $p = int($curr * 100 / $max) || 1;
         $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);  
55    
56          if (utf8::is_utf8($format)) {          # reset on re-run
57                  $format = $self->_x($format);          if ($p < $self->{'last_pcnt'}) {
58                    $self->{'last_pcnt'} = $p;
59                    $self->{'start_t'} = time();
60          }          }
61    
62          my $found = 0;          if ($p != $self->{'last_pcnt'}) {
63    
64          my $eval_code;                  my $t = time();
65          # remove eval{...} from beginning                  my $rate = ($curr / ($t - $self->{'start_t'} || 1));
66          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);                  my $eta = ($max-$curr) / ($rate || 1);
67                    printf STDERR ("%5d [%-38s] %-5d %0.1f/s %s\r",$curr,"=" x ($p/3)."$p%>", $max, $rate, $self->fmt_time($eta));
68          my $filter_name;                  $self->{'last_pcnt'} = $p;
69          # remove filter{...} from beginning                  $self->{'last_curr'} = $curr;
         $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);  
   
         # do actual replacement of placeholders  
         # repeatable fields  
         $format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;  
         # non-repeatable fields  
         $format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found)/ges;  
   
         if ($found) {  
                 $log->debug("format: $format");  
                 if ($eval_code) {  
                         my $eval = $self->fill_in($rec,$eval_code,$i);  
                         return if (! $self->_eval($eval));  
                 }  
                 if ($filter_name && $self->{'filter'}->{$filter_name}) {  
                         $log->debug("filter '$filter_name' for $format");  
                         $format = $self->{'filter'}->{$filter_name}->($format);  
                         return unless(defined($format));  
                         $log->debug("filter result: $format");  
                 }  
                 # do we have lookups?  
                 if ($self->{'lookup'}) {  
                         return $self->lookup($format);  
                 } else {  
                         return $format;  
                 }  
         } else {  
                 return;  
70          }          }
71            print STDERR "\n" if ($p == 100);
72  }  }
73    
74    =head2 fmt_time
75    
76  =head2 get_data  Format time (in seconds) for display.
   
 Returns value from record.  
   
  my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);  
77    
78  Arguments are:   print $webpac->fmt_time(time());
 record reference C<$rec>,  
 field C<$f>,  
 optional subfiled C<$sf>,  
 index for repeatable values C<$i>.  
79    
80  Optinal variable C<$found> will be incremeted if there  This method is called by L<progress_bar> to display remaining time.
 is field.  
   
 Returns value or empty string.  
81    
82  =cut  =cut
83    
84  sub get_data {  sub fmt_time {
85          my $self = shift;          my $self = shift;
86    
87          my ($rec,$f,$sf,$i,$found) = @_;          my $t = shift || 0;
88            my $out = "";
89    
90          if ($$rec->{$f}) {          my ($ss,$mm,$hh) = gmtime($t);
91                  return '' if (! $$rec->{$f}->[$i]);          $out .= "${hh}h" if ($hh);
92                  no strict 'refs';          $out .= sprintf("%02d:%02d", $mm,$ss);
93                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {          $out .= "  " if ($hh == 0);
94                          $$found++ if (defined($$found));          return $out;
                         return $$rec->{$f}->[$i]->{$sf};  
                 } elsif ($$rec->{$f}->[$i]) {  
                         $$found++ if (defined($$found));  
                         # it still might have subfield, just  
                         # not specified, so we'll dump all  
                         if ($$rec->{$f}->[$i] =~ /HASH/o) {  
                                 my $out;  
                                 foreach my $k (keys %{$$rec->{$f}->[$i]}) {  
                                         $out .= $$rec->{$f}->[$i]->{$k}." ";  
                                 }  
                                 return $out;  
                         } else {  
                                 return $$rec->{$f}->[$i];  
                         }  
                 }  
         } else {  
                 return '';  
         }  
95  }  }
96    
97    #
98    #
99    #
100    
101  =head1 INTERNAL METHODS  =head1 INTERNAL METHODS
102    
# Line 196  sub _eval { Line 129  sub _eval {
129          return $ret || undef;          return $ret || undef;
130  }  }
131    
 =head2 _sort_by_order  
   
 Sort xml tags data structure accoding to C<order=""> attribute.  
   
 =cut  
   
 sub _sort_by_order {  
         my $self = shift;  
   
         my $va = $self->{'import_xml'}->{'indexer'}->{$a}->{'order'} ||  
                 $self->{'import_xml'}->{'indexer'}->{$a};  
         my $vb = $self->{'import_xml'}->{'indexer'}->{$b}->{'order'} ||  
                 $self->{'import_xml'}->{'indexer'}->{$b};  
   
         return $va <=> $vb;  
 }  
   
 =head2 _x  
   
 Convert string from UTF-8 to code page defined in C<import_xml>.  
   
  my $text = $webpac->_x('utf8 text');  
   
 Default application code page is C<ISO-8859-2>. You will probably want to  
 change that when creating new instance of object based on this one.  
   
 =cut  
   
 sub _x {  
         my $self = shift;  
         my $utf8 = shift || return;  
   
         # create UTF-8 convertor for import_xml files  
         $self->{'utf2cp'} ||= Text::Iconv->new('UTF-8' ,$self->{'code_page'} || 'ISO-8859-2');  
   
         return $self->{'utf2cp'}->convert($utf8) ||  
                 $self->_get_logger()->logwarn("can't convert '$utf8'");  
 }  
   
132  =head2 _init_logger  =head2 _init_logger
133    
134  This function will init C<Log::Log4perl> using provided configuration file.  This function will init C<Log::Log4perl> using provided configuration file.
# Line 242  This function will init C<Log::Log4perl> Line 136  This function will init C<Log::Log4perl>
136    $webpac->_init_logger('/path/to/log.conf');    $webpac->_init_logger('/path/to/log.conf');
137    
138  If no path to configuration file is given, dummy empty configuration  If no path to configuration file is given, dummy empty configuration
139  will be create.  will be created. If any mode which inherits from this one is called
140    with C<debug> flag, it will turn logging to debug level.
141    
142  =cut  =cut
143    
# Line 253  sub _init_logger { Line 148  sub _init_logger {
148                  Log::Log4perl->init($file);                  Log::Log4perl->init($file);
149          } else {          } else {
150                  my $conf = q( );                  my $conf = q( );
151                    if ($self->{'debug'}) {
152                            $conf = << '_log4perl_';
153    
154    log4perl.rootLogger=INFO, SCREEN
155    
156    log4perl.logger.WebPAC.=DEBUG
157    
158    log4perl.appender.SCREEN=Log::Log4perl::Appender::Screen
159    log4perl.appender.SCREEN.layout=PatternLayout
160    log4perl.appender.SCREEN.layout.ConversionPattern=%d %p> %F{1}:%L %M - %m%n
161    
162    _log4perl_
163                    }
164                  Log::Log4perl->init( \$conf );                  Log::Log4perl->init( \$conf );
165          }          }
166  }  }
Legend:
Removed from v.7  
changed lines
  Added in v.16
  ViewVC Help
Powered by ViewVC 1.1.26