/[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 10 by dpavlin, Sat Jul 16 20:35:30 2005 UTC revision 942 by dpavlin, Wed Oct 31 14:11:44 2007 UTC
# Line 1  Line 1 
1  package WebPAC::Common;  package WebPAC::Common;
2    use Exporter 'import';
3    @EXPORT = qw/
4            force_array
5    /;
6    
7  use warnings;  use warnings;
8  use strict;  use strict;
9    
10  use Log::Log4perl qw(get_logger :levels);  use Log::Log4perl qw/get_logger :levels/;
11    use Time::HiRes qw/time/;
12    use Data::Dump qw/dump/;
13    use File::Spec;
14    use Cwd qw/abs_path/;
15    
16    use base qw/Class::Accessor/;
17    __PACKAGE__->mk_accessors( qw/log_debug no_log debug/ );
18    
19  =head1 NAME  =head1 NAME
20    
# Line 11  WebPAC::Common - internal methods called Line 22  WebPAC::Common - internal methods called
22    
23  =head1 VERSION  =head1 VERSION
24    
25  Version 0.01  Version 0.05
26    
27  =cut  =cut
28    
29  our $VERSION = '0.01';  our $VERSION = '0.05';
30    
31  =head1 SYNOPSYS  =head1 SYNOPSYS
32    
33  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
34  specific modules.  specific modules.
35    
36   my $webpac = new WebPAC::Common(  my $o = WebPAC::Common->new({
37          filter => {          log_debug => 1,
38                  'filter_name_1' => sub {          no_log => 1,
39                          # filter code          debug => 1,
40                          return length($_);  });
                 }, ...  
         },  
   }  
   
 =head1 FUNCTIONS  
   
 =head2 fill_in  
   
 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');  
   
 Optional argument is ordinal number for repeatable fields. By default,  
 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.  
   
  my $text = $webpac->fill_in($rec,'Title: v250^a',1);  
   
 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 {  
         my $self = shift;  
   
         my $log = $self->_get_logger();  
   
         my $rec = shift || $log->logconfess("need data record");  
         my $format = shift || $log->logconfess("need format to parse");  
         # iteration (for repeatable fields)  
         my $i = shift || 0;  
   
         $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));  
   
         # 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;  
         # remove eval{...} from beginning  
         $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);  
   
         my $filter_name;  
         # remove filter{...} from beginning  
         $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;  
         }  
 }  
   
41    
42  =head2 get_data  Options:
43    
44  Returns value from record.  =over 20
45    
46   my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);  =item log_debug
47    
48  Arguments are:  Generate additional debugging log on C<STDERR>
 record reference C<$rec>,  
 field C<$f>,  
 optional subfiled C<$sf>,  
 index for repeatable values C<$i>.  
49    
50  Optinal variable C<$found> will be incremeted if there  =item no_log
 is field.  
51    
52  Returns value or empty string.  Disable all logging (useful for tests)
53    
54  =cut  =item debug
55    
56  sub get_data {  Use debugging logger which dumps output only yo C<STDERR>
         my $self = shift;  
57    
58          my ($rec,$f,$sf,$i,$found) = @_;  =back
59    
         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};  
                 } 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 '';  
         }  
 }  
