/[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 856 by dpavlin, Sun May 27 16:00:26 2007 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    use Data::Dump qw/dump/;
9    
10    # If ture, enable logging debug
11    my $log_debug = 0;
12    
13  =head1 NAME  =head1 NAME
14    
# Line 11  WebPAC::Common - internal methods called Line 16  WebPAC::Common - internal methods called
16    
17  =head1 VERSION  =head1 VERSION
18    
19  Version 0.01  Version 0.04
20    
21  =cut  =cut
22    
23  our $VERSION = '0.01';  our $VERSION = '0.04';
24    
25  =head1 SYNOPSYS  =head1 SYNOPSYS
26    
27  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
28  specific modules.  specific modules.
29    
  my $webpac = new WebPAC::Common(  
         filter => {  
                 'filter_name_1' => sub {  
                         # filter code  
                         return length($_);  
                 }, ...  
         },  
   }  
   
30  =head1 FUNCTIONS  =head1 FUNCTIONS
31    
32  =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');  
33    
34  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.  
35    
36   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.  
37    
38  =cut  =cut
39    
40  sub fill_in {  sub progress_bar {
41          my $self = shift;          my $self = shift;
42    
43            my ($curr,$max) = @_;
44    
45          my $log = $self->_get_logger();          my $log = $self->_get_logger();
46    
47          my $rec = shift || $log->logconfess("need data record");          $self->{last_pcnt_t} ||= time();
         my $format = shift || $log->logconfess("need format to parse");  
         # iteration (for repeatable fields)  
         my $i = shift || 0;  
48    
49          $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));          $log->logconfess("no current value!") if (! $curr);
50            $log->logconfess("no maximum value!") if (! $max);
51    
52          # FIXME remove for speedup?          if ($curr > $max) {
53          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);                  $max = $curr;
54                    $log->debug("overflow to $curr");
55            }
56    
57            $self->{'last_pcnt'} ||= 1;
58            $self->{'start_t'} ||= time();
59    
60          if (utf8::is_utf8($format)) {          my $p = int($curr * 100 / $max) || 1;
61                  $format = $self->_x($format);  
62            # reset on re-run
63            if ($p < $self->{'last_pcnt'}) {
64                    $self->{'last_pcnt'} = $p;
65                    $self->{'start_t'} = time();
66          }          }
67    
68          my $found = 0;          my $t = time();
69    
70          my $eval_code;          if ($p != $self->{'last_pcnt'} || ( $t - $self->{last_pcnt_t} ) > 2 ) {
71          # remove eval{...} from beginning  
72          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);                  my $rate = ($curr / ($t - $self->{'start_t'} || 1));
73                    my $eta = ($max-$curr) / ($rate || 1);
74          my $filter_name;                  printf STDERR ("%5d [%-38s] %-5d %0.1f/s %s\r",$curr,"=" x ($p/3)."$p%>", $max, $rate, $self->fmt_time($eta));
75          # remove filter{...} from beginning                  $self->{'last_pcnt'} = $p;
76          $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);                  $self->{'last_curr'} = $curr;
77                    $self->{last_pcnt_t} = $t;
         # 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;  
78          }          }
79            print STDERR "\n" if ($p == 100);
80  }  }
81    
82    =head2 fmt_time
83    
84  =head2 get_data  Format time (in seconds) for display.
85    
86  Returns value from record.   print $webpac->fmt_time(time());
87    
88   my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);  This method is called by L<progress_bar> to display remaining time.
89    
90  Arguments are:  =cut
 record reference C<$rec>,  
 field C<$f>,  
 optional subfiled C<$sf>,  
 index for repeatable values C<$i>.  
91    
92  Optinal variable C<$found> will be incremeted if there  sub fmt_time {
93  is field.          my $self = shift;
94    
95  Returns value or empty string.          my $t = shift || 0;
96            my $out = "";
97    
98            my ($ss,$mm,$hh) = gmtime($t);
99            $out .= "${hh}h" if ($hh);
100            $out .= sprintf("%02d:%02d", $mm,$ss);
101            $out .= "  " if ($hh == 0);
102            return $out;
103    }
104    
105    =head2 fill_in
106    
107    Fill in variable names by values
108    
109      print $webpac->fill_in( 'foo = $foo bar = $bar',
110            foo => 42, bar => 11,
111      );
112    
113  =cut  =cut
114    
115  sub get_data {  sub fill_in {
116          my $self = shift;          my $self = shift;
117    
118          my ($rec,$f,$sf,$i,$found) = @_;          my $format = shift || die "no format?";
119            my $d = {@_};
120    
121          if ($$rec->{$f}) {          foreach my $n ( keys %$d ) {
122                  return '' if (! $$rec->{$f}->[$i]);                  $format =~ s/\$\Q$n\E/$d->{$n}/gs;
                 no strict 'refs';  
                 if ($sf && $$rec->{$f}->[$i]->{$sf}) {  
                         $$found++ if (defined($$found));  
                         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 '';  
123          }          }
124    
125            die "unknown variables in '$format' input data = ", dump( $d ) if ( $format =~ m/\$\w+/ );
126    
127            return $format;
128  }  }
129    
130    #
131    #
132    #
133    
134  =head1 INTERNAL METHODS  =head1 INTERNAL METHODS
135    
# Line 196  sub _eval { Line 162  sub _eval {
162          return $ret || undef;          return $ret || undef;
163  }  }
164    
 =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'");  
 }  
   
