/[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 6 by dpavlin, Sat Jul 16 14:44:38 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';
   
 #my $LOOKUP_REGEX = '\[[^\[\]]+\]';  
 #my $LOOKUP_REGEX_SAVE = '\[([^\[\]]+)\]';  
 my $LOOKUP_REGEX = 'lookup{[^\{\}]+}';  
 my $LOOKUP_REGEX_SAVE = 'lookup{([^\{\}]+)}';  
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($_);  });
                 }, ...  
         },  
   }  
40    
41  =head1 FUNCTIONS  Options:
42    
43  =head2 fill_in  =over 20
44    
45    =item log_debug
46    
47    Generate additional debugging log on C<STDERR>
48    
49  Workhourse of all: takes record from in-memory structure of database and  =item no_log
 strings with placeholders and returns string or array of with substituted  
 values from record.  
50    
51   my $text = $webpac->fill_in($rec,'v250^a');  Disable all logging (useful for tests)
52    
53  Optional argument is ordinal number for repeatable fields. By default,  =item debug
54  it's assume to be first repeatable field (fields are perl array, so first  
55  element is 0).  Use debugging logger which dumps output only yo C<STDERR>
56  Following example will read second value from repeatable field.  
57    =back
58    
59    
60    =head1 FUNCTIONS
61    
62   my $text = $webpac->fill_in($rec,'Title: v250^a',1);  =head2 progress_bar
63    
64  This function B<does not> perform parsing of format to inteligenty skip  Draw progress bar on STDERR.
 delimiters before fields which aren't used.  
65    
66  This method will automatically decode UTF-8 string to local code page   $webpac->progress_bar($current, $max);
 if needed.  
67    
68  =cut  =cut
69    
70  sub fill_in {  sub progress_bar {
71          my $self = shift;          my $self = shift;
72    
73            my ($curr,$max) = @_;
74    
75          my $log = $self->_get_logger();          my $log = $self->_get_logger();
76    
77          my $rec = shift || $log->logconfess("need data record");          $self->{last_pcnt_t} ||= time();
78          my $format = shift || $log->logconfess("need format to parse");  
79          # iteration (for repeatable fields)          $log->logconfess("no current value!") if (! $curr);
80          my $i = shift || 0;          $log->logconfess("no maximum value!") if (! $max);
81    
82          $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));          if ($curr > $max) {
83                    $max = $curr;
84                    $log->debug("overflow to $curr");
85            }
86    
87            $self->{'last_pcnt'} ||= 1;
88            $self->{'start_t'} ||= time();
89    
90          # FIXME remove for speedup?          my $p = int($curr * 100 / $max) || 1;
         $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);  
91    
92          if (utf8::is_utf8($format)) {          # reset on re-run
93                  $format = $self->_x($format);          if ($p < $self->{'last_pcnt'}) {
94                    $self->{'last_pcnt'} = $p;
95                    $self->{'start_t'} = time();
96          }          }
97    
98          my $found = 0;          my $t = time();
99    
100          my $eval_code;          if ($p != $self->{'last_pcnt'} || ( $t - $self->{last_pcnt_t} ) > 2 ) {
101          # remove eval{...} from beginning  
102          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);                  my $rate = ($curr / ($t - $self->{'start_t'} || 1));
103                    my $eta = ($max-$curr) / ($rate || 1);
104          my $filter_name;                  printf STDERR ("%5d [%-38s] %-5d %0.1f/s %s\r",$curr,"=" x ($p/3)."$p%>", $max, $rate, $self->fmt_time($eta));
105          # remove filter{...} from beginning                  $self->{'last_pcnt'} = $p;
106          $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);                  $self->{'last_curr'} = $curr;
107                    $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 ($format =~ /$LOOKUP_REGEX/o) {  
                         $log->debug("format '$format' has lookup");  
                         return $self->lookup($format);  
                 } else {  
                         return $format;  
                 }  
         } else {  
                 return;  
108          }          }
109            print STDERR "\n" if ($p == 100);
110  }  }
111    
112    =head2 fmt_time
113    
114    Format time (in seconds) for display.
115    
116  =head2 get_data   print $webpac->fmt_time(time());
117    
118  Returns value from record.  This method is called by L<progress_bar> to display remaining time.
119    
120   my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);  =cut
121    
122    sub fmt_time {
123            my $self = shift;
124    
125  Arguments are:          my $t = shift || 0;
126  record reference C<$rec>,          my $out = "";
 field C<$f>,  
 optional subfiled C<$sf>,  
 index for repeatable values C<$i>.  
127    
128  Optinal variable C<$found> will be incremeted if there          my ($ss,$mm,$hh) = gmtime($t);
129  is field.          $out .= "${hh}h" if ($hh);
130            $out .= sprintf("%02d:%02d", $mm,$ss);
131            $out .= "  " if ($hh == 0);
132            return $out;
133    }
134    
135    =head2 fill_in
136    
137  Returns value or empty string.  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  =cut
144    
145  sub get_data {  sub fill_in {
146          my $self = shift;          my $self = shift;
147    
148          my ($rec,$f,$sf,$i,$found) = @_;          my $format = shift || die "no format?";
149            my $d = {@_};
150    
151          if ($$rec->{$f}) {          foreach my $n ( keys %$d ) {
152                  return '' if (! $$rec->{$f}->[$i]);                  $format =~ s/\$\Q$n\E/$d->{$n}/gs;
153                  no strict 'refs';          }
154                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {  
155                          $$found++ if (defined($$found));          die "unknown variables in '$format' input data = ", dump( $d ) if ( $format =~ m/\$\w+/ );
156                          return $$rec->{$f}->[$i]->{$sf};  
157                  } elsif ($$rec->{$f}->[$i]) {          return $format;
158                          $$found++ if (defined($$found));  }
159                          # it still might have subfield, just  
160                          # not specified, so we'll dump all  #
161                          if ($$rec->{$f}->[$i] =~ /HASH/o) {  #
162                                  my $out;  #
163                                  foreach my $k (keys %{$$rec->{$f}->[$i]}) {  
164                                          $out .= $$rec->{$f}->[$i]->{$k}." ";  =head2 var_path
165                                  }  
166                                  return $out;    my $path = $self->var_path('data_dir', 'data_file', ... );
167                          } else {  
168                                  return $$rec->{$f}->[$i];  =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 {          } else {
194                  return '';                  $error->() if ref($error) eq 'CODE';
195          }          }
196            return @result;
197  }  }
198    
199    
# Line 202  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 248  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 273  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 297  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.6  
changed lines
  Added in v.924
  ViewVC Help
Powered by ViewVC 1.1.26