60    
61    =head1 FUNCTIONS
62    
63  =head2 progress_bar  =head2 progress_bar
64    
# Line 180  sub progress_bar { Line 75  sub progress_bar {
75    
76          my $log = $self->_get_logger();          my $log = $self->_get_logger();
77    
78            $self->{last_pcnt_t} ||= time();
79    
80          $log->logconfess("no current value!") if (! $curr);          $log->logconfess("no current value!") if (! $curr);
81          $log->logconfess("no maximum value!") if (! $max);          $log->logconfess("no maximum value!") if (! $max);
82    
# Line 199  sub progress_bar { Line 96  sub progress_bar {
96                  $self->{'start_t'} = time();                  $self->{'start_t'} = time();
97          }          }
98    
99          if ($p != $self->{'last_pcnt'}) {          my $t = time();
100    
101            if ($p != $self->{'last_pcnt'} || ( $t - $self->{last_pcnt_t} ) > 2 ) {
102    
                 my $t = time();  
103                  my $rate = ($curr / ($t - $self->{'start_t'} || 1));                  my $rate = ($curr / ($t - $self->{'start_t'} || 1));
104                  my $eta = ($max-$curr) / ($rate || 1);                  my $eta = ($max-$curr) / ($rate || 1);
105                  printf STDERR ("%5d [%-38s] %-5d %0.1f/s %s\r",$curr,"=" x ($p/3)."$p%>", $max, $rate, $self->fmt_time($eta));                  printf STDERR ("%5d [%-38s] %-5d %0.1f/s %s\r",$curr,"=" x ($p/3)."$p%>", $max, $rate, $self->fmt_time($eta));
106                  $self->{'last_pcnt'} = $p;                  $self->{'last_pcnt'} = $p;
107                  $self->{'last_curr'} = $curr;                  $self->{'last_curr'} = $curr;
108                    $self->{last_pcnt_t} = $t;
109          }          }
110          print STDERR "\n" if ($p == 100);          print STDERR "\n" if ($p == 100);
111  }  }
# Line 234  sub fmt_time { Line 133  sub fmt_time {
133          return $out;          return $out;
134  }  }
135    
136    =head2 fill_in
137    
138    Fill in variable names by values
139    
140      print $webpac->fill_in( 'foo = $foo bar = $bar',
141            foo => 42, bar => 11,
142      );
143    
144    =cut
145    
146    sub fill_in {
147            my $self = shift;
148    
149            my $format = shift || die "no format?";
150            my $d = {@_};
151    
152            foreach my $n ( keys %$d ) {
153                    $format =~ s/\$\Q$n\E/$d->{$n}/gs;
154            }
155    
156            die "unknown variables in '$format' input data = ", dump( $d ) if ( $format =~ m/\$\w+/ );
157    
158            return $format;
159    }
160    
161  #  #
162  #  #
163  #  #
164    
165    =head2 var_path
166    
167      my $path = $self->var_path('data_dir', 'data_file', ... );
168    
169    =cut
170    
171    my $abs_path;
172    
173    sub var_path {
174            my $self = shift;
175    
176            if ( ! $abs_path ) {
177    #               $abs_path = abs_path( $0 );
178    #               $abs_path =~ s!/WebPAC/Common\.pm!!;
179                    $abs_path = '/data/webpac2';
180            }
181    
182            return File::Spec->catfile($abs_path, 'var', @_);
183    }
184    
185    =head1 EXPORTED NETHODS
186    
187    =head2 force_array
188    
189      my @array = force_array( $ref, sub {
190            warn "reference is undefined!";
191      });
192    
193    =cut
194    
195    sub force_array {
196            my ( $what, $error ) = @_;
197            my @result;
198            if ( ref( $what ) eq 'ARRAY' ) {
199                    @result = @{ $what };
200            } elsif ( defined $what ) {
201                    @result =  ( $what );
202            } else {
203                    $error->() if ref($error) eq 'CODE';
204            }
205            return @result;
206    }
207    
208    
209  =head1 INTERNAL METHODS  =head1 INTERNAL METHODS
210    
211  Here is a quick list of internal methods, mostly useful to turn debugging  Here is a quick list of internal methods, mostly useful to turn debugging
# Line 269  sub _eval { Line 237  sub _eval {
237          return $ret || undef;          return $ret || undef;
238  }  }
239    
 =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'");  
 }  
   
