/[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 924 by dpavlin, Wed Oct 31 00:26:45 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    
15    use base qw/Class::Accessor/;
16    __PACKAGE__->mk_accessors( qw/log_debug no_log debug/ );
17    
18  =head1 NAME  =head1 NAME
19    
# Line 11  WebPAC::Common - internal methods called Line 21  WebPAC::Common - internal methods called
21    
22  =head1 VERSION  =head1 VERSION
23    
24  Version 0.01  Version 0.05
25    
26  =cut  =cut
27    
28  our $VERSION = '0.01';  our $VERSION = '0.05';
29    
30  =head1 SYNOPSYS  =head1 SYNOPSYS
31    
32  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
33  specific modules.  specific modules.
34    
35   my $webpac = new WebPAC::Common(  my $o = WebPAC::Common->new({
36          filter => {          log_debug => 1,
37                  'filter_name_1' => sub {          no_log => 1,
38                          # filter code          debug => 1,
39                          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;  
         }  
 }  
   
40    
41  =head2 get_data  Options:
42    
43  Returns value from record.  =over 20
44    
45   my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);  =item log_debug
46    
47  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>.  
48    
49  Optinal variable C<$found> will be incremeted if there  =item no_log
 is field.  
50    
51  Returns value or empty string.  Disable all logging (useful for tests)
52    
53  =cut  =item debug
54    
55  sub get_data {  Use debugging logger which dumps output only yo C<STDERR>
         my $self = shift;  
56    
57          my ($rec,$f,$sf,$i,$found) = @_;  =back
58    
         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 '';  
         }  
 }  
59    
60    =head1 FUNCTIONS
61    
62  =head2 progress_bar  =head2 progress_bar
63    
# Line 180  sub progress_bar { Line 74  sub progress_bar {
74    
75          my $log = $self->_get_logger();          my $log = $self->_get_logger();
76    
77            $self->{last_pcnt_t} ||= time();
78    
79          $log->logconfess("no current value!") if (! $curr);          $log->logconfess("no current value!") if (! $curr);
80          $log->logconfess("no maximum value!") if (! $max);          $log->logconfess("no maximum value!") if (! $max);
81    
# Line 199  sub progress_bar { Line 95  sub progress_bar {
95                  $self->{'start_t'} = time();                  $self->{'start_t'} = time();
96          }          }
97    
98          if ($p != $self->{'last_pcnt'}) {          my $t = time();
99    
100            if ($p != $self->{'last_pcnt'} || ( $t - $self->{last_pcnt_t} ) > 2 ) {
101    
                 my $t = time();  
102                  my $rate = ($curr / ($t - $self->{'start_t'} || 1));                  my $rate = ($curr / ($t - $self->{'start_t'} || 1));
103                  my $eta = ($max-$curr) / ($rate || 1);                  my $eta = ($max-$curr) / ($rate || 1);
104                  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));
105                  $self->{'last_pcnt'} = $p;                  $self->{'last_pcnt'} = $p;
106                  $self->{'last_curr'} = $curr;                  $self->{'last_curr'} = $curr;
107                    $self->{last_pcnt_t} = $t;
108          }          }
109          print STDERR "\n" if ($p == 100);          print STDERR "\n" if ($p == 100);
110  }  }
# Line 234  sub fmt_time { Line 132  sub fmt_time {
132          return $out;          return $out;
133  }  }
134    
135    =head2 fill_in
136    
137    Fill in variable names by values
138    
139      print $webpac->fill_in( 'foo = $foo bar = $bar',
140            foo => 42, bar => 11,
141      );
142    
143    =cut
144    
145    sub fill_in {
146            my $self = shift;
147    
148            my $format = shift || die "no format?";
149            my $d = {@_};
150    
151            foreach my $n ( keys %$d ) {
152                    $format =~ s/\$\Q$n\E/$d->{$n}/gs;
153            }
154    
155            die "unknown variables in '$format' input data = ", dump( $d ) if ( $format =~ m/\$\w+/ );
156    
157            return $format;
158    }
159    
160  #  #
161  #  #
162  #  #
163    
164    =head2 var_path
165    
166      my $path = $self->var_path('data_dir', 'data_file', ... );
167    
168    =cut
169    
170    sub var_path {
171            my $self = shift;
172    
173            return File::Spec->catfile('var', @_);
174    }
175    
176    =head1 EXPORTED NETHODS
177    
178    =head2 force_array
179    
180      my @array = force_array( $ref, sub {
181            warn "reference is undefined!";
182      });
183    
184    =cut
185    
186    sub force_array {
187            my ( $what, $error ) = @_;
188            my @result;
189            if ( ref( $what ) eq 'ARRAY' ) {
190                    @result = @{ $what };
191            } elsif ( defined $what ) {
192                    @result =  ( $what );
193            } else {
194                    $error->() if ref($error) eq 'CODE';
195            }
196            return @result;
197    }
198    
199    
200  =head1 INTERNAL METHODS  =head1 INTERNAL METHODS
201    
202  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 228  sub _eval {
228          return $ret || undef;          return $ret || undef;
229  }  }
230    
 =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'");  
 }  
   
