/[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 363 by dpavlin, Sun Jan 8 20:27:06 2006 UTC revision 1068 by dpavlin, Tue Nov 27 23:45:28 2007 UTC
# Line 1  Line 1 
1  package WebPAC::Common;  package WebPAC::Common;
2    use Exporter 'import';
3    @EXPORT = qw/
4            force_array
5            dump
6    /;
7    
8  use warnings;  use warnings;
9  use strict;  use strict;
10    
11  use Log::Log4perl qw/get_logger :levels/;  use Log::Log4perl qw/get_logger :levels/;
12  use Time::HiRes qw/time/;  use Time::HiRes qw/time/;
13    use Data::Dump qw/dump/;
14    use File::Spec;
15    use Cwd qw/abs_path/;
16    
17  # If ture, enable logging debug  use base qw/Class::Accessor/;
18  my $log_debug = 0;  __PACKAGE__->mk_accessors( qw/log_debug no_log debug/ );
19    
20  =head1 NAME  =head1 NAME
21    
# Line 15  WebPAC::Common - internal methods called Line 23  WebPAC::Common - internal methods called
23    
24  =head1 VERSION  =head1 VERSION
25    
26  Version 0.02  Version 0.05
27    
28  =cut  =cut
29    
30  our $VERSION = '0.02';  our $VERSION = '0.05';
31    
32  =head1 SYNOPSYS  =head1 SYNOPSYS
33    
34  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
35  specific modules.  specific modules.
36    
37    my $o = WebPAC::Common->new({
38            log_debug => 1,
39            no_log => 1,
40            debug => 1,
41    });
42    
43    Options:
44    
45    =over 20
46    
47    =item log_debug
48    
49    Generate additional debugging log on C<STDERR>
50    
51    =item no_log
52    
53    Disable all logging (useful for tests)
54    
55    =item debug
56    
57    Use debugging logger which dumps output only yo C<STDERR>
58    
59    =back
60    
61    
62  =head1 FUNCTIONS  =head1 FUNCTIONS
63    
64  =head2 progress_bar  =head2 progress_bar
# Line 43  sub progress_bar { Line 76  sub progress_bar {
76    
77          my $log = $self->_get_logger();          my $log = $self->_get_logger();
78    
79            $self->{last_pcnt_t} ||= time();
80    
81          $log->logconfess("no current value!") if (! $curr);          $log->logconfess("no current value!") if (! $curr);
82          $log->logconfess("no maximum value!") if (! $max);          $log->logconfess("no maximum value!") if (! $max);
83    
# Line 62  sub progress_bar { Line 97  sub progress_bar {
97                  $self->{'start_t'} = time();                  $self->{'start_t'} = time();
98          }          }
99    
100          if ($p != $self->{'last_pcnt'}) {          my $t = time();
101    
102            if ($p != $self->{'last_pcnt'} || ( $t - $self->{last_pcnt_t} ) > 2 ) {
103    
                 my $t = time();  
104                  my $rate = ($curr / ($t - $self->{'start_t'} || 1));                  my $rate = ($curr / ($t - $self->{'start_t'} || 1));
105                  my $eta = ($max-$curr) / ($rate || 1);                  my $eta = ($max-$curr) / ($rate || 1);
106                  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));
107                  $self->{'last_pcnt'} = $p;                  $self->{'last_pcnt'} = $p;
108                  $self->{'last_curr'} = $curr;                  $self->{'last_curr'} = $curr;
109                    $self->{last_pcnt_t} = $t;
110          }          }
111          print STDERR "\n" if ($p == 100);          print STDERR "\n" if ($p == 100);
112  }  }
# Line 97  sub fmt_time { Line 134  sub fmt_time {
134          return $out;          return $out;
135  }  }
136    
137    =head2 fill_in
138    
139    Fill in variable names by values
140    
141      print $webpac->fill_in( 'foo = $foo bar = $bar',
142            foo => 42, bar => 11,
143      );
144    
145    =cut
146    
147    sub fill_in {
148            my $self = shift;
149    
150            my $format = shift || die "no format?";
151            my $d = {@_};
152    
153            foreach my $n ( keys %$d ) {
154                    $format =~ s/\$\Q$n\E/$d->{$n}/gs;
155            }
156    
157            die "unknown variables in '$format' input data = ", dump( $d ) if ( $format =~ m/\$\w+/ );
158    
159            return $format;
160    }
161    
162  #  #
163  #  #
164  #  #
165    
166    =head2 var_path
167    
168      my $path = $self->var_path('data_dir', 'data_file', ... );
169    
170    =cut
171    
172    my $abs_path;
173    
174    sub var_path {
175            my $self = shift;
176    
177            if ( ! $abs_path ) {
178    #               $abs_path = abs_path( $0 );
179    #               $abs_path =~ s!/WebPAC/Common\.pm!!;
180                    $abs_path = '/data/webpac2';
181            }
182    
183            return File::Spec->catfile($abs_path, 'var', @_);
184    }
185    
186    =head1 EXPORTED NETHODS
187    
188    =head2 force_array
189    
190      my @array = force_array( $ref, sub {
191            warn "reference is undefined!";
192      });
193    
194    =cut
195    
196    sub force_array {
197            my ( $what, $error ) = @_;
198            my @result;
199            if ( ref( $what ) eq 'ARRAY' ) {
200                    @result = @{ $what };
201            } elsif ( defined $what ) {
202                    @result =  ( $what );
203            } else {
204                    $error->() if ref($error) eq 'CODE';
205            }
206            return @result;
207    }
208    
209    
210  =head1 INTERNAL METHODS  =head1 INTERNAL METHODS
211    
212  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 266  sub _init_logger {
266          my $name = (caller(2))[3] || caller;          my $name = (caller(2))[3] || caller;
267    
268          my $conf = q( );          my $conf = q( );
269          if ($self->{'no_log'}) {          if ($self->no_log) {
270                  warn "# $name disabled logging\n" if ($log_debug);                  warn "# $name disabled logging\n" if $self->log_debug;
271          } elsif ($self->{'debug'}) {                  $Log::Log4perl::Config::CONFIG_INTEGRITY_CHECK = 0;
272            } elsif ($self->debug) {
273                  $conf = << '_log4perl_';                  $conf = << '_log4perl_';
274    
275  log4perl.rootLogger=INFO, SCREEN  log4perl.rootLogger=INFO, SCREEN
# Line 174  log4perl.appender.SCREEN.layout=PatternL Line 281  log4perl.appender.SCREEN.layout=PatternL
281  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
282    
283  _log4perl_  _log4perl_
284                  warn "# $name is using debug logger\n" if ($log_debug);                  warn "# $name is using debug logger\n" if $self->log_debug;
285          } elsif ($name =~ m/Test::Exception/o) {          } elsif ($name =~ m/Test::Exception/o) {
286                  warn "# disabled logging for Text::Exception\n" if ($log_debug);                  warn "# disabled logging for Text::Exception\n" if $self->log_debug;
287          } elsif (-e $file) {          } elsif (-e $file) {
288                  warn "# $name is using $file logger\n" if ($log_debug);                  warn "# $name is using $file logger\n" if $self->log_debug;
289                  Log::Log4perl->init($file);                  Log::Log4perl->init($file);
290                  return 1;                  return 1;
291          } else {          } else {
292                  warn "# $name is using null logger\n" if ($log_debug);                  warn "# $name is using null logger\n" if $self->log_debug;
293          }          }
294          Log::Log4perl->init( \$conf );          Log::Log4perl->init( \$conf );
295    
# Line 199  method Line 306  method
306    
307  =cut  =cut
308    
309    my $_logger_seen;
310    
311  sub _get_logger {  sub _get_logger {
312          my $self = shift;          my $self = shift;
313    
314          my $name = (caller(2))[3] || caller;          my $name = (caller(1))[3] || caller;
315    
316            # make name full
317            my $f = '';
318            if ( $self->log_debug ) {
319                    foreach ( 0 .. 5 ) {
320                            my $s = (caller($_))[3];
321                            $f .= "#### $_ >> $s\n" if ($s);
322                    }
323            }
324    
325          $self->{'_logger_'} ||= $self->_init_logger;          $self->{'_logger_'} ||= $self->_init_logger;
326    
327          my $log = get_logger( $name );          my $log = get_logger( $name );
328          warn "# get_logger( $name ) level ", $log->level, "\n" if ($log_debug);          warn "# get_logger( $name ) level ", $log->level, "\n$f" if ($self->log_debug && !defined($_logger_seen->{$name}));
329            $_logger_seen->{$name}++;
330          return $log;          return $log;
331  }  }
332    
# Line 221  use webpac line this: Line 341  use webpac line this:
341  =cut  =cut
342    
343  sub _new {  sub _new {
344          my $class = shift;          my $class = shift;
345          my $self = {@_};          my $self = {@_};
346          bless($self, $class);          bless($self, $class);
347    
348          $self ? return $self : return undef;          $self ? return $self : return undef;
# Line 242  B<This is different from normal Log4perl Line 362  B<This is different from normal Log4perl
362  also use method names, and not only classes (which are just few)  also use method names, and not only classes (which are just few)
363  to filter logging.  to filter logging.
364    
365    =cut
366    
367    1;
Legend:
Removed from v.363  
changed lines
  Added in v.1068
  ViewVC Help
Powered by ViewVC 1.1.26