/[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 9 by dpavlin, Sat Jul 16 17:14:43 2005 UTC revision 887 by dpavlin, Mon Sep 3 15:26:46 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    use File::Spec;
10    
11    use base qw/Class::Accessor/;
12    __PACKAGE__->mk_accessors( qw/log_debug no_log debug/ );
13    
14  =head1 NAME  =head1 NAME
15    
# Line 11  WebPAC::Common - internal methods called Line 17  WebPAC::Common - internal methods called
17    
18  =head1 VERSION  =head1 VERSION
19    
20  Version 0.01  Version 0.05
21    
22  =cut  =cut
23    
24  our $VERSION = '0.01';  our $VERSION = '0.05';
25    
26  =head1 SYNOPSYS  =head1 SYNOPSYS
27    
28  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
29  specific modules.  specific modules.
30    
31   my $webpac = new WebPAC::Common(  my $o = WebPAC::Common->new({
32          filter => {          log_debug => 1,
33                  'filter_name_1' => sub {          no_log => 1,
34                          # filter code          debug => 1,
35                          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;  
         }  
 }  
   
36    
37  =head2 get_data  Options:
38    
39  Returns value from record.  =over 20
40    
41   my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);  =item log_debug
42    
43  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>.  
44    
45  Optinal variable C<$found> will be incremeted if there  =item no_log
 is field.  
46    
47  Returns value or empty string.  Disable all logging (useful for tests)
48    
49  =cut  =item debug
50    
51  sub get_data {  Use debugging logger which dumps output only yo C<STDERR>
         my $self = shift;  
52    
53          my ($rec,$f,$sf,$i,$found) = @_;  =back
54    
         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 '';  
         }  
 }  
55    
56    =head1 FUNCTIONS
57    
58  =head2 progress_bar  =head2 progress_bar
59    
# Line 180  sub progress_bar { Line 70  sub progress_bar {
70    
71          my $log = $self->_get_logger();          my $log = $self->_get_logger();
72    
73            $self->{last_pcnt_t} ||= time();
74    
75          $log->logconfess("no current value!") if (! $curr);          $log->logconfess("no current value!") if (! $curr);
76          $log->logconfess("no maximum value!") if (! $max);          $log->logconfess("no maximum value!") if (! $max);
77    
# Line 199  sub progress_bar { Line 91  sub progress_bar {
91                  $self->{'start_t'} = time();                  $self->{'start_t'} = time();
92          }          }
93    
94          if ($p != $self->{'last_pcnt'}) {          my $t = time();
95    
96            if ($p != $self->{'last_pcnt'} || ( $t - $self->{last_pcnt_t} ) > 2 ) {
97    
                 my $t = time();  
98                  my $rate = ($curr / ($t - $self->{'start_t'} || 1));                  my $rate = ($curr / ($t - $self->{'start_t'} || 1));
99                  my $eta = ($max-$curr) / ($rate || 1);                  my $eta = ($max-$curr) / ($rate || 1);
100                  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));
101                  $self->{'last_pcnt'} = $p;                  $self->{'last_pcnt'} = $p;
102                  $self->{'last_curr'} = $curr;                  $self->{'last_curr'} = $curr;
103                    $self->{last_pcnt_t} = $t;
104          }          }
105          print STDERR "\n" if ($p == 100);          print STDERR "\n" if ($p == 100);
106  }  }
# Line 234  sub fmt_time { Line 128  sub fmt_time {
128          return $out;          return $out;
129  }  }
130    
131    =head2 fill_in
132    
133    Fill in variable names by values
134    
135      print $webpac->fill_in( 'foo = $foo bar = $bar',
136            foo => 42, bar => 11,
137      );
138    
139    =cut
140    
141    sub fill_in {
142            my $self = shift;
143    
144            my $format = shift || die "no format?";
145            my $d = {@_};
146    
147            foreach my $n ( keys %$d ) {
148                    $format =~ s/\$\Q$n\E/$d->{$n}/gs;
149            }
150    
151            die "unknown variables in '$format' input data = ", dump( $d ) if ( $format =~ m/\$\w+/ );
152    
153            return $format;
154    }
155    
156  #  #
157  #  #
158  #  #
159    
160    =head2 var_path
161    
162      my $path = $self->var_path('data_dir', 'data_file', ... );
163    
164    =cut
165    
166    sub var_path {
167            my $self = shift;
168    
169            return File::Spec->catfile('var', @_);
170    }
171    
172    
173  =head1 INTERNAL METHODS  =head1 INTERNAL METHODS
174    
175  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 201  sub _eval {
201          return $ret || undef;          return $ret || undef;
202  }  }
203    
 =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'");  
 }  
   
