/[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 4 by dpavlin, Sat Jul 16 12:37:18 2005 UTC revision 13 by dpavlin, Sat Jul 16 23:56:14 2005 UTC
# Line 17  Version 0.01 Line 17  Version 0.01
17    
18  our $VERSION = '0.01';  our $VERSION = '0.01';
19    
20  #my $LOOKUP_REGEX = '\[[^\[\]]+\]';  =head1 SYNOPSYS
 #my $LOOKUP_REGEX_SAVE = '\[([^\[\]]+)\]';  
 my $LOOKUP_REGEX = 'lookup{[^\{\}]+}';  
 my $LOOKUP_REGEX_SAVE = 'lookup{([^\{\}]+)}';  
21    
22    This module defines common functions, and is used as base for other, more
23    specific modules.
24    
25     my $webpac = new WebPAC::Common(
26            filter => {
27                    'filter_name_1' => sub {
28                            # filter code
29                            return length($_);
30                    }, ...
31            },
32      }
33    
34  =head1 FUNCTIONS  =head1 FUNCTIONS
35    
# Line 96  sub fill_in { Line 104  sub fill_in {
104                          $log->debug("filter result: $format");                          $log->debug("filter result: $format");
105                  }                  }
106                  # do we have lookups?                  # do we have lookups?
107                  if ($format =~ /$LOOKUP_REGEX/o) {                  if ($self->{'lookup'}) {
                         $log->debug("format '$format' has lookup");  
108                          return $self->lookup($format);                          return $self->lookup($format);
109                  } else {                  } else {
110                          return $format;                          return $format;
# Line 158  sub get_data { Line 165  sub get_data {
165  }  }
166    
167    
168  =head1 INTERNAL METHODS  =head2 progress_bar
169    
170  Here is a quick list of internal methods, mostly useful to turn debugging  Draw progress bar on STDERR.
 on them (see L<LOGGING> below for explanation).  
171    
172  =cut   $webpac->progress_bar($current, $max);
   
 =head2 _eval  
   
 Internal function to eval code without C<strict 'subs'>.  
