/[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 15 by dpavlin, Sun Jul 17 10:42:23 2005 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/;
13    use Data::Dump qw/dump/;
14    use File::Spec;
15    use Cwd qw/abs_path/;
16    
17    use base qw/Class::Accessor/;
18    __PACKAGE__->mk_accessors( qw/log_debug no_log debug/ );
19    
20  =head1 NAME  =head1 NAME
21    
# Line 11  WebPAC::Common - internal methods called Line 23  WebPAC::Common - internal methods called
23    
24  =head1 VERSION  =head1 VERSION
25    
26  Version 0.01  Version 0.05
27    
28  =cut  =cut
29    
30  our $VERSION = '0.01';  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 39  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 58  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 93  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 138  If no path to configuration file is give Line 248  If no path to configuration file is give
248  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
249  with C<debug> flag, it will turn logging to debug level.  with C<debug> flag, it will turn logging to debug level.
250    
251    This function will also read C<log_conf> value from current object and try
252    to read that as configuration file if it exists, if it doesn't it will
253    fallback to default C<conf/log.conf>.
254    
255    You can disable all logging by adding C<no_log> to constructor of WebPAC
256    object. Object in C<Test::Exception> class will disable logging
257    automatically.
258    
259  =cut  =cut
260    
261  sub _init_logger {  sub _init_logger {
262          my $self = shift;          my $self = shift;
263          my $file = shift;          my $file = shift;
264          if ($file) {          $file ||= $self->{'log_conf'};
265                  Log::Log4perl->init($file);          $file = 'conf/log.conf';
266          } else {          my $name = (caller(2))[3] || caller;
267                  my $conf = q( );  
268                  if ($self->{'debug'}) {          my $conf = q( );
269                          $conf = << '_log4perl_';          if ($self->no_log) {
270                    warn "# $name disabled logging\n" if $self->log_debug;
271                    $Log::Log4perl::Config::CONFIG_INTEGRITY_CHECK = 0;
272            } elsif ($self->debug) {
273                    $conf = << '_log4perl_';
274    
275  log4perl.rootLogger=INFO, SCREEN  log4perl.rootLogger=INFO, SCREEN
276    
# Line 159  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 $self->log_debug;
285                  Log::Log4perl->init( \$conf );          } elsif ($name =~ m/Test::Exception/o) {
286                    warn "# disabled logging for Text::Exception\n" if $self->log_debug;
287            } elsif (-e $file) {
288                    warn "# $name is using $file logger\n" if $self->log_debug;
289                    Log::Log4perl->init($file);
290                    return 1;
291            } else {
292                    warn "# $name is using null logger\n" if $self->log_debug;
293          }          }
294            Log::Log4perl->init( \$conf );
295    
296            return 1;
297  }  }
298    
299    
# Line 174  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    
         $self->{'_logger_ok'} ||= $self->_init_logger;  
   
314          my $name = (caller(1))[3] || caller;          my $name = (caller(1))[3] || caller;
315          return get_logger($name);  
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;
326    
327            my $log = get_logger( $name );
328            warn "# get_logger( $name ) level ", $log->level, "\n$f" if ($self->log_debug && !defined($_logger_seen->{$name}));
329            $_logger_seen->{$name}++;
330            return $log;
331  }  }
332    
333    
334    =head2 _log
335    
336    Quick cludge to make logging object available to scripts which
337    use webpac line this:
338    
339      my $log = _new WebPAC::Common()->_get_logger();
340    
341    =cut
342    
343    sub _new {
344            my $class = shift;
345            my $self = {@_};
346            bless($self, $class);
347    
348            $self ? return $self : return undef;
349    }
350    
351  =head1 LOGGING  =head1 LOGGING
352    
353  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 198  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.15  
changed lines
  Added in v.1068
  ViewVC Help
Powered by ViewVC 1.1.26