240  =head2 _init_logger  =head2 _init_logger
241    
242  This function will init C<Log::Log4perl> using provided configuration file.  This function will init C<Log::Log4perl> using provided configuration file.
# Line 318  If no path to configuration file is give Line 247  If no path to configuration file is give
247  will be created. If any mode which inherits from this one is called  will be created. If any mode which inherits from this one is called
248  with C<debug> flag, it will turn logging to debug level.  with C<debug> flag, it will turn logging to debug level.
249    
250    This function will also read C<log_conf> value from current object and try
251    to read that as configuration file if it exists, if it doesn't it will
252    fallback to default C<conf/log.conf>.
253    
254    You can disable all logging by adding C<no_log> to constructor of WebPAC
255    object. Object in C<Test::Exception> class will disable logging
256    automatically.
257    
258  =cut  =cut
259    
260  sub _init_logger {  sub _init_logger {
261          my $self = shift;          my $self = shift;
262          my $file = shift;          my $file = shift;
263          if ($file) {          $file ||= $self->{'log_conf'};
264                  Log::Log4perl->init($file);          $file = 'conf/log.conf';
265          } else {          my $name = (caller(2))[3] || caller;
266                  my $conf = q( );  
267                  if ($self->{'debug'}) {          my $conf = q( );
268                          $conf = << '_log4perl_';          if ($self->no_log) {
269                    warn "# $name disabled logging\n" if $self->log_debug;
270            } elsif ($self->debug) {
271                    $conf = << '_log4perl_';
272    
273  log4perl.rootLogger=INFO, SCREEN  log4perl.rootLogger=INFO, SCREEN
274    
# Line 339  log4perl.appender.SCREEN.layout=PatternL Line 279  log4perl.appender.SCREEN.layout=PatternL
279  log4perl.appender.SCREEN.layout.ConversionPattern=%d %p> %F{1}:%L %M - %m%n  log4perl.appender.SCREEN.layout.ConversionPattern=%d %p> %F{1}:%L %M - %m%n
280    
281  _log4perl_  _log4perl_
282                  }                  warn "# $name is using debug logger\n" if $self->log_debug;
283                  Log::Log4perl->init( \$conf );          } elsif ($name =~ m/Test::Exception/o) {
284                    warn "# disabled logging for Text::Exception\n" if $self->log_debug;
285            } elsif (-e $file) {
286                    warn "# $name is using $file logger\n" if $self->log_debug;
287                    Log::Log4perl->init($file);
288                    return 1;
289            } else {
290                    warn "# $name is using null logger\n" if $self->log_debug;
291          }          }
292            Log::Log4perl->init( \$conf );
293    
294            return 1;
295  }  }
296    
297    
# Line 354  method Line 304  method
304    
305  =cut  =cut
306    
307    my $_logger_seen;
308    
309  sub _get_logger {  sub _get_logger {
310          my $self = shift;          my $self = shift;
311    
         $self->{'_logger_ok'} ||= $self->_init_logger;  
   
312          my $name = (caller(1))[3] || caller;          my $name = (caller(1))[3] || caller;
313          return get_logger($name);  
314            # make name full
315            my $f = '';
316            if ( $self->log_debug ) {
317                    foreach ( 0 .. 5 ) {
318                            my $s = (caller($_))[3];
319                            $f .= "#### $_ >> $s\n" if ($s);
320                    }
321            }
322    
323            $self->{'_logger_'} ||= $self->_init_logger;
324    
325            my $log = get_logger( $name );
326            warn "# get_logger( $name ) level ", $log->level, "\n$f" if ($self->log_debug && !defined($_logger_seen->{$name}));
327            $_logger_seen->{$name}++;
328            return $log;
329  }  }
330    
331    
332    =head2 _log
333    
334    Quick cludge to make logging object available to scripts which
335    use webpac line this:
336    
337      my $log = _new WebPAC::Common()->_get_logger();
338    
339    =cut
340    
341    sub _new {
342            my $class = shift;
343            my $self = {@_};
344            bless($self, $class);
345    
346            $self ? return $self : return undef;
347    }
348    
349  =head1 LOGGING  =head1 LOGGING
350    
351  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 378  B<This is different from normal Log4perl Line 360  B<This is different from normal Log4perl
360  also use method names, and not only classes (which are just few)  also use method names, and not only classes (which are just few)
361  to filter logging.  to filter logging.
362    
363    =cut
364    
365    1;
Legend:
Removed from v.10  
changed lines
  Added in v.942
  ViewVC Help
Powered by ViewVC 1.1.26