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