/[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 763 by dpavlin, Wed Oct 25 20:53:14 2006 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    
9    # If ture, enable logging debug
10    my $log_debug = 0;
11    
12  =head1 NAME  =head1 NAME
13    
# Line 11  WebPAC::Common - internal methods called Line 15  WebPAC::Common - internal methods called
15    
16  =head1 VERSION  =head1 VERSION
17    
18  Version 0.01  Version 0.04
19    
20  =cut  =cut
21    
22  our $VERSION = '0.01';  our $VERSION = '0.04';
   
 #my $LOOKUP_REGEX = '\[[^\[\]]+\]';  
 #my $LOOKUP_REGEX_SAVE = '\[([^\[\]]+)\]';  
 my $LOOKUP_REGEX = 'lookup{[^\{\}]+}';  
 my $LOOKUP_REGEX_SAVE = 'lookup{([^\{\}]+)}';  
23    
24  =head1 SYNOPSYS  =head1 SYNOPSYS
25    
26  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
27  specific modules.  specific modules.
28    
  my $webpac = new WebPAC::Common(  
         filter => {  
                 'filter_name_1' => sub {  
                         # filter code  
                         return length($_);  
                 }, ...  
         },  
   }  
   
29  =head1 FUNCTIONS  =head1 FUNCTIONS
30    
31  =head2 fill_in  =head2 progress_bar
   
 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.  
32    
33   my $text = $webpac->fill_in($rec,'v250^a');  Draw progress bar on STDERR.
34    
35  Optional argument is ordinal number for repeatable fields. By default,   $webpac->progress_bar($current, $max);
 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.  
36    
37  =cut  =cut
38    
39  sub fill_in {  sub progress_bar {
40          my $self = shift;          my $self = shift;
41    
42          my $log = $self->_get_logger();          my ($curr,$max) = @_;
43    
44          my $rec = shift || $log->logconfess("need data record");          my $log = $self->_get_logger();
         my $format = shift || $log->logconfess("need format to parse");  
         # iteration (for repeatable fields)  
         my $i = shift || 0;  
45    
46          $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));          $self->{last_pcnt_t} ||= time();
47    
48          # FIXME remove for speedup?          $log->logconfess("no current value!") if (! $curr);
49          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("no maximum value!") if (! $max);
50    
51          if (utf8::is_utf8($format)) {          if ($curr > $max) {
52                  $format = $self->_x($format);                  $max = $curr;
53                    $log->debug("overflow to $curr");
54          }          }
55    
56          my $found = 0;          $self->{'last_pcnt'} ||= 1;
57            $self->{'start_t'} ||= time();
58    
59          my $eval_code;          my $p = int($curr * 100 / $max) || 1;
60          # remove eval{...} from beginning  
61          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          # reset on re-run
62            if ($p < $self->{'last_pcnt'}) {
63          my $filter_name;                  $self->{'last_pcnt'} = $p;
64          # remove filter{...} from beginning                  $self->{'start_t'} = time();
         $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 ($format =~ /$LOOKUP_REGEX/o) {  
                         $log->debug("format '$format' has lookup");  
                         return $self->lookup($format);  
                 } else {  
                         return $format;  
                 }  
         } else {  
                 return;  
65          }          }
 }  
66    
67            my $t = time();
68    
69  =head2 get_data          if ($p != $self->{'last_pcnt'} || ( $t - $self->{last_pcnt_t} ) > 2 ) {
70    
71  Returns value from record.                  my $rate = ($curr / ($t - $self->{'start_t'} || 1));
72                    my $eta = ($max-$curr) / ($rate || 1);
73                    printf STDERR ("%5d [%-38s] %-5d %0.1f/s %s\r",$curr,"=" x ($p/3)."$p%>", $max, $rate, $self->fmt_time($eta));
74                    $self->{'last_pcnt'} = $p;
75                    $self->{'last_curr'} = $curr;
76                    $self->{last_pcnt_t} = $t;
77            }
78            print STDERR "\n" if ($p == 100);
79    }
80    
81   my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);  =head2 fmt_time
82    
83  Arguments are:  Format time (in seconds) for display.
 record reference C<$rec>,  
 field C<$f>,  
 optional subfiled C<$sf>,  
 index for repeatable values C<$i>.  
84    
85  Optinal variable C<$found> will be incremeted if there   print $webpac->fmt_time(time());
 is field.  