231  =head2 _init_logger  =head2 _init_logger
232    
233  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 235  This function will init C<Log::Log4perl>
235    $webpac->_init_logger('/path/to/log.conf');    $webpac->_init_logger('/path/to/log.conf');
236    
237  If no path to configuration file is given, dummy empty configuration  If no path to configuration file is given, dummy empty configuration
238  will be create.  will be created. If any mode which inherits from this one is called
239    with C<debug> flag, it will turn logging to debug level.
240    
241    This function will also read C<log_conf> value from current object and try
242    to read that as configuration file if it exists, if it doesn't it will
243    fallback to default C<conf/log.conf>.
244    
245    You can disable all logging by adding C<no_log> to constructor of WebPAC
246    object. Object in C<Test::Exception> class will disable logging
247    automatically.
248    
249  =cut  =cut
250    
251  sub _init_logger {  sub _init_logger {
252          my $self = shift;          my $self = shift;
253          my $file = shift;          my $file = shift;
254          if ($file) {          $file ||= $self->{'log_conf'};
255            $file = 'conf/log.conf';
256            my $name = (caller(2))[3] || caller;
257    
258            my $conf = q( );
259            if ($self->no_log) {
260                    warn "# $name disabled logging\n" if $self->log_debug;
261            } elsif ($self->debug) {
262                    $conf = << '_log4perl_';
263    
264    log4perl.rootLogger=INFO, SCREEN
265    
266    log4perl.logger.WebPAC.=DEBUG
267    
268    log4perl.appender.SCREEN=Log::Log4perl::Appender::Screen
269    log4perl.appender.SCREEN.layout=PatternLayout
270    log4perl.appender.SCREEN.layout.ConversionPattern=%d %p> %F{1}:%L %M - %m%n
271    
272    _log4perl_
273                    warn "# $name is using debug logger\n" if $self->log_debug;
274            } elsif ($name =~ m/Test::Exception/o) {
275                    warn "# disabled logging for Text::Exception\n" if $self->log_debug;
276            } elsif (-e $file) {
277                    warn "# $name is using $file logger\n" if $self->log_debug;
278                  Log::Log4perl->init($file);                  Log::Log4perl->init($file);
279                    return 1;
280          } else {          } else {
281                  my $conf = q( );                  warn "# $name is using null logger\n" if $self->log_debug;
                 Log::Log4perl->init( \$conf );  
282          }          }
283            Log::Log4perl->init( \$conf );
284    
285            return 1;
286  }  }
287    
288    
# Line 340  method Line 295  method
295    
296  =cut  =cut
297    
298    my $_logger_seen;
299    
300  sub _get_logger {  sub _get_logger {
301          my $self = shift;          my $self = shift;
302    
         $self->{'_logger_ok'} ||= $self->_init_logger;  
   
303          my $name = (caller(1))[3] || caller;          my $name = (caller(1))[3] || caller;
304          return get_logger($name);  
305            # make name full
306            my $f = '';
307            if ( $self->log_debug ) {
308                    foreach ( 0 .. 5 ) {
309                            my $s = (caller($_))[3];
310                            $f .= "#### $_ >> $s\n" if ($s);
311                    }
312            }
313    
314            $self->{'_logger_'} ||= $self->_init_logger;
315    
316            my $log = get_logger( $name );
317            warn "# get_logger( $name ) level ", $log->level, "\n$f" if ($self->log_debug && !defined($_logger_seen->{$name}));
318            $_logger_seen->{$name}++;
319            return $log;
320  }  }
321    
322    
323    =head2 _log
324    
325    Quick cludge to make logging object available to scripts which
326    use webpac line this:
327    
328      my $log = _new WebPAC::Common()->_get_logger();
329    
330    =cut
331    
332    sub _new {
333            my $class = shift;
334            my $self = {@_};
335            bless($self, $class);
336    
337            $self ? return $self : return undef;
338    }
339    
340  =head1 LOGGING  =head1 LOGGING
341    
342  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 351  B<This is different from normal Log4perl
351  also use method names, and not only classes (which are just few)  also use method names, and not only classes (which are just few)
352  to filter logging.  to filter logging.
353    
354    =cut
355    
356    1;
Legend:
Removed from v.9  
changed lines
  Added in v.924
  ViewVC Help
Powered by ViewVC 1.1.26