/[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 3 by dpavlin, Sat Jul 16 11:07:38 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 INTERNAL METHODS  =head1 SYNOPSYS
25    
26  Here is a quick list of internal methods, mostly useful to turn debugging  This module defines common functions, and is used as base for other, more
27  on them (see L<LOGGING> below for explanation).  specific modules.
28    
29  =cut  =head1 FUNCTIONS
30    
31  =head2 _eval  =head2 progress_bar
32    
33  Internal function to eval code without C<strict 'subs'>.  Draw progress bar on STDERR.
34    
35     $webpac->progress_bar($current, $max);
36    
37  =cut  =cut
38    
39  sub _eval {  sub progress_bar {
40          my $self = shift;          my $self = shift;
41    
42          my $code = shift || return;          my ($curr,$max) = @_;
43    
44          my $log = $self->_get_logger();          my $log = $self->_get_logger();
45    
46          no strict 'subs';          $log->logconfess("no current value!") if (! $curr);
47          my $ret = eval $code;          $log->logconfess("no maximum value!") if (! $max);
48          if ($@) {  
49                  $log->error("problem with eval code [$code]: $@");          if ($curr > $max) {
50                    $max = $curr;
51                    $log->debug("overflow to $curr");
52          }          }
53    
54          $log->debug("eval: ",$code," [",$ret,"]");          $self->{'last_pcnt'} ||= 1;
55            $self->{'start_t'} ||= time();
56    
57          return $ret || undef;          my $p = int($curr * 100 / $max) || 1;
58    
59            # reset on re-run
60            if ($p < $self->{'last_pcnt'}) {
61                    $self->{'last_pcnt'} = $p;
62                    $self->{'start_t'} = time();
63            }
64    
65            if ($p != $self->{'last_pcnt'}) {
66    
67                    my $t = time();
68                    my $rate = ($curr / ($t - $self->{'start_t'} || 1));
69                    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                    $self->{'last_pcnt'} = $p;
72                    $self->{'last_curr'} = $curr;
73            }
74            print STDERR "\n" if ($p == 100);
75  }  }
76    
77  =head2 _sort_by_order  =head2 fmt_time
78    
79    Format time (in seconds) for display.
80    
81  Sort xml tags data structure accoding to C<order=""> attribute.   print $webpac->fmt_time(time());
82    
83    This method is called by L<progress_bar> to display remaining time.
84    
85  =cut  =cut
86    
87  sub _sort_by_order {  sub fmt_time {
88          my $self = shift;          my $self = shift;
89    
90          my $va = $self->{'import_xml'}->{'indexer'}->{$a}->{'order'} ||          my $t = shift || 0;
91                  $self->{'import_xml'}->{'indexer'}->{$a};          my $out = "";
         my $vb = $self->{'import_xml'}->{'indexer'}->{$b}->{'order'} ||  
                 $self->{'import_xml'}->{'indexer'}->{$b};  
92    
93          return $va <=> $vb;          my ($ss,$mm,$hh) = gmtime($t);
94            $out .= "${hh}h" if ($hh);
95            $out .= sprintf("%02d:%02d", $mm,$ss);
96            $out .= "  " if ($hh == 0);
97            return $out;
98  }  }
99    
100  =head2 _x  #
101    #
102    #
103    
104    =head1 INTERNAL METHODS
105    
106    Here is a quick list of internal methods, mostly useful to turn debugging
107    on them (see L<LOGGING> below for explanation).
108    
109  Convert string from UTF-8 to code page defined in C<import_xml>.  =cut
110    
111   my $text = $webpac->_x('utf8 text');  =head2 _eval
112    
113  Default application code page is C<ISO-8859-2>. You will probably want to  Internal function to eval code without C<strict 'subs'>.
 change that when creating new instance of object based on this one.  
114    
115  =cut  =cut
116    
117  sub _x {  sub _eval {
118          my $self = shift;          my $self = shift;
         my $utf8 = shift || return;  
119    
120          # create UTF-8 convertor for import_xml files          my $code = shift || return;
121          $self->{'utf2cp'} ||= Text::Iconv->new('UTF-8' ,$self->{'code_page'} || 'ISO-8859-2');  
122            my $log = $self->_get_logger();
123    
124            no strict 'subs';
125            my $ret = eval $code;
126            if ($@) {
127                    $log->error("problem with eval code [$code]: $@");
128            }
129    
130            $log->debug("eval: ",$code," [",$ret,"]");
131    
132          return $self->{'utf2cp'}->convert($utf8) ||          return $ret || undef;
                 $self->_get_logger()->logwarn("can't convert '$utf8'");  
133  }  }
134    
135  =head2 _init_logger  =head2 _init_logger
# Line 93  This function will init C<Log::Log4perl> Line 138  This function will init C<Log::Log4perl>
138    
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
142    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 119  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.3  
changed lines
  Added in v.254
  ViewVC Help
Powered by ViewVC 1.1.26