--- trunk/lib/WebPAC/Common.pm 2005/07/17 10:42:23 15 +++ trunk/lib/WebPAC/Common.pm 2007/11/27 23:45:28 1068 @@ -1,9 +1,21 @@ package WebPAC::Common; +use Exporter 'import'; +@EXPORT = qw/ + force_array + dump +/; use warnings; use strict; -use Log::Log4perl qw(get_logger :levels); +use Log::Log4perl qw/get_logger :levels/; +use Time::HiRes qw/time/; +use Data::Dump qw/dump/; +use File::Spec; +use Cwd qw/abs_path/; + +use base qw/Class::Accessor/; +__PACKAGE__->mk_accessors( qw/log_debug no_log debug/ ); =head1 NAME @@ -11,17 +23,42 @@ =head1 VERSION -Version 0.01 +Version 0.05 =cut -our $VERSION = '0.01'; +our $VERSION = '0.05'; =head1 SYNOPSYS This module defines common functions, and is used as base for other, more specific modules. +my $o = WebPAC::Common->new({ + log_debug => 1, + no_log => 1, + debug => 1, +}); + +Options: + +=over 20 + +=item log_debug + +Generate additional debugging log on C + +=item no_log + +Disable all logging (useful for tests) + +=item debug + +Use debugging logger which dumps output only yo C + +=back + + =head1 FUNCTIONS =head2 progress_bar @@ -39,6 +76,8 @@ my $log = $self->_get_logger(); + $self->{last_pcnt_t} ||= time(); + $log->logconfess("no current value!") if (! $curr); $log->logconfess("no maximum value!") if (! $max); @@ -58,14 +97,16 @@ $self->{'start_t'} = time(); } - if ($p != $self->{'last_pcnt'}) { + my $t = time(); + + if ($p != $self->{'last_pcnt'} || ( $t - $self->{last_pcnt_t} ) > 2 ) { - my $t = time(); my $rate = ($curr / ($t - $self->{'start_t'} || 1)); my $eta = ($max-$curr) / ($rate || 1); printf STDERR ("%5d [%-38s] %-5d %0.1f/s %s\r",$curr,"=" x ($p/3)."$p%>", $max, $rate, $self->fmt_time($eta)); $self->{'last_pcnt'} = $p; $self->{'last_curr'} = $curr; + $self->{last_pcnt_t} = $t; } print STDERR "\n" if ($p == 100); } @@ -93,10 +134,79 @@ return $out; } +=head2 fill_in + +Fill in variable names by values + + print $webpac->fill_in( 'foo = $foo bar = $bar', + foo => 42, bar => 11, + ); + +=cut + +sub fill_in { + my $self = shift; + + my $format = shift || die "no format?"; + my $d = {@_}; + + foreach my $n ( keys %$d ) { + $format =~ s/\$\Q$n\E/$d->{$n}/gs; + } + + die "unknown variables in '$format' input data = ", dump( $d ) if ( $format =~ m/\$\w+/ ); + + return $format; +} + # # # +=head2 var_path + + my $path = $self->var_path('data_dir', 'data_file', ... ); + +=cut + +my $abs_path; + +sub var_path { + my $self = shift; + + if ( ! $abs_path ) { +# $abs_path = abs_path( $0 ); +# $abs_path =~ s!/WebPAC/Common\.pm!!; + $abs_path = '/data/webpac2'; + } + + return File::Spec->catfile($abs_path, 'var', @_); +} + +=head1 EXPORTED NETHODS + +=head2 force_array + + my @array = force_array( $ref, sub { + warn "reference is undefined!"; + }); + +=cut + +sub force_array { + my ( $what, $error ) = @_; + my @result; + if ( ref( $what ) eq 'ARRAY' ) { + @result = @{ $what }; + } elsif ( defined $what ) { + @result = ( $what ); + } else { + $error->() if ref($error) eq 'CODE'; + } + return @result; +} + + =head1 INTERNAL METHODS Here is a quick list of internal methods, mostly useful to turn debugging @@ -138,17 +248,29 @@ will be created. If any mode which inherits from this one is called with C flag, it will turn logging to debug level. +This function will also read C value from current object and try +to read that as configuration file if it exists, if it doesn't it will +fallback to default C. + +You can disable all logging by adding C to constructor of WebPAC +object. Object in C class will disable logging +automatically. + =cut sub _init_logger { my $self = shift; my $file = shift; - if ($file) { - Log::Log4perl->init($file); - } else { - my $conf = q( ); - if ($self->{'debug'}) { - $conf = << '_log4perl_'; + $file ||= $self->{'log_conf'}; + $file = 'conf/log.conf'; + my $name = (caller(2))[3] || caller; + + my $conf = q( ); + if ($self->no_log) { + warn "# $name disabled logging\n" if $self->log_debug; + $Log::Log4perl::Config::CONFIG_INTEGRITY_CHECK = 0; + } elsif ($self->debug) { + $conf = << '_log4perl_'; log4perl.rootLogger=INFO, SCREEN @@ -159,9 +281,19 @@ log4perl.appender.SCREEN.layout.ConversionPattern=%d %p> %F{1}:%L %M - %m%n _log4perl_ - } - Log::Log4perl->init( \$conf ); + warn "# $name is using debug logger\n" if $self->log_debug; + } elsif ($name =~ m/Test::Exception/o) { + warn "# disabled logging for Text::Exception\n" if $self->log_debug; + } elsif (-e $file) { + warn "# $name is using $file logger\n" if $self->log_debug; + Log::Log4perl->init($file); + return 1; + } else { + warn "# $name is using null logger\n" if $self->log_debug; } + Log::Log4perl->init( \$conf ); + + return 1; } @@ -174,16 +306,48 @@ =cut +my $_logger_seen; + sub _get_logger { my $self = shift; - $self->{'_logger_ok'} ||= $self->_init_logger; - my $name = (caller(1))[3] || caller; - return get_logger($name); + + # make name full + my $f = ''; + if ( $self->log_debug ) { + foreach ( 0 .. 5 ) { + my $s = (caller($_))[3]; + $f .= "#### $_ >> $s\n" if ($s); + } + } + + $self->{'_logger_'} ||= $self->_init_logger; + + my $log = get_logger( $name ); + warn "# get_logger( $name ) level ", $log->level, "\n$f" if ($self->log_debug && !defined($_logger_seen->{$name})); + $_logger_seen->{$name}++; + return $log; } +=head2 _log + +Quick cludge to make logging object available to scripts which +use webpac line this: + + my $log = _new WebPAC::Common()->_get_logger(); + +=cut + +sub _new { + my $class = shift; + my $self = {@_}; + bless($self, $class); + + $self ? return $self : return undef; +} + =head1 LOGGING Logging in WebPAC is performed by L with config file @@ -198,4 +362,6 @@ also use method names, and not only classes (which are just few) to filter logging. +=cut +1;