/[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 7 by dpavlin, Sat Jul 16 16:00:19 2005 UTC revision 254 by dpavlin, Fri Dec 16 01:04:14 2005 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.02
19    
20  =cut  =cut
21    
22  our $VERSION = '0.01';  our $VERSION = '0.02';
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.  
   
  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);  
32    
33  This function B<does not> perform parsing of format to inteligenty skip  Draw progress bar on STDERR.
 delimiters before fields which aren't used.  
34    
35  This method will automatically decode UTF-8 string to local code page   $webpac->progress_bar($current, $max);
 if needed.  
36    
37  =cut  =cut
38    
39  sub fill_in {  sub progress_bar {
40          my $self = shift;          my $self = shift;
41    
42            my ($curr,$max) = @_;
43    
44          my $log = $self->_get_logger();          my $log = $self->_get_logger();
45    
46          my $rec = shift || $log->logconfess("need data record");          $log->logconfess("no current value!") if (! $curr);
47          my $format = shift || $log->logconfess("need format to parse");          $log->logconfess("no maximum value!") if (! $max);
48          # iteration (for repeatable fields)  
49          my $i = shift || 0;          if ($curr > $max) {
50                    $max = $curr;
51                    $log->debug("overflow to $curr");
52            }
53    
54          $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));          $self->{'last_pcnt'} ||= 1;
55            $self->{'start_t'} ||= time();
56    
57          # FIXME remove for speedup?          my $p = int($curr * 100 / $max) || 1;
         $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);  
58    
59          if (utf8::is_utf8($format)) {          # reset on re-run
60                  $format = $self->_x($format);          if ($p < $self->{'last_pcnt'}) {
61                    $self->{'last_pcnt'} = $p;
62                    $self->{'start_t'} = time();
63          }          }
64    
65          my $found = 0;          if ($p != $self->{'last_pcnt'}) {
66    
67          my $eval_code;                  my $t = time();
68          # remove eval{...} from beginning                  my $rate = ($curr / ($t - $self->{'start_t'} || 1));
69          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);                  my $eta = ($max-$curr) / ($rate || 1);
70                    printf STDERR ("%5d [%-38s] %-5d %0.1f/s %s\r",$curr,"=" x ($p/3)."$p%>", $max, $rate, $self->fmt_time($eta));
71          my $filter_name;                  $self->{'last_pcnt'} = $p;
72          # remove filter{...} from beginning                  $self->{'last_curr'} = $curr;
         $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;  
73          }          }
74            print STDERR "\n" if ($p == 100);
75  }  }
76    
77    =head2 fmt_time
78    
79  =head2 get_data  Format time (in seconds) for display.
   
 Returns value from record.  
   
  my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);  
80    
81  Arguments are:   print $webpac->fmt_time(time());
 record reference C<$rec>,  
 field C<$f>,  
 optional subfiled C<$sf>,  
 index for repeatable values C<$i>.  
82    
83  Optinal variable C<$found> will be incremeted if there  This method is called by L<progress_bar> to display remaining time.
 is field.  
   
 Returns value or empty string.  
84    
85  =cut  =cut
86    
87  sub get_data {  sub fmt_time {
88          my $self = shift;          my $self = shift;
89    
90          my ($rec,$f,$sf,$i,$found) = @_;          my $t = shift || 0;
91            my $out = "";
92    
93          if ($$rec->{$f}) {          my ($ss,$mm,$hh) = gmtime($t);
94                  return '' if (! $$rec->{$f}->[$i]);          $out .= "${hh}h" if ($hh);
95                  no strict 'refs';          $out .= sprintf("%02d:%02d", $mm,$ss);
96                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {          $out .= "  " if ($hh == 0);
97                          $$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 '';  
         }  
98  }  }
99    
100    #
101    #
102    #
103    
104  =head1 INTERNAL METHODS  =head1 INTERNAL METHODS
105    
# Line 196  sub _eval { Line 132  sub _eval {
132          return $ret || undef;          return $ret || undef;
133  }  }
134    
 =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'");  
 }  
   