173    
174  =cut  =cut
175    
176  sub _eval {  sub progress_bar {
177          my $self = shift;          my $self = shift;
178    
179          my $code = shift || return;          my ($curr,$max) = @_;
180    
181          my $log = $self->_get_logger();          my $log = $self->_get_logger();
182    
183          no strict 'subs';          $log->logconfess("no current value!") if (! $curr);
184          my $ret = eval $code;          $log->logconfess("no maximum value!") if (! $max);
185          if ($@) {  
186                  $log->error("problem with eval code [$code]: $@");          if ($curr > $max) {
187                    $max = $curr;
188                    $log->debug("overflow to $curr");
189          }          }
190    
191          $log->debug("eval: ",$code," [",$ret,"]");          $self->{'last_pcnt'} ||= 1;
192            $self->{'start_t'} ||= time();
193    
194          return $ret || undef;          my $p = int($curr * 100 / $max) || 1;
195    
196            # reset on re-run
197            if ($p < $self->{'last_pcnt'}) {
198                    $self->{'last_pcnt'} = $p;
199                    $self->{'start_t'} = time();
200            }
201    
202            if ($p != $self->{'last_pcnt'}) {
203    
204                    my $t = time();
205                    my $rate = ($curr / ($t - $self->{'start_t'} || 1));
206                    my $eta = ($max-$curr) / ($rate || 1);
207                    printf STDERR ("%5d [%-38s] %-5d %0.1f/s %s\r",$curr,"=" x ($p/3)."$p%>", $max, $rate, $self->fmt_time($eta));
208                    $self->{'last_pcnt'} = $p;
209                    $self->{'last_curr'} = $curr;
210            }
211            print STDERR "\n" if ($p == 100);
212  }  }
213    
214  =head2 _sort_by_order  =head2 fmt_time
215    
216  Sort xml tags data structure accoding to C<order=""> attribute.  Format time (in seconds) for display.
217    
218     print $webpac->fmt_time(time());
219    
220    This method is called by L<progress_bar> to display remaining time.
221    
222  =cut  =cut
223    
224  sub _sort_by_order {  sub fmt_time {
225          my $self = shift;          my $self = shift;
226    
227          my $va = $self->{'import_xml'}->{'indexer'}->{$a}->{'order'} ||          my $t = shift || 0;
228                  $self->{'import_xml'}->{'indexer'}->{$a};          my $out = "";
         my $vb = $self->{'import_xml'}->{'indexer'}->{$b}->{'order'} ||  
                 $self->{'import_xml'}->{'indexer'}->{$b};  
229    
230          return $va <=> $vb;          my ($ss,$mm,$hh) = gmtime($t);
231            $out .= "${hh}h" if ($hh);
232            $out .= sprintf("%02d:%02d", $mm,$ss);
233            $out .= "  " if ($hh == 0);
234            return $out;
235  }  }
236    
237  =head2 _x  #
238    #
239    #
240    
241    =head1 INTERNAL METHODS
242    
243  Convert string from UTF-8 to code page defined in C<import_xml>.  Here is a quick list of internal methods, mostly useful to turn debugging
244    on them (see L<LOGGING> below for explanation).
245    
246   my $text = $webpac->_x('utf8 text');  =cut
247    
248  Default application code page is C<ISO-8859-2>. You will probably want to  =head2 _eval
249  change that when creating new instance of object based on this one.  
250    Internal function to eval code without C<strict 'subs'>.
251    
252  =cut  =cut
253    
254  sub _x {  sub _eval {
255          my $self = shift;          my $self = shift;
         my $utf8 = shift || return;  
256    
257          # create UTF-8 convertor for import_xml files          my $code = shift || return;
258          $self->{'utf2cp'} ||= Text::Iconv->new('UTF-8' ,$self->{'code_page'} || 'ISO-8859-2');  
259            my $log = $self->_get_logger();
260    
261            no strict 'subs';
262            my $ret = eval $code;
263            if ($@) {
264                    $log->error("problem with eval code [$code]: $@");
265            }
266    
267            $log->debug("eval: ",$code," [",$ret,"]");
268    
269          return $self->{'utf2cp'}->convert($utf8) ||          return $ret || undef;
                 $self->_get_logger()->logwarn("can't convert '$utf8'");  
270  }  }
271    
272  =head2 _init_logger  =head2 _init_logger
# Line 234  This function will init C<Log::Log4perl> Line 275  This function will init C<Log::Log4perl>
275    
276    $webpac->_init_logger('/path/to/log.conf');    $webpac->_init_logger('/path/to/log.conf');
277    
278    If no path to configuration file is given, dummy empty configuration
279    will be created. If any mode which inherits from this one is called
280    with C<debug> flag, it will turn logging to debug level.
281    
282  =cut  =cut
283    
284  sub _init_logger {  sub _init_logger {
# Line 243  sub _init_logger { Line 288  sub _init_logger {
288                  Log::Log4perl->init($file);                  Log::Log4perl->init($file);
289          } else {          } else {
290                  my $conf = q( );                  my $conf = q( );
291                    if ($self->{'debug'}) {
292                            $conf = << '_log4perl_';
293    
294    log4perl.rootLogger=INFO, SCREEN
295    
296    log4perl.logger.WebPAC.=DEBUG
297    
298    log4perl.appender.SCREEN=Log::Log4perl::Appender::Screen
299    log4perl.appender.SCREEN.layout=PatternLayout
300    log4perl.appender.SCREEN.layout.ConversionPattern=%d %p> %F{1}:%L %M - %m%n
301    
302    _log4perl_
303                    }
304                  Log::Log4perl->init( \$conf );                  Log::Log4perl->init( \$conf );
305          }          }
306  }  }
Legend:
Removed from v.4  
changed lines
  Added in v.13
  ViewVC Help
Powered by ViewVC 1.1.26