204  =head2 _init_logger  =head2 _init_logger
205    
206  This function will init C<Log::Log4perl> using provided configuration file.  This function will init C<Log::Log4perl> using provided configuration file.
# Line 315  This function will init C<Log::Log4perl> Line 208  This function will init C<Log::Log4perl>
208    $webpac->_init_logger('/path/to/log.conf');    $webpac->_init_logger('/path/to/log.conf');
209    
210  If no path to configuration file is given, dummy empty configuration  If no path to configuration file is given, dummy empty configuration
211  will be create.  will be created. If any mode which inherits from this one is called
212    with C<debug> flag, it will turn logging to debug level.
213    
214    This function will also read C<log_conf> value from current object and try
215    to read that as configuration file if it exists, if it doesn't it will
216    fallback to default C<conf/log.conf>.
217    
218    You can disable all logging by adding C<no_log> to constructor of WebPAC
219    object. Object in C<Test::Exception> class will disable logging
220    automatically.
221    
222  =cut  =cut
223    
224  sub _init_logger {  sub _init_logger {
225          my $self = shift;          my $self = shift;
226          my $file = shift;          my $file = shift;
227          if ($file) {          $file ||= $self->{'log_conf'};
228            $file = 'conf/log.conf';
229            my $name = (caller(2))[3] || caller;
230    
231            my $conf = q( );
232            if ($self->no_log) {
233                    warn "# $name disabled logging\n" if $self->log_debug;
234            } elsif ($self->debug) {
235                    $conf = << '_log4perl_';
236    
237    log4perl.rootLogger=INFO, SCREEN
238    
239    log4perl.logger.WebPAC.=DEBUG
240    
241    log4perl.appender.SCREEN=Log::Log4perl::Appender::Screen
242    log4perl.appender.SCREEN.layout=PatternLayout
243    log4perl.appender.SCREEN.layout.ConversionPattern=%d %p> %F{1}:%L %M - %m%n
244    
245    _log4perl_
246                    warn "# $name is using debug logger\n" if $self->log_debug;
247            } elsif ($name =~ m/Test::Exception/o) {
248                    warn "# disabled logging for Text::Exception\n" if $self->log_debug;
249            } elsif (-e $file) {
250                    warn "# $name is using $file logger\n" if $self->log_debug;
251                  Log::Log4perl->init($file);                  Log::Log4perl->init($file);
252                    return 1;
253          } else {          } else {
254                  my $conf = q( );                  warn "# $name is using null logger\n" if $self->log_debug;
                 Log::Log4perl->init( \$conf );  
255          }          }
256            Log::Log4perl->init( \$conf );
257    
258            return 1;
259  }  }
260    
261    
# Line 340  method Line 268  method
268    
269  =cut  =cut
270    
271    my $_logger_seen;
272    
273  sub _get_logger {  sub _get_logger {
274          my $self = shift;          my $self = shift;
275    
         $self->{'_logger_ok'} ||= $self->_init_logger;  
   
276          my $name = (caller(1))[3] || caller;          my $name = (caller(1))[3] || caller;
277          return get_logger($name);  
278            # make name full
279            my $f = '';
280            if ( $self->log_debug ) {
281                    foreach ( 0 .. 5 ) {
282                            my $s = (caller($_))[3];
283                            $f .= "#### $_ >> $s\n" if ($s);
284                    }
285            }
286    
287            $self->{'_logger_'} ||= $self->_init_logger;
288    
289            my $log = get_logger( $name );
290            warn "# get_logger( $name ) level ", $log->level, "\n$f" if ($self->log_debug && !defined($_logger_seen->{$name}));
291            $_logger_seen->{$name}++;
292            return $log;
293  }  }
294    
295    
296    =head2 _log
297    
298    Quick cludge to make logging object available to scripts which
299    use webpac line this:
300    
301      my $log = _new WebPAC::Common()->_get_logger();
302    
303    =cut
304    
305    sub _new {
306            my $class = shift;
307            my $self = {@_};
308            bless($self, $class);
309    
310            $self ? return $self : return undef;
311    }
312    
313  =head1 LOGGING  =head1 LOGGING
314    
315  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 364  B<This is different from normal Log4perl Line 324  B<This is different from normal Log4perl
324  also use method names, and not only classes (which are just few)  also use method names, and not only classes (which are just few)
325  to filter logging.  to filter logging.
326    
327    =cut
328    
329    1;
Legend:
Removed from v.9  
changed lines
  Added in v.887
  ViewVC Help
Powered by ViewVC 1.1.26