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