/[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 16 by dpavlin, Sun Jul 17 11:37:07 2005 UTC revision 924 by dpavlin, Wed Oct 31 00:26:45 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    
15    use base qw/Class::Accessor/;
16    __PACKAGE__->mk_accessors( qw/log_debug no_log debug/ );
17    
18  =head1 NAME  =head1 NAME
19    
# Line 12  WebPAC::Common - internal methods called Line 21  WebPAC::Common - internal methods called
21    
22  =head1 VERSION  =head1 VERSION
23    
24  Version 0.01  Version 0.05
25    
26  =cut  =cut
27    
28  our $VERSION = '0.01';  our $VERSION = '0.05';
29    
30  =head1 SYNOPSYS  =head1 SYNOPSYS
31    
32  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
33  specific modules.  specific modules.
34    
35    my $o = WebPAC::Common->new({
36            log_debug => 1,
37            no_log => 1,
38            debug => 1,
39    });
40    
41    Options:
42    
43    =over 20
44    
45    =item log_debug
46    
47    Generate additional debugging log on C<STDERR>
48    
49    =item no_log
50    
51    Disable all logging (useful for tests)
52    
53    =item debug
54    
55    Use debugging logger which dumps output only yo C<STDERR>
56    
57    =back
58    
59    
60  =head1 FUNCTIONS  =head1 FUNCTIONS
61    
62  =head2 progress_bar  =head2 progress_bar
# Line 40  sub progress_bar { Line 74  sub progress_bar {
74    
75          my $log = $self->_get_logger();          my $log = $self->_get_logger();
76    
77            $self->{last_pcnt_t} ||= time();
78    
79          $log->logconfess("no current value!") if (! $curr);          $log->logconfess("no current value!") if (! $curr);
80          $log->logconfess("no maximum value!") if (! $max);          $log->logconfess("no maximum value!") if (! $max);
81    
# Line 59  sub progress_bar { Line 95  sub progress_bar {
95                  $self->{'start_t'} = time();                  $self->{'start_t'} = time();
96          }          }
97    
98          if ($p != $self->{'last_pcnt'}) {          my $t = time();
99    
100            if ($p != $self->{'last_pcnt'} || ( $t - $self->{last_pcnt_t} ) > 2 ) {
101    
                 my $t = time();  
102                  my $rate = ($curr / ($t - $self->{'start_t'} || 1));                  my $rate = ($curr / ($t - $self->{'start_t'} || 1));
103                  my $eta = ($max-$curr) / ($rate || 1);                  my $eta = ($max-$curr) / ($rate || 1);
104                  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));
105                  $self->{'last_pcnt'} = $p;                  $self->{'last_pcnt'} = $p;
106                  $self->{'last_curr'} = $curr;                  $self->{'last_curr'} = $curr;
107                    $self->{last_pcnt_t} = $t;
108          }          }
109          print STDERR "\n" if ($p == 100);          print STDERR "\n" if ($p == 100);
110  }  }
# Line 94  sub fmt_time { Line 132  sub fmt_time {
132          return $out;          return $out;
133  }  }
134    
135    =head2 fill_in
136    
137    Fill in variable names by values
138    
139      print $webpac->fill_in( 'foo = $foo bar = $bar',
140            foo => 42, bar => 11,
141      );
142    
143    =cut
144    
145    sub fill_in {
146            my $self = shift;
147    
148            my $format = shift || die "no format?";
149            my $d = {@_};
150    
151            foreach my $n ( keys %$d ) {
152                    $format =~ s/\$\Q$n\E/$d->{$n}/gs;
153            }
154    
155            die "unknown variables in '$format' input data = ", dump( $d ) if ( $format =~ m/\$\w+/ );
156    
157            return $format;
158    }
159    
160  #  #
161  #  #
162  #  #
163    
164    =head2 var_path
165    
166      my $path = $self->var_path('data_dir', 'data_file', ... );
167    
168    =cut
169    
170    sub var_path {
171            my $self = shift;
172    
173            return File::Spec->catfile('var', @_);
174    }
175    
176    =head1 EXPORTED NETHODS
177    
178    =head2 force_array
179    
180      my @array = force_array( $ref, sub {
181            warn "reference is undefined!";
182      });
183    
184    =cut
185    
186    sub force_array {
187            my ( $what, $error ) = @_;
188            my @result;
189            if ( ref( $what ) eq 'ARRAY' ) {
190                    @result = @{ $what };
191            } elsif ( defined $what ) {
192                    @result =  ( $what );
193            } else {
194                    $error->() if ref($error) eq 'CODE';
195            }
196            return @result;
197    }
198    
199    
200  =head1 INTERNAL METHODS  =head1 INTERNAL METHODS
201    
202  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 139  If no path to configuration file is give Line 238  If no path to configuration file is give
238  will be created. If any mode which inherits from this one is called  will be created. If any mode which inherits from this one is called
239  with C<debug> flag, it will turn logging to debug level.  with C<debug> flag, it will turn logging to debug level.
240    
241    This function will also read C<log_conf> value from current object and try
242    to read that as configuration file if it exists, if it doesn't it will
243    fallback to default C<conf/log.conf>.
244    
245    You can disable all logging by adding C<no_log> to constructor of WebPAC
246    object. Object in C<Test::Exception> class will disable logging
247    automatically.
248    
249  =cut  =cut
250    
251  sub _init_logger {  sub _init_logger {
252          my $self = shift;          my $self = shift;
253          my $file = shift;          my $file = shift;
254          if ($file) {          $file ||= $self->{'log_conf'};
255                  Log::Log4perl->init($file);          $file = 'conf/log.conf';
256          } else {          my $name = (caller(2))[3] || caller;
257                  my $conf = q( );  
258                  if ($self->{'debug'}) {          my $conf = q( );
259                          $conf = << '_log4perl_';          if ($self->no_log) {
260                    warn "# $name disabled logging\n" if $self->log_debug;
261            } elsif ($self->debug) {
262                    $conf = << '_log4perl_';
263    
264  log4perl.rootLogger=INFO, SCREEN  log4perl.rootLogger=INFO, SCREEN
265    
# Line 160  log4perl.appender.SCREEN.layout=PatternL Line 270  log4perl.appender.SCREEN.layout=PatternL
270  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
271    
272  _log4perl_  _log4perl_
273                  }                  warn "# $name is using debug logger\n" if $self->log_debug;
274                  Log::Log4perl->init( \$conf );          } elsif ($name =~ m/Test::Exception/o) {
275                    warn "# disabled logging for Text::Exception\n" if $self->log_debug;
276            } elsif (-e $file) {
277                    warn "# $name is using $file logger\n" if $self->log_debug;
278                    Log::Log4perl->init($file);
279                    return 1;
280            } else {
281                    warn "# $name is using null logger\n" if $self->log_debug;
282          }          }
283            Log::Log4perl->init( \$conf );
284    
285            return 1;
286  }  }
287    
288    
# Line 175  method Line 295  method
295    
296  =cut  =cut
297    
298    my $_logger_seen;
299    
300  sub _get_logger {  sub _get_logger {
301          my $self = shift;          my $self = shift;
302    
         $self->{'_logger_ok'} ||= $self->_init_logger;  
   
303          my $name = (caller(1))[3] || caller;          my $name = (caller(1))[3] || caller;
304          return get_logger($name);  
305            # make name full
306            my $f = '';
307            if ( $self->log_debug ) {
308                    foreach ( 0 .. 5 ) {
309                            my $s = (caller($_))[3];
310                            $f .= "#### $_ >> $s\n" if ($s);
311                    }
312            }
313    
314            $self->{'_logger_'} ||= $self->_init_logger;
315    
316            my $log = get_logger( $name );
317            warn "# get_logger( $name ) level ", $log->level, "\n$f" if ($self->log_debug && !defined($_logger_seen->{$name}));
318            $_logger_seen->{$name}++;
319            return $log;
320  }  }
321    
322    
323    =head2 _log
324    
325    Quick cludge to make logging object available to scripts which
326    use webpac line this:
327    
328      my $log = _new WebPAC::Common()->_get_logger();
329    
330    =cut
331    
332    sub _new {
333            my $class = shift;
334            my $self = {@_};
335            bless($self, $class);
336    
337            $self ? return $self : return undef;
338    }
339    
340  =head1 LOGGING  =head1 LOGGING
341    
342  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 199  B<This is different from normal Log4perl Line 351  B<This is different from normal Log4perl
351  also use method names, and not only classes (which are just few)  also use method names, and not only classes (which are just few)
352  to filter logging.  to filter logging.
353    
354    =cut
355    
356    1;
Legend:
Removed from v.16  
changed lines
  Added in v.924
  ViewVC Help
Powered by ViewVC 1.1.26