git.rot13.org Git - webpac2/blob - lib/WebPAC/Common.pm

   1 package WebPAC::Common;
   2
   3 use warnings;
   4 use strict;
   5
   6 use Log::Log4perl qw(get_logger :levels);
   7
   8 =head1 NAME
   9
  10 WebPAC::Common - internal methods called from other WebPAC modules
  11
  12 =head1 VERSION
  13
  14 Version 0.01
  15
  16 =cut
  17
  18 our $VERSION = '0.01';
  19
  20 =head1 SYNOPSYS
  21
  22 This module defines common functions, and is used as base for other, more
  23 specific modules.
  24
  25  my $webpac = new WebPAC::Common(
  26         filter => {
  27                 'filter_name_1' => sub {
  28                         # filter code
  29                         return length($_);
  30                 }, ...
  31         },
  32   }
  33
  34 =head1 FUNCTIONS
  35
  36 =head2 fill_in
  37
  38 Workhourse of all: takes record from in-memory structure of database and
  39 strings with placeholders and returns string or array of with substituted
  40 values from record.
  41
  42  my $text = $webpac->fill_in($rec,'v250^a');
  43
  44 Optional argument is ordinal number for repeatable fields. By default,
  45 it's assume to be first repeatable field (fields are perl array, so first
  46 element is 0).
  47 Following example will read second value from repeatable field.
  48
  49  my $text = $webpac->fill_in($rec,'Title: v250^a',1);
  50
  51 This function B<does not> perform parsing of format to inteligenty skip
  52 delimiters before fields which aren't used.
  53
  54 This method will automatically decode UTF-8 string to local code page
  55 if needed.
  56
  57 =cut
  58
  59 sub fill_in {
  60         my $self = shift;
  61
  62         my $log = $self->_get_logger();
  63
  64         my $rec = shift || $log->logconfess("need data record");
  65         my $format = shift || $log->logconfess("need format to parse");
  66         # iteration (for repeatable fields)
  67         my $i = shift || 0;
  68
  69         $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));
  70
  71         # FIXME remove for speedup?
  72         $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
  73
  74         if (utf8::is_utf8($format)) {
  75                 $format = $self->_x($format);
  76         }
  77
  78         my $found = 0;
  79
  80         my $eval_code;
  81         # remove eval{...} from beginning
  82         $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
  83
  84         my $filter_name;
  85         # remove filter{...} from beginning
  86         $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
  87
  88         # do actual replacement of placeholders
  89         # repeatable fields
  90         $format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;
  91         # non-repeatable fields
  92         $format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found)/ges;
  93
  94         if ($found) {
  95                 $log->debug("format: $format");
  96                 if ($eval_code) {
  97                         my $eval = $self->fill_in($rec,$eval_code,$i);
  98                         return if (! $self->_eval($eval));
  99                 }
 100                 if ($filter_name && $self->{'filter'}->{$filter_name}) {
 101                         $log->debug("filter '$filter_name' for $format");
 102                         $format = $self->{'filter'}->{$filter_name}->($format);
 103                         return unless(defined($format));
 104                         $log->debug("filter result: $format");
 105                 }
 106                 # do we have lookups?
 107                 if ($self->{'lookup'}) {
 108                         return $self->lookup($format);
 109                 } else {
 110                         return $format;
 111                 }
 112         } else {
 113                 return;
 114         }
 115 }
 116
 117
 118 =head2 get_data
 119
 120 Returns value from record.
 121
 122  my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);
 123
 124 Arguments are:
 125 record reference C<$rec>,
 126 field C<$f>,
 127 optional subfiled C<$sf>,
 128 index for repeatable values C<$i>.
 129
 130 Optinal variable C<$found> will be incremeted if there
 131 is field.
 132
 133 Returns value or empty string.
 134
 135 =cut
 136
 137 sub get_data {
 138         my $self = shift;
 139
 140         my ($rec,$f,$sf,$i,$found) = @_;
 141
 142         if ($$rec->{$f}) {
 143                 return '' if (! $$rec->{$f}->[$i]);
 144                 no strict 'refs';
 145                 if ($sf && $$rec->{$f}->[$i]->{$sf}) {
 146                         $$found++ if (defined($$found));
 147                         return $$rec->{$f}->[$i]->{$sf};
 148                 } elsif ($$rec->{$f}->[$i]) {
 149                         $$found++ if (defined($$found));
 150                         # it still might have subfield, just
 151                         # not specified, so we'll dump all
 152                         if ($$rec->{$f}->[$i] =~ /HASH/o) {
 153                                 my $out;
 154                                 foreach my $k (keys %{$$rec->{$f}->[$i]}) {
 155                                         $out .= $$rec->{$f}->[$i]->{$k}." ";
 156                                 }
 157                                 return $out;
 158                         } else {
 159                                 return $$rec->{$f}->[$i];
 160                         }
 161                 }
 162         } else {
 163                 return '';
 164         }
 165 }
 166
 167
 168 =head2 progress_bar
 169
 170 Draw progress bar on STDERR.
 171
 172  $webpac->progress_bar($current, $max);
 173
 174 =cut
 175
 176 sub progress_bar {
 177         my $self = shift;
 178
 179         my ($curr,$max) = @_;
 180
 181         my $log = $self->_get_logger();
 182
 183         $log->logconfess("no current value!") if (! $curr);
 184         $log->logconfess("no maximum value!") if (! $max);
 185
 186         if ($curr > $max) {
 187                 $max = $curr;
 188                 $log->debug("overflow to $curr");
 189         }
 190
 191         $self->{'last_pcnt'} ||= 1;
 192         $self->{'start_t'} ||= time();
 193
 194         my $p = int($curr * 100 / $max) || 1;
 195
 196         # reset on re-run
 197         if ($p < $self->{'last_pcnt'}) {
 198                 $self->{'last_pcnt'} = $p;
 199                 $self->{'start_t'} = time();
 200         }
 201
 202         if ($p != $self->{'last_pcnt'}) {
 203
 204                 my $t = time();
 205                 my $rate = ($curr / ($t - $self->{'start_t'} || 1));
 206                 my $eta = ($max-$curr) / ($rate || 1);
 207                 printf STDERR ("%5d [%-38s] %-5d %0.1f/s %s\r",$curr,"=" x ($p/3)."$p%>", $max, $rate, $self->fmt_time($eta));
 208                 $self->{'last_pcnt'} = $p;
 209                 $self->{'last_curr'} = $curr;
 210         }
 211         print STDERR "\n" if ($p == 100);
 212 }
 213
 214 =head2 fmt_time
 215
 216 Format time (in seconds) for display.
 217
 218  print $webpac->fmt_time(time());
 219
 220 This method is called by L<progress_bar> to display remaining time.
 221
 222 =cut
 223
 224 sub fmt_time {
 225         my $self = shift;
 226
 227         my $t = shift || 0;
 228         my $out = "";
 229
 230         my ($ss,$mm,$hh) = gmtime($t);
 231         $out .= "${hh}h" if ($hh);
 232         $out .= sprintf("%02d:%02d", $mm,$ss);
 233         $out .= "  " if ($hh == 0);
 234         return $out;
 235 }
 236
 237 #
 238 #
 239 #
 240
 241 =head1 INTERNAL METHODS
 242
 243 Here is a quick list of internal methods, mostly useful to turn debugging
 244 on them (see L<LOGGING> below for explanation).
 245
 246 =cut
 247
 248 =head2 _eval
 249
 250 Internal function to eval code without C<strict 'subs'>.
 251
 252 =cut
 253
 254 sub _eval {
 255         my $self = shift;
 256
 257         my $code = shift || return;
 258
 259         my $log = $self->_get_logger();
 260
 261         no strict 'subs';
 262         my $ret = eval $code;
 263         if ($@) {
 264                 $log->error("problem with eval code [$code]: $@");
 265         }
 266
 267         $log->debug("eval: ",$code," [",$ret,"]");
 268
 269         return $ret || undef;
 270 }
 271
 272 =head2 _init_logger
 273
 274 This function will init C<Log::Log4perl> using provided configuration file.
 275
 276   $webpac->_init_logger('/path/to/log.conf');
 277
 278 If no path to configuration file is given, dummy empty configuration
 279 will be created. If any mode which inherits from this one is called
 280 with C<debug> flag, it will turn logging to debug level.
 281
 282 =cut
 283
 284 sub _init_logger {
 285         my $self = shift;
 286         my $file = shift;
 287         if ($file) {
 288                 Log::Log4perl->init($file);
 289         } else {
 290                 my $conf = q( );
 291                 if ($self->{'debug'}) {
 292                         $conf = << '_log4perl_';
 293
 294 log4perl.rootLogger=INFO, SCREEN
 295
 296 log4perl.logger.WebPAC.=DEBUG
 297
 298 log4perl.appender.SCREEN=Log::Log4perl::Appender::Screen
 299 log4perl.appender.SCREEN.layout=PatternLayout
 300 log4perl.appender.SCREEN.layout.ConversionPattern=%d %p> %F{1}:%L %M - %m%n
 301
 302 _log4perl_
 303                 }
 304                 Log::Log4perl->init( \$conf );
 305         }
 306 }
 307
 308
 309 =head2 _get_logger
 310
 311 Get C<Log::Log4perl> object with a twist: domains are defined for each
 312 method
 313
 314  my $log = $webpac->_get_logger();
 315
 316 =cut
 317
 318 sub _get_logger {
 319         my $self = shift;
 320
 321         $self->{'_logger_ok'} ||= $self->_init_logger;
 322
 323         my $name = (caller(1))[3] || caller;
 324         return get_logger($name);
 325 }
 326
 327
 328 =head1 LOGGING
 329
 330 Logging in WebPAC is performed by L<Log::Log4perl> with config file
 331 C<log.conf>.
 332
 333 Methods defined above have different levels of logging, so
 334 it's descriptions will be useful to turn (mostry B<debug> logging) on
 335 or off to see why WabPAC isn't perforing as you expect it (it might even
 336 be a bug!).
 337
 338 B<This is different from normal Log4perl behaviour>. To repeat, you can
 339 also use method names, and not only classes (which are just few)
 340 to filter logging.
 341
 342