/[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 254 by dpavlin, Fri Dec 16 01:04:14 2005 UTC revision 887 by dpavlin, Mon Sep 3 15:26:46 2007 UTC
# Line 5  use strict; Line 5  use strict;
5    
6  use Log::Log4perl qw/get_logger :levels/;  use Log::Log4perl qw/get_logger :levels/;
7  use Time::HiRes qw/time/;  use Time::HiRes qw/time/;
8    use Data::Dump qw/dump/;
9    use File::Spec;
10    
11  # If ture, enable logging debug  use base qw/Class::Accessor/;
12  my $log_debug = 0;  __PACKAGE__->mk_accessors( qw/log_debug no_log debug/ );
13    
14  =head1 NAME  =head1 NAME
15    
# Line 15  WebPAC::Common - internal methods called Line 17  WebPAC::Common - internal methods called
17    
18  =head1 VERSION  =head1 VERSION
19    
20  Version 0.02  Version 0.05
21    
22  =cut  =cut
23    
24  our $VERSION = '0.02';  our $VERSION = '0.05';
25    
26  =head1 SYNOPSYS  =head1 SYNOPSYS
27    
28  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
29  specific modules.  specific modules.
30    
31    my $o = WebPAC::Common->new({
32            log_debug => 1,
33            no_log => 1,
34            debug => 1,
35    });
36    
37    Options:
38    
39    =over 20
40    
41    =item log_debug
42    
43    Generate additional debugging log on C<STDERR>
44    
45    =item no_log
46    
47    Disable all logging (useful for tests)
48    
49    =item debug
50    
51    Use debugging logger which dumps output only yo C<STDERR>
52    
53    =back
54    
55    
56  =head1 FUNCTIONS  =head1 FUNCTIONS
57    
58  =head2 progress_bar  =head2 progress_bar
# Line 43  sub progress_bar { Line 70  sub progress_bar {
70    
71          my $log = $self->_get_logger();          my $log = $self->_get_logger();
72    
73            $self->{last_pcnt_t} ||= time();
74    
75          $log->logconfess("no current value!") if (! $curr);          $log->logconfess("no current value!") if (! $curr);
76          $log->logconfess("no maximum value!") if (! $max);          $log->logconfess("no maximum value!") if (! $max);
77    
# Line 62  sub progress_bar { Line 91  sub progress_bar {
91                  $self->{'start_t'} = time();                  $self->{'start_t'} = time();
92          }          }
93    
94          if ($p != $self->{'last_pcnt'}) {          my $t = time();
95    
96            if ($p != $self->{'last_pcnt'} || ( $t - $self->{last_pcnt_t} ) > 2 ) {
97    
                 my $t = time();  
98                  my $rate = ($curr / ($t - $self->{'start_t'} || 1));                  my $rate = ($curr / ($t - $self->{'start_t'} || 1));
99                  my $eta = ($max-$curr) / ($rate || 1);                  my $eta = ($max-$curr) / ($rate || 1);
100                  printf STDERR ("%5d [%-38s] %-5d %0.1f/s %s\r",$curr,"=" x ($p/3)."$p%>", $max, $rate, $self->fmt_time($eta));                  printf STDERR ("%5d [%-38s] %-5d %0.1f/s %s\r",$curr,"=" x ($p/3)."$p%>", $max, $rate, $self->fmt_time($eta));
101                  $self->{'last_pcnt'} = $p;                  $self->{'last_pcnt'} = $p;
102                  $self->{'last_curr'} = $curr;                  $self->{'last_curr'} = $curr;
103                    $self->{last_pcnt_t} = $t;
104          }          }
105          print STDERR "\n" if ($p == 100);          print STDERR "\n" if ($p == 100);
106  }  }
# Line 97  sub fmt_time { Line 128  sub fmt_time {
128          return $out;          return $out;
129  }  }
130    
131    =head2 fill_in
132    
133    Fill in variable names by values
134    
135      print $webpac->fill_in( 'foo = $foo bar = $bar',
136            foo => 42, bar => 11,
137      );
138    
139    =cut
140    
141    sub fill_in {
142            my $self = shift;
143    
144            my $format = shift || die "no format?";
145            my $d = {@_};
146    
147            foreach my $n ( keys %$d ) {
148                    $format =~ s/\$\Q$n\E/$d->{$n}/gs;
149            }
150    
151            die "unknown variables in '$format' input data = ", dump( $d ) if ( $format =~ m/\$\w+/ );
152    
153            return $format;
154    }
155    
156  #  #
157  #  #
158  #  #
159    
160    =head2 var_path
161    
162      my $path = $self->var_path('data_dir', 'data_file', ... );
163    
164    =cut
165    
166    sub var_path {
167            my $self = shift;
168    
169            return File::Spec->catfile('var', @_);
170    }
171    
172    
173  =head1 INTERNAL METHODS  =head1 INTERNAL METHODS
174    
175  Here is a quick list of internal methods, mostly useful to turn debugging  Here is a quick list of internal methods, mostly useful to turn debugging
# Line 160  sub _init_logger { Line 229  sub _init_logger {
229          my $name = (caller(2))[3] || caller;          my $name = (caller(2))[3] || caller;
230    
231          my $conf = q( );          my $conf = q( );
232          if ($self->{'no_log'}) {          if ($self->no_log) {
233                  warn "# $name disabled logging\n" if ($log_debug);                  warn "# $name disabled logging\n" if $self->log_debug;
234          } elsif ($self->{'debug'}) {          } elsif ($self->debug) {
235                  $conf = << '_log4perl_';                  $conf = << '_log4perl_';
236    
237  log4perl.rootLogger=INFO, SCREEN  log4perl.rootLogger=INFO, SCREEN
# Line 174  log4perl.appender.SCREEN.layout=PatternL Line 243  log4perl.appender.SCREEN.layout=PatternL
243  log4perl.appender.SCREEN.layout.ConversionPattern=%d %p> %F{1}:%L %M - %m%n  log4perl.appender.SCREEN.layout.ConversionPattern=%d %p> %F{1}:%L %M - %m%n
244    
245  _log4perl_  _log4perl_
246                  warn "# $name is using debug logger\n" if ($log_debug);                  warn "# $name is using debug logger\n" if $self->log_debug;
247          } elsif ($name =~ m/Test::Exception/o) {          } elsif ($name =~ m/Test::Exception/o) {
248                  warn "# disabled logging for Text::Exception\n" if ($log_debug);                  warn "# disabled logging for Text::Exception\n" if $self->log_debug;
249          } elsif (-e $file) {          } elsif (-e $file) {
250                  warn "# $name is using $file logger\n" if ($log_debug);                  warn "# $name is using $file logger\n" if $self->log_debug;
251                  Log::Log4perl->init($file);                  Log::Log4perl->init($file);
252                  return 1;                  return 1;
253          } else {          } else {
254                  warn "# $name is using null logger\n" if ($log_debug);                  warn "# $name is using null logger\n" if $self->log_debug;
255          }          }
256          Log::Log4perl->init( \$conf );          Log::Log4perl->init( \$conf );
257    
# Line 199  method Line 268  method
268    
269  =cut  =cut
270    
271    my $_logger_seen;
272    
273  sub _get_logger {  sub _get_logger {
274          my $self = shift;          my $self = shift;
275    
276          my $name = (caller(2))[3] || caller;          my $name = (caller(1))[3] || caller;
         $self->{'_logger_'} ||= $self->_init_logger;  
277    
278          warn "# get_logger( $name )\n" if ($log_debug);          # make name full
279            my $f = '';
280            if ( $self->log_debug ) {
281                    foreach ( 0 .. 5 ) {
282                            my $s = (caller($_))[3];
283                            $f .= "#### $_ >> $s\n" if ($s);
284                    }
285            }
286    
287          return get_logger($name);          $self->{'_logger_'} ||= $self->_init_logger;
288    
289            my $log = get_logger( $name );
290            warn "# get_logger( $name ) level ", $log->level, "\n$f" if ($self->log_debug && !defined($_logger_seen->{$name}));
291            $_logger_seen->{$name}++;
292            return $log;
293  }  }
294    
295    
# Line 221  use webpac line this: Line 303  use webpac line this:
303  =cut  =cut
304    
305  sub _new {  sub _new {
306          my $class = shift;          my $class = shift;
307          my $self = {@_};          my $self = {@_};
308          bless($self, $class);          bless($self, $class);
309    
310          $self ? return $self : return undef;          $self ? return $self : return undef;
# Line 242  B<This is different from normal Log4perl Line 324  B<This is different from normal Log4perl
324  also use method names, and not only classes (which are just few)  also use method names, and not only classes (which are just few)
325  to filter logging.  to filter logging.
326    
327    =cut
328    
329    1;
Legend:
Removed from v.254  
changed lines
  Added in v.887
  ViewVC Help
Powered by ViewVC 1.1.26