165  =head2 _init_logger  =head2 _init_logger
166    
167  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 169  This function will init C<Log::Log4perl>
169    $webpac->_init_logger('/path/to/log.conf');    $webpac->_init_logger('/path/to/log.conf');
170    
171  If no path to configuration file is given, dummy empty configuration  If no path to configuration file is given, dummy empty configuration
172  will be create.  will be created. If any mode which inherits from this one is called
173    with C<debug> flag, it will turn logging to debug level.
174    
175    This function will also read C<log_conf> value from current object and try
176    to read that as configuration file if it exists, if it doesn't it will
177    fallback to default C<conf/log.conf>.
178    
179    You can disable all logging by adding C<no_log> to constructor of WebPAC
180    object. Object in C<Test::Exception> class will disable logging
181    automatically.
182    
183  =cut  =cut
184    
185  sub _init_logger {  sub _init_logger {
186          my $self = shift;          my $self = shift;
187          my $file = shift;          my $file = shift;
188          if ($file) {          $file ||= $self->{'log_conf'};
189            $file = 'conf/log.conf';
190            my $name = (caller(2))[3] || caller;
191    
192            my $conf = q( );
193            if ($self->{'no_log'}) {
194                    warn "# $name disabled logging\n" if ($log_debug);
195            } elsif ($self->{'debug'}) {
196                    $conf = << '_log4perl_';
197    
198    log4perl.rootLogger=INFO, SCREEN
199    
200    log4perl.logger.WebPAC.=DEBUG
201    
202    log4perl.appender.SCREEN=Log::Log4perl::Appender::Screen
203    log4perl.appender.SCREEN.layout=PatternLayout
204    log4perl.appender.SCREEN.layout.ConversionPattern=%d %p> %F{1}:%L %M - %m%n
205    
206    _log4perl_
207                    warn "# $name is using debug logger\n" if ($log_debug);
208            } elsif ($name =~ m/Test::Exception/o) {
209                    warn "# disabled logging for Text::Exception\n" if ($log_debug);
210            } elsif (-e $file) {
211                    warn "# $name is using $file logger\n" if ($log_debug);
212                  Log::Log4perl->init($file);                  Log::Log4perl->init($file);
213                    return 1;
214          } else {          } else {
215                  my $conf = q( );                  warn "# $name is using null logger\n" if ($log_debug);
                 Log::Log4perl->init( \$conf );  
216          }          }
217            Log::Log4perl->init( \$conf );
218    
219            return 1;
220  }  }
221    
222    
# Line 267  method Line 229  method
229    
230  =cut  =cut
231    
232    my $_logger_seen;
233    
234  sub _get_logger {  sub _get_logger {
235          my $self = shift;          my $self = shift;
236    
         $self->{'_logger_ok'} ||= $self->_init_logger;  
   
237          my $name = (caller(1))[3] || caller;          my $name = (caller(1))[3] || caller;
238          return get_logger($name);  
239            # make name full
240            my $f = '';
241            if ($log_debug) {
242                    foreach ( 0 .. 5 ) {
243                            my $s = (caller($_))[3];
244                            $f .= "#### $_ >> $s\n" if ($s);
245                    }
246            }
247    
248            $self->{'_logger_'} ||= $self->_init_logger;
249    
250            my $log = get_logger( $name );
251            warn "# get_logger( $name ) level ", $log->level, "\n$f" if ($log_debug && !defined($_logger_seen->{$name}));
252            $_logger_seen->{$name}++;
253            return $log;
254  }  }
255    
256    
257    =head2 _log
258    
259    Quick cludge to make logging object available to scripts which
260    use webpac line this:
261    
262      my $log = _new WebPAC::Common()->_get_logger();
263    
264    =cut
265    
266    sub _new {
267            my $class = shift;
268            my $self = {@_};
269            bless($self, $class);
270    
271            $self ? return $self : return undef;
272    }
273    
274  =head1 LOGGING  =head1 LOGGING
275    
276  Logging in WebPAC is performed by L<Log::Log4perl> with config file  Logging in WebPAC is performed by L<Log::Log4perl> with config file
# Line 291  B<This is different from normal Log4perl Line 285  B<This is different from normal Log4perl
285  also use method names, and not only classes (which are just few)  also use method names, and not only classes (which are just few)
286  to filter logging.  to filter logging.
287    
288    =cut
289    
290    1;
Legend:
Removed from v.7  
changed lines
  Added in v.856
  ViewVC Help
Powered by ViewVC 1.1.26