135  =head2 _init_logger  =head2 _init_logger
136    
137  This function will init C<Log::Log4perl> using provided configuration file.  This function will init C<Log::Log4perl> using provided configuration file.
# Line 242  This function will init C<Log::Log4perl> Line 139  This function will init C<Log::Log4perl>
139    $webpac->_init_logger('/path/to/log.conf');    $webpac->_init_logger('/path/to/log.conf');
140    
141  If no path to configuration file is given, dummy empty configuration  If no path to configuration file is given, dummy empty configuration
142  will be create.  will be created. If any mode which inherits from this one is called
143    with C<debug> flag, it will turn logging to debug level.
144    
145    This function will also read C<log_conf> value from current object and try
146    to read that as configuration file if it exists, if it doesn't it will
147    fallback to default C<conf/log.conf>.
148    
149    You can disable all logging by adding C<no_log> to constructor of WebPAC
150    object. Object in C<Test::Exception> class will disable logging
151    automatically.
152    
153  =cut  =cut
154    
155  sub _init_logger {  sub _init_logger {
156          my $self = shift;          my $self = shift;
157          my $file = shift;          my $file = shift;
158          if ($file) {          $file ||= $self->{'log_conf'};
159            $file = 'conf/log.conf';
160            my $name = (caller(2))[3] || caller;
161    
162            my $conf = q( );
163            if ($self->{'no_log'}) {
164                    warn "# $name disabled logging\n" if ($log_debug);
165            } elsif ($self->{'debug'}) {
166                    $conf = << '_log4perl_';
167    
168    log4perl.rootLogger=INFO, SCREEN
169    
170    log4perl.logger.WebPAC.=DEBUG
171    
172    log4perl.appender.SCREEN=Log::Log4perl::Appender::Screen
173    log4perl.appender.SCREEN.layout=PatternLayout
174    log4perl.appender.SCREEN.layout.ConversionPattern=%d %p> %F{1}:%L %M - %m%n
175    
176    _log4perl_
177                    warn "# $name is using debug logger\n" if ($log_debug);
178            } elsif ($name =~ m/Test::Exception/o) {
179                    warn "# disabled logging for Text::Exception\n" if ($log_debug);
180            } elsif (-e $file) {
181                    warn "# $name is using $file logger\n" if ($log_debug);
182                  Log::Log4perl->init($file);                  Log::Log4perl->init($file);
183                    return 1;
184          } else {          } else {
185                  my $conf = q( );                  warn "# $name is using null logger\n" if ($log_debug);
                 Log::Log4perl->init( \$conf );  
186          }          }
187            Log::Log4perl->init( \$conf );
188    
189            return 1;
190  }  }
191    
192    
# Line 270  method Line 202  method
202  sub _get_logger {  sub _get_logger {
203          my $self = shift;          my $self = shift;
204    
205          $self->{'_logger_ok'} ||= $self->_init_logger;          my $name = (caller(2))[3] || caller;
206            $self->{'_logger_'} ||= $self->_init_logger;
207    
208            warn "# get_logger( $name )\n" if ($log_debug);
209    
         my $name = (caller(1))[3] || caller;  
210          return get_logger($name);          return get_logger($name);
211  }  }
212    
213    
214    =head2 _log
215    
216    Quick cludge to make logging object available to scripts which
217    use webpac line this:
218    
219      my $log = _new WebPAC::Common()->_get_logger();
220    
221    =cut
222    
223    sub _new {
224            my $class = shift;
225            my $self = {@_};
226            bless($self, $class);
227    
228            $self ? return $self : return undef;
229    }
230    
231  =head1 LOGGING  =head1 LOGGING
232    
233  Logging in WebPAC is performed by L<Log::Log4perl> with config file  Logging in WebPAC is performed by L<Log::Log4perl> with config file
Legend:
Removed from v.7  
changed lines
  Added in v.254
  ViewVC Help
Powered by ViewVC 1.1.26