/[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 948 by dpavlin, Thu Nov 1 00:16:46 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';
   
 #my $LOOKUP_REGEX = '\[[^\[\]]+\]';  
 #my $LOOKUP_REGEX_SAVE = '\[([^\[\]]+)\]';  
 my $LOOKUP_REGEX = 'lookup{[^\{\}]+}';  
 my $LOOKUP_REGEX_SAVE = 'lookup{([^\{\}]+)}';  
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($_);  });
                 }, ...  
         },  
   }  
41    
42  =head1 FUNCTIONS  Options:
43    
44  =head2 fill_in  =over 20
45    
46    =item log_debug
47    
48    Generate additional debugging log on C<STDERR>
49    
50  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.  
51    
52   my $text = $webpac->fill_in($rec,'v250^a');  Disable all logging (useful for tests)
53    
54  Optional argument is ordinal number for repeatable fields. By default,  =item debug
 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.  
55    
56   my $text = $webpac->fill_in($rec,'Title: v250^a',1);  Use debugging logger which dumps output only yo C<STDERR>
57    
58  This function B<does not> perform parsing of format to inteligenty skip  =back
 delimiters before fields which aren't used.  
59    
60  This method will automatically decode UTF-8 string to local code page  
61  if needed.  =head1 FUNCTIONS
62    
63    =head2 progress_bar
64    
65    Draw progress bar on STDERR.
66    
67     $webpac->progress_bar($current, $max);
68    
69  =cut  =cut
70    
71  sub fill_in {  sub progress_bar {
72          my $self = shift;          my $self = shift;
73    
74            my ($curr,$max) = @_;
75    
76          my $log = $self->_get_logger();          my $log = $self->_get_logger();
77    
78          my $rec = shift || $log->logconfess("need data record");          $self->{last_pcnt_t} ||= time();
79          my $format = shift || $log->logconfess("need format to parse");  
80          # iteration (for repeatable fields)          $log->logconfess("no current value!") if (! $curr);
81          my $i = shift || 0;          $log->logconfess("no maximum value!") if (! $max);
82    
83            if ($curr > $max) {
84                    $max = $curr;
85                    $log->debug("overflow to $curr");
86            }
87    
88          $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));          $self->{'last_pcnt'} ||= 1;
89            $self->{'start_t'} ||= time();
90    
91          # FIXME remove for speedup?          my $p = int($curr * 100 / $max) || 1;
         $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);  
