--- trunk/lib/WebPAC/Common.pm 2005/07/16 17:14:43 9 +++ trunk/lib/WebPAC/Common.pm 2007/09/03 15:26:46 887 @@ -3,7 +3,13 @@ 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 base qw/Class::Accessor/; +__PACKAGE__->mk_accessors( qw/log_debug no_log debug/ ); =head1 NAME @@ -11,159 +17,43 @@ =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 $webpac = new WebPAC::Common( - filter => { - 'filter_name_1' => sub { - # filter code - return length($_); - }, ... - }, - } - -=head1 FUNCTIONS - -=head2 fill_in - -Workhourse of all: takes record from in-memory structure of database and -strings with placeholders and returns string or array of with substituted -values from record. - - my $text = $webpac->fill_in($rec,'v250^a'); - -Optional argument is ordinal number for repeatable fields. By default, -it's assume to be first repeatable field (fields are perl array, so first -element is 0). -Following example will read second value from repeatable field. - - my $text = $webpac->fill_in($rec,'Title: v250^a',1); - -This function B perform parsing of format to inteligenty skip -delimiters before fields which aren't used. - -This method will automatically decode UTF-8 string to local code page -if needed. - -=cut - -sub fill_in { - my $self = shift; - - my $log = $self->_get_logger(); - - my $rec = shift || $log->logconfess("need data record"); - my $format = shift || $log->logconfess("need format to parse"); - # iteration (for repeatable fields) - my $i = shift || 0; - - $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999)); - - # FIXME remove for speedup? - $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o); - - if (utf8::is_utf8($format)) { - $format = $self->_x($format); - } - - my $found = 0; - - my $eval_code; - # remove eval{...} from beginning - $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s); - - my $filter_name; - # remove filter{...} from beginning - $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s); - - # do actual replacement of placeholders - # repeatable fields - $format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges; - # non-repeatable fields - $format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found)/ges; - - if ($found) { - $log->debug("format: $format"); - if ($eval_code) { - my $eval = $self->fill_in($rec,$eval_code,$i); - return if (! $self->_eval($eval)); - } - if ($filter_name && $self->{'filter'}->{$filter_name}) { - $log->debug("filter '$filter_name' for $format"); - $format = $self->{'filter'}->{$filter_name}->($format); - return unless(defined($format)); - $log->debug("filter result: $format"); - } - # do we have lookups? - if ($self->{'lookup'}) { - return $self->lookup($format); - } else { - return $format; - } - } else { - return; - } -} - +my $o = WebPAC::Common->new({ + log_debug => 1, + no_log => 1, + debug => 1, +}); -=head2 get_data +Options: -Returns value from record. +=over 20 - my $text = $self->get_data(\$rec,$f,$sf,$i,\$found); +=item log_debug -Arguments are: -record reference C<$rec>, -field C<$f>, -optional subfiled C<$sf>, -index for repeatable values C<$i>. +Generate additional debugging log on C -Optinal variable C<$found> will be incremeted if there -is field. +=item no_log -Returns value or empty string. +Disable all logging (useful for tests) -=cut +=item debug -sub get_data { - my $self = shift; +Use debugging logger which dumps output only yo C - my ($rec,$f,$sf,$i,$found) = @_; +=back - if ($$rec->{$f}) { - return '' if (! $$rec->{$f}->[$i]); - no strict 'refs'; - if ($sf && $$rec->{$f}->[$i]->{$sf}) { - $$found++ if (defined($$found)); - return $$rec->{$f}->[$i]->{$sf}; - } elsif ($$rec->{$f}->[$i]) { - $$found++ if (defined($$found)); - # it still might have subfield, just - # not specified, so we'll dump all - if ($$rec->{$f}->[$i] =~ /HASH/o) { - my $out; - foreach my $k (keys %{$$rec->{$f}->[$i]}) { - $out .= $$rec->{$f}->[$i]->{$k}." "; - } - return $out; - } else { - return $$rec->{$f}->[$i]; - } - } - } else { - return ''; - } -} +=head1 FUNCTIONS =head2 progress_bar @@ -180,6 +70,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); @@ -199,14 +91,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); } @@ -234,10 +128,48 @@ 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 + +sub var_path { + my $self = shift; + + return File::Spec->catfile('var', @_); +} + + =head1 INTERNAL METHODS Here is a quick list of internal methods, mostly useful to turn debugging @@ -269,45 +201,6 @@ return $ret || undef; } -=head2 _sort_by_order - -Sort xml tags data structure accoding to C attribute. - -=cut - -sub _sort_by_order { - my $self = shift; - - my $va = $self->{'import_xml'}->{'indexer'}->{$a}->{'order'} || - $self->{'import_xml'}->{'indexer'}->{$a}; - my $vb = $self->{'import_xml'}->{'indexer'}->{$b}->{'order'} || - $self->{'import_xml'}->{'indexer'}->{$b}; - - return $va <=> $vb; -} - -=head2 _x - -Convert string from UTF-8 to code page defined in C. - - my $text = $webpac->_x('utf8 text'); - -Default application code page is C. You will probably want to -change that when creating new instance of object based on this one. - -=cut - -sub _x { - my $self = shift; - my $utf8 = shift || return; - - # create UTF-8 convertor for import_xml files - $self->{'utf2cp'} ||= Text::Iconv->new('UTF-8' ,$self->{'code_page'} || 'ISO-8859-2'); - - return $self->{'utf2cp'}->convert($utf8) || - $self->_get_logger()->logwarn("can't convert '$utf8'"); -} - =head2 _init_logger This function will init C using provided configuration file. @@ -315,19 +208,54 @@ $webpac->_init_logger('/path/to/log.conf'); If no path to configuration file is given, dummy empty configuration -will be create. +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) { + $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; + } elsif ($self->debug) { + $conf = << '_log4perl_'; + +log4perl.rootLogger=INFO, SCREEN + +log4perl.logger.WebPAC.=DEBUG + +log4perl.appender.SCREEN=Log::Log4perl::Appender::Screen +log4perl.appender.SCREEN.layout=PatternLayout +log4perl.appender.SCREEN.layout.ConversionPattern=%d %p> %F{1}:%L %M - %m%n + +_log4perl_ + 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 { - my $conf = q( ); - Log::Log4perl->init( \$conf ); + warn "# $name is using null logger\n" if $self->log_debug; } + Log::Log4perl->init( \$conf ); + + return 1; } @@ -340,16 +268,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 @@ -364,4 +324,6 @@ also use method names, and not only classes (which are just few) to filter logging. +=cut +1;