/[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 632 by dpavlin, Wed Sep 6 17:51:07 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.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  Sort xml tags data structure accoding to C<order=""> attribute.  Format time (in seconds) for display.
80    
81     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  Convert string from UTF-8 to code page defined in C<import_xml>.  =head1 INTERNAL METHODS
105    
106   my $text = $webpac->_x('utf8 text');  Here is a quick list of internal methods, mostly useful to turn debugging
107    on them (see L<LOGGING> below for explanation).
108    
109  Default application code page is C<ISO-8859-2>. You will probably want to  =cut
110  change that when creating new instance of object based on this one.  
111    =head2 _eval
112    
113    Internal function to eval code without C<strict 'subs'>.
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 116  method Line 199  method
199    
200  =cut  =cut
201    
202    my $_logger_seen;
203    
204  sub _get_logger {  sub _get_logger {
205          my $self = shift;          my $self = shift;
206    
207          $self->{'_logger_ok'} ||= $self->_init_logger;          my $name = (caller(2))[3] || caller;
208            $self->{'_logger_'} ||= $self->_init_logger;
209    
210          my $name = (caller(1))[3] || caller;          my $log = get_logger( $name );
211          return get_logger($name);          warn "# get_logger( $name ) level ", $log->level, "\n" if ($log_debug || !defined($_logger_seen->{$name}));
212            $_logger_seen->{$name}++;
213            return $log;
214  }  }
215    
216    
217    =head2 _log
218    
219    Quick cludge to make logging object available to scripts which
220    use webpac line this:
221    
222      my $log = _new WebPAC::Common()->_get_logger();
223    
224    =cut
225    
226    sub _new {
227            my $class = shift;
228            my $self = {@_};
229            bless($self, $class);
230    
231            $self ? return $self : return undef;
232    }
233    
234  =head1 LOGGING  =head1 LOGGING
235    
236  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 140  B<This is different from normal Log4perl Line 245  B<This is different from normal Log4perl
245  also use method names, and not only classes (which are just few)  also use method names, and not only classes (which are just few)
246  to filter logging.  to filter logging.
247    
248    =cut
249    
250    1;
Legend:
Removed from v.3  
changed lines
  Added in v.632
  ViewVC Help
Powered by ViewVC 1.1.26