92    
93          if (utf8::is_utf8($format)) {          # reset on re-run
94                  $format = $self->_x($format);          if ($p < $self->{'last_pcnt'}) {
95                    $self->{'last_pcnt'} = $p;
96                    $self->{'start_t'} = time();
97          }          }
98    
99          my $found = 0;          my $t = time();
100    
101          my $eval_code;          if ($p != $self->{'last_pcnt'} || ( $t - $self->{last_pcnt_t} ) > 2 ) {
102          # remove eval{...} from beginning  
103          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);                  my $rate = ($curr / ($t - $self->{'start_t'} || 1));
104                    my $eta = ($max-$curr) / ($rate || 1);
105          my $filter_name;                  printf STDERR ("%5d [%-38s] %-5d %0.1f/s %s\r",$curr,"=" x ($p/3)."$p%>", $max, $rate, $self->fmt_time($eta));
106          # remove filter{...} from beginning                  $self->{'last_pcnt'} = $p;
107          $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);                  $self->{'last_curr'} = $curr;
108                    $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;  
109          }          }
110            print STDERR "\n" if ($p == 100);
111    }
112    
113    =head2 fmt_time
114    
115    Format time (in seconds) for display.
116    
117     print $webpac->fmt_time(time());
118    
119    This method is called by L<progress_bar> to display remaining time.
120    
121    =cut
122    
123    sub fmt_time {
124            my $self = shift;
125    
126            my $t = shift || 0;
127            my $out = "";
128    
129            my ($ss,$mm,$hh) = gmtime($t);
130            $out .= "${hh}h" if ($hh);
131            $out .= sprintf("%02d:%02d", $mm,$ss);
132            $out .= "  " if ($hh == 0);
133            return $out;
134  }  }
135    
136    =head2 fill_in
137    
138  =head2 get_data  Fill in variable names by values
139    
140  Returns value from record.    print $webpac->fill_in( 'foo = $foo bar = $bar',
141            foo => 42, bar => 11,
142      );
143    
144   my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);  =cut
145    
146  Arguments are:  sub fill_in {
147  record reference C<$rec>,          my $self = shift;
148  field C<$f>,  
149  optional subfiled C<$sf>,          my $format = shift || die "no format?";
150  index for repeatable values C<$i>.          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  Optinal variable C<$found> will be incremeted if there          return $format;
159  is field.  }
160    
161  Returns value or empty string.  #
162    #
163    #
164    
165    =head2 var_path
166    
167      my $path = $self->var_path('data_dir', 'data_file', ... );
168    
169  =cut  =cut
170    
171  sub get_data {  my $abs_path;
172    
173    sub var_path {
174          my $self = shift;          my $self = shift;
175    
176          my ($rec,$f,$sf,$i,$found) = @_;          if ( ! $abs_path ) {
177    #               $abs_path = abs_path( $0 );
178    #               $abs_path =~ s!/WebPAC/Common\.pm!!;
179                    $abs_path = '/data/webpac2';
180            }
181    
182          if ($$rec->{$f}) {          return File::Spec->catfile($abs_path, 'var', @_);
183                  return '' if (! $$rec->{$f}->[$i]);  }
184                  no strict 'refs';  
185                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {  =head1 EXPORTED NETHODS
186                          $$found++ if (defined($$found));  
187                          return $$rec->{$f}->[$i]->{$sf};  =head2 force_array
188                  } elsif ($$rec->{$f}->[$i]) {  
189                          $$found++ if (defined($$found));    my @array = force_array( $ref, sub {
190                          # it still might have subfield, just          warn "reference is undefined!";
191                          # not specified, so we'll dump all    });
192                          if ($$rec->{$f}->[$i] =~ /HASH/o) {  
193                                  my $out;  =cut
194                                  foreach my $k (keys %{$$rec->{$f}->[$i]}) {  
195                                          $out .= $$rec->{$f}->[$i]->{$k}." ";  sub force_array {
196                                  }          my ( $what, $error ) = @_;
197                                  return $out;          my @result;
198                          } else {          if ( ref( $what ) eq 'ARRAY' ) {
199                                  return $$rec->{$f}->[$i];                  @result = @{ $what };
200                          }          } elsif ( defined $what ) {
201                  }                  @result =  ( $what );
202          } else {          } else {
203                  return '';                  $error->() if ref($error) eq 'CODE';
204          }          }
205            return @result;
206  }  }
207    
208    
# Line 202  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 248  This function will init C<Log::Log4perl> Line 244  This function will init C<Log::Log4perl>
244    $webpac->_init_logger('/path/to/log.conf');    $webpac->_init_logger('/path/to/log.conf');
245    
246  If no path to configuration file is given, dummy empty configuration  If no path to configuration file is given, dummy empty configuration
247  will be create.  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.
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            $file = 'conf/log.conf';
265            my $name = (caller(2))[3] || caller;
266    
267            my $conf = q( );
268            if ($self->no_log) {
269                    warn "# $name disabled logging\n" if $self->log_debug;
270                    $Log::Log4perl::Config::CONFIG_INTEGRITY_CHECK = 0;
271            } elsif ($self->debug) {
272                    $conf = << '_log4perl_';
273    
274    log4perl.rootLogger=INFO, SCREEN
275    
276    log4perl.logger.WebPAC.=DEBUG
277    
278    log4perl.appender.SCREEN=Log::Log4perl::Appender::Screen
279    log4perl.appender.SCREEN.layout=PatternLayout
280    log4perl.appender.SCREEN.layout.ConversionPattern=%d %p> %F{1}:%L %M - %m%n
281    
282    _log4perl_
283                    warn "# $name is using debug logger\n" if $self->log_debug;
284            } elsif ($name =~ m/Test::Exception/o) {
285                    warn "# disabled logging for Text::Exception\n" if $self->log_debug;
286            } elsif (-e $file) {
287                    warn "# $name is using $file logger\n" if $self->log_debug;
288                  Log::Log4perl->init($file);                  Log::Log4perl->init($file);
289                    return 1;
290          } else {          } else {
291                  my $conf = q( );                  warn "# $name is using null logger\n" if $self->log_debug;
                 Log::Log4perl->init( \$conf );  
292          }          }
293            Log::Log4perl->init( \$conf );
294    
295            return 1;
296  }  }
297    
298    
# Line 273  method Line 305  method
305    
306  =cut  =cut
307    
308    my $_logger_seen;
309    
310  sub _get_logger {  sub _get_logger {
311          my $self = shift;          my $self = shift;
312    
         $self->{'_logger_ok'} ||= $self->_init_logger;  
   
313          my $name = (caller(1))[3] || caller;          my $name = (caller(1))[3] || caller;
314          return get_logger($name);  
315            # make name full
316            my $f = '';
317            if ( $self->log_debug ) {
318                    foreach ( 0 .. 5 ) {
319                            my $s = (caller($_))[3];
320                            $f .= "#### $_ >> $s\n" if ($s);
321                    }
322            }
323    
324            $self->{'_logger_'} ||= $self->_init_logger;
325    
326            my $log = get_logger( $name );
327            warn "# get_logger( $name ) level ", $log->level, "\n$f" if ($self->log_debug && !defined($_logger_seen->{$name}));
328            $_logger_seen->{$name}++;
329            return $log;
330  }  }
331    
332    
333    =head2 _log
334    
335    Quick cludge to make logging object available to scripts which
336    use webpac line this:
337    
338      my $log = _new WebPAC::Common()->_get_logger();
339    
340    =cut
341    
342    sub _new {
343            my $class = shift;
344            my $self = {@_};
345            bless($self, $class);
346    
347            $self ? return $self : return undef;
348    }
349    
350  =head1 LOGGING  =head1 LOGGING
351    
352  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 361  B<This is different from normal Log4perl
361  also use method names, and not only classes (which are just few)  also use method names, and not only classes (which are just few)
362  to filter logging.  to filter logging.
363    
364    =cut
365    
366    1;
Legend:
Removed from v.6  
changed lines
  Added in v.948
  ViewVC Help
Powered by ViewVC 1.1.26