86    
87  Returns value or empty string.  This method is called by L<progress_bar> to display remaining time.
88    
89  =cut  =cut
90    
91  sub get_data {  sub fmt_time {
92          my $self = shift;          my $self = shift;
93    
94          my ($rec,$f,$sf,$i,$found) = @_;          my $t = shift || 0;
95            my $out = "";
96    
97          if ($$rec->{$f}) {          my ($ss,$mm,$hh) = gmtime($t);
98                  return '' if (! $$rec->{$f}->[$i]);          $out .= "${hh}h" if ($hh);
99                  no strict 'refs';          $out .= sprintf("%02d:%02d", $mm,$ss);
100                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {          $out .= "  " if ($hh == 0);
101                          $$found++ if (defined($$found));          return $out;
                         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 '';  
         }  
102  }  }
103    
104    #
105    #
106    #
107    
108  =head1 INTERNAL METHODS  =head1 INTERNAL METHODS
109    
# Line 202  sub _eval { Line 136  sub _eval {
136          return $ret || undef;          return $ret || undef;
137  }  }
138    
 =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'");  
 }  
   
139  =head2 _init_logger  =head2 _init_logger
140    
141  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 143  This function will init C<Log::Log4perl>
143    $webpac->_init_logger('/path/to/log.conf');    $webpac->_init_logger('/path/to/log.conf');
144    
145  If no path to configuration file is given, dummy empty configuration  If no path to configuration file is given, dummy empty configuration
146  will be create.  will be created. If any mode which inherits from this one is called
147    with C<debug> flag, it will turn logging to debug level.
148    
149    This function will also read C<log_conf> value from current object and try
150    to read that as configuration file if it exists, if it doesn't it will
151    fallback to default C<conf/log.conf>.
152    
153    You can disable all logging by adding C<no_log> to constructor of WebPAC
154    object. Object in C<Test::Exception> class will disable logging
155    automatically.
156    
157  =cut  =cut
158    
159  sub _init_logger {  sub _init_logger {
160          my $self = shift;          my $self = shift;
161          my $file = shift;          my $file = shift;
162          if ($file) {          $file ||= $self->{'log_conf'};
163            $file = 'conf/log.conf';
164            my $name = (caller(2))[3] || caller;
165    
166            my $conf = q( );
167            if ($self->{'no_log'}) {
168                    warn "# $name disabled logging\n" if ($log_debug);
169            } elsif ($self->{'debug'}) {
170                    $conf = << '_log4perl_';
171    
172    log4perl.rootLogger=INFO, SCREEN
173    
174    log4perl.logger.WebPAC.=DEBUG
175    
176    log4perl.appender.SCREEN=Log::Log4perl::Appender::Screen
177    log4perl.appender.SCREEN.layout=PatternLayout
178    log4perl.appender.SCREEN.layout.ConversionPattern=%d %p> %F{1}:%L %M - %m%n
179    
180    _log4perl_
181                    warn "# $name is using debug logger\n" if ($log_debug);
182            } elsif ($name =~ m/Test::Exception/o) {
183                    warn "# disabled logging for Text::Exception\n" if ($log_debug);
184            } elsif (-e $file) {
185                    warn "# $name is using $file logger\n" if ($log_debug);
186                  Log::Log4perl->init($file);                  Log::Log4perl->init($file);
187                    return 1;
188          } else {          } else {
189                  my $conf = q( );                  warn "# $name is using null logger\n" if ($log_debug);
                 Log::Log4perl->init( \$conf );  
190          }          }
191            Log::Log4perl->init( \$conf );
192    
193            return 1;
194  }  }
195    
196    
# Line 273  method Line 203  method
203    
204  =cut  =cut
205    
206    my $_logger_seen;
207    
208  sub _get_logger {  sub _get_logger {
209          my $self = shift;          my $self = shift;
210    
         $self->{'_logger_ok'} ||= $self->_init_logger;  
   
211          my $name = (caller(1))[3] || caller;          my $name = (caller(1))[3] || caller;
212          return get_logger($name);  
213            # make name full
214            my $f = '';
215            if ($log_debug) {
216                    foreach ( 0 .. 5 ) {
217                            my $s = (caller($_))[3];
218                            $f .= "#### $_ >> $s\n" if ($s);
219                    }
220            }
221    
222            $self->{'_logger_'} ||= $self->_init_logger;
223    
224            my $log = get_logger( $name );
225            warn "# get_logger( $name ) level ", $log->level, "\n$f" if ($log_debug && !defined($_logger_seen->{$name}));
226            $_logger_seen->{$name}++;
227            return $log;
228  }  }
229    
230    
231    =head2 _log
232    
233    Quick cludge to make logging object available to scripts which
234    use webpac line this:
235    
236      my $log = _new WebPAC::Common()->_get_logger();
237    
238    =cut
239    
240    sub _new {
241            my $class = shift;
242            my $self = {@_};
243            bless($self, $class);
244    
245            $self ? return $self : return undef;
246    }
247    
248  =head1 LOGGING  =head1 LOGGING
249    
250  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 259  B<This is different from normal Log4perl
259  also use method names, and not only classes (which are just few)  also use method names, and not only classes (which are just few)
260  to filter logging.  to filter logging.
261    
262    =cut
263    
264    1;
Legend:
Removed from v.6  
changed lines
  Added in v.763
  ViewVC Help
Powered by ViewVC 1.1.26