/[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 13 by dpavlin, Sat Jul 16 23:56:14 2005 UTC revision 29 by dpavlin, Sun Jul 24 11:17:44 2005 UTC
# Line 3  package WebPAC::Common; Line 3  package WebPAC::Common;
3  use warnings;  use warnings;
4  use strict;  use strict;
5    
6  use Log::Log4perl qw(get_logger :levels);  use Log::Log4perl qw/get_logger :levels/;
7    use Time::HiRes qw/time/;
8    
9    # If ture, enable logging debug
10    my $log_debug = 0;
11    
12  =head1 NAME  =head1 NAME
13    
# Line 22  our $VERSION = '0.01'; Line 26  our $VERSION = '0.01';
26  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
27  specific modules.  specific modules.
28    
  my $webpac = new WebPAC::Common(  
         filter => {  
                 'filter_name_1' => sub {  
                         # filter code  
                         return length($_);  
                 }, ...  
         },  
   }  
   
29  =head1 FUNCTIONS  =head1 FUNCTIONS
30    
 =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<does not> 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;  
         }  
 }  
   
   
 =head2 get_data  
   
 Returns value from record.  
   
  my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);  
   
 Arguments are:  
 record reference C<$rec>,  
 field C<$f>,  
 optional subfiled C<$sf>,  
 index for repeatable values C<$i>.  
   
 Optinal variable C<$found> will be incremeted if there  
 is field.  
   
 Returns value or empty string.  
   
 =cut  
   
 sub get_data {  
         my $self = shift;  
   
         my ($rec,$f,$sf,$i,$found) = @_;  
   
         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 '';  
         }  
 }  
   
   
31  =head2 progress_bar  =head2 progress_bar
32    
33  Draw progress bar on STDERR.  Draw progress bar on STDERR.
# Line 279  If no path to configuration file is give Line 142  If no path to configuration file is give
142  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
143  with C<debug> flag, it will turn logging to debug level.  with C<debug> flag, it will turn logging to debug level.
144    
145    This function will also read C<log_conf> value from current object and try
146    to read that as configuration file if it exists.
147    
148  =cut  =cut
149    
150  sub _init_logger {  sub _init_logger {
151          my $self = shift;          my $self = shift;
152          my $file = shift;          my $file = shift;
153            $file ||= $self->{'log_conf'};
154            $file = 'conf/log.conf';
155            my $name = (caller(2))[3] || caller;
156          if ($file) {          if ($file) {
157                    warn "# $name is using $file logger\n" if ($log_debug);
158                  Log::Log4perl->init($file);                  Log::Log4perl->init($file);
159          } else {          } else {
160                  my $conf = q( );                  my $conf = q( );
# Line 300  log4perl.appender.SCREEN.layout=PatternL Line 170  log4perl.appender.SCREEN.layout=PatternL
170  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
171    
172  _log4perl_  _log4perl_
173                            warn "# $name is using debug logger\n" if ($log_debug);
174                    } else {
175                            warn "# $name is using null logger\n" if ($log_debug);
176                  }                  }
177                  Log::Log4perl->init( \$conf );                  Log::Log4perl->init( \$conf );
178          }          }
# Line 318  method Line 191  method
191  sub _get_logger {  sub _get_logger {
192          my $self = shift;          my $self = shift;
193    
194          $self->{'_logger_ok'} ||= $self->_init_logger;          my $name = (caller(2))[3] || caller;
195            $self->{'_logger_'} ||= $self->_init_logger;
196    
197            warn "# get_logger( $name )\n" if ($log_debug);
198    
         my $name = (caller(1))[3] || caller;  
199          return get_logger($name);          return get_logger($name);
200  }  }
201    
Legend:
Removed from v.13  
changed lines
  Added in v.29
  ViewVC Help
Powered by ViewVC 1.1.26