/[webpac2]/trunk/lib/WebPAC/Normalize.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/Normalize.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 397 by dpavlin, Wed Feb 15 15:54:12 2006 UTC
# Line 2  package WebPAC::Normalize; Line 2  package WebPAC::Normalize;
2    
3  use warnings;  use warnings;
4  use strict;  use strict;
5    use blib;
6    use WebPAC::Common;
7    use base 'WebPAC::Common';
8  use Data::Dumper;  use Data::Dumper;
9    
10  =head1 NAME  =head1 NAME
11    
12  WebPAC::Normalize - normalisation of source file  WebPAC::Normalize - data mungling for normalisation
13    
14  =head1 VERSION  =head1 VERSION
15    
16  Version 0.01  Version 0.08
17    
18  =cut  =cut
19    
20  our $VERSION = '0.01';  our $VERSION = '0.08';
21    
22  =head1 SYNOPSIS  =head1 SYNOPSIS
23    
24  This package contains code that could be helpful in implementing different  This package contains code that mungle data to produce normalized format.
25  normalisation front-ends.  
26    It contains several assumptions:
27    
28    =over
29    
30    =item *
31    
32    format of fields is defined using C<v123^a> notation for repeatable fields
33    or C<s123^a> for single (or first) value, where C<123> is field number and
34    C<a> is subfield.
35    
36    =item *
37    
38    source data records (C<$rec>) have unique identifiers in field C<000>
39    
40    =item *
41    
42    optional C<eval{length('v123^a') == 3}> tag at B<beginning of format> will be
43    perl code that is evaluated before producing output (value of field will be
44    interpolated before that)
45    
46    =item *
47    
48    optional C<filter{filter_name}> at B<begining of format> will apply perl
49    code defined as code ref on format after field substitution to producing
50    output
51    
52    There is one built-in filter called C<regex> which can be use like this:
53    
54      filter{regex(s/foo/bar/)}
55    
56    =item *
57    
58    optional C<lookup{...}> will be then performed. See C<WebPAC::Lookups>.
59    
60    =item *
61    
62    at end, optional C<format>s rules are resolved. Format rules are similar to
63    C<sprintf> and can also contain C<lookup{...}> which is performed after
64    values are inserted in format.
65    
66    =back
67    
68    This also describes order in which transformations are applied (eval,
69    filter, lookup, format) which is important to undestand when deciding how to
70    solve your data mungling and normalisation process.
71    
72    
73    
74    
75  =head1 FUNCTIONS  =head1 FUNCTIONS
76    
# Line 28  normalisation front-ends. Line 79  normalisation front-ends.
79  Create new normalisation object  Create new normalisation object
80    
81    my $n = new WebPAC::Normalize::Something(    my $n = new WebPAC::Normalize::Something(
82          cache_data_structure => './cache/ds/',          filter => {
83                    'filter_name_1' => sub {
84                            # filter code
85                            return length($_);
86                    }, ...
87            },
88            db => $db_obj,
89          lookup_regex => $lookup->regex,          lookup_regex => $lookup->regex,
90            lookup => $lookup_obj,
91            prefix => 'foobar',
92    );    );
93    
94  Optional parameter C<cache_data_structure> defines path to directory  Parametar C<filter> defines user supplied snippets of perl code which can
95  in which cache file for C<data_structure> call will be created.  be use with C<filter{...}> notation.
96    
97    C<prefix> is used to form filename for database record (to support multiple
98    source files which are joined in one database).
99    
100  Recommended parametar C<lookup_regex> is used to enable parsing of lookups  Recommended parametar C<lookup_regex> is used to enable parsing of lookups
101  in structures.  in structures. If you pass this parametar, you must also pass C<lookup>
102    which is C<WebPAC::Lookup> object.
103    
104  =cut  =cut
105    
# Line 45  sub new { Line 108  sub new {
108          my $self = {@_};          my $self = {@_};
109          bless($self, $class);          bless($self, $class);
110    
111          $self->setup_cache_dir( $self->{'cache_data_structure'} );          my $r = $self->{'lookup_regex'} ? 1 : 0;
112            my $l = $self->{'lookup'} ? 1 : 0;
         $self ? return $self : return undef;  
 }  
   
 =head2 setup_cache_dir  
   
 Check if specified cache directory exist, and if not, disable caching.  
   
  $setup_cache_dir('./cache/ds/');  
   
 If you pass false or zero value to this function, it will disable  
 cacheing.  
113    
114  =cut          my $log = $self->_get_logger();
115    
116  sub setup_cache_dir {          # those two must be in pair
117          my $self = shift;          if ( ($r & $l) != ($r || $l) ) {
118                    my $log = $self->_get_logger();
119                    $log->logdie("lookup_regex and lookup must be in pair");
120            }
121    
122          my $dir = shift;          $log->logdie("lookup must be WebPAC::Lookup object") if ($self->{'lookup'} && ! $self->{'lookup'}->isa('WebPAC::Lookup'));
123    
124          my $log = $self->_get_logger();          $log->warn("no prefix defined. please check that!") unless ($self->{'prefix'});
125    
126          if ($dir) {          $log->debug("using lookup regex: ", $self->{lookup_regex}) if ($r && $l);
                 my $msg;  
                 if (! -e $dir) {  
                         $msg = "doesn't exist";  
                 } elsif (! -d $dir) {  
                         $msg = "is not directory";  
                 } elsif (! -w $dir) {  
                         $msg = "not writable";  
                 }  
127    
128                  if ($msg) {          if (! $self->{filter} || ! $self->{filter}->{regex}) {
129                          undef $self->{'cache_data_structure'};                  $log->debug("adding built-in filter regex");
130                          $log->warn("cache_data_structure $dir $msg, disabling...");                  $self->{filter}->{regex} = sub {
131                  } else {                          my ($val, $regex) = @_;
132                          $log->debug("using cache dir $dir");                          eval "\$val =~ $regex";
133                  }                          return $val;
134          } else {                  };
                 $log->debug("disabling cache");  
                 undef $self->{'cache_data_structure'};  
135          }          }
136    
137            $self ? return $self : return undef;
138  }  }
139    
140    
# Line 98  C<conf/normalize/*.xml>. Line 145  C<conf/normalize/*.xml>.
145    
146  This structures are used to produce output.  This structures are used to produce output.
147    
148   my @ds = $webpac->data_structure($rec);   my $ds = $webpac->data_structure($rec);
   
 B<Note: historical oddity follows>  
   
 This method will also set C<< $webpac->{'currnet_filename'} >> if there is  
 C<< <filename> >> tag and C<< $webpac->{'headline'} >> if there is  
 C<< <headline> >> tag.  
149    
150  =cut  =cut
151    
# Line 116  sub data_structure { Line 157  sub data_structure {
157          my $rec = shift;          my $rec = shift;
158          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
159    
160            $log->debug("data_structure rec = ", sub { Dumper($rec) });
161    
162            $log->logdie("need unique ID (mfn) in field 000 of record " . Dumper($rec) ) unless (defined($rec->{'000'}));
163    
164            my $id = $rec->{'000'}->[0] || $log->logdie("field 000 isn't array!");
165    
166          my $cache_file;          my $cache_file;
167    
168          if (my $cache_path = $self->{'cache_data_structure'}) {          if ($self->{'db'}) {
169                  my $id = $rec->{'000'};                  my $ds = $self->{'db'}->load_ds( id => $id, prefix => $self->{prefix} );
170                  $id = $rec->{'000'}->[0] if ($id =~ m/^ARRAY/o);                  $log->debug("load_ds( rec = ", sub { Dumper($rec) }, ") = ", sub { Dumper($ds) });
171                  unless (defined($id)) {                  return $ds if ($ds);
172                          $log->warn("Can't use cache_data_structure on records without unique identifier in field 000");                  $log->debug("cache miss, creating");
                         undef $self->{'cache_data_structure'};  
                 } else {  
                         $cache_file = "$cache_path/$id";  
                         if (-r $cache_file) {  
                                 my $ds_ref = retrieve($cache_file);  
                                 if ($ds_ref) {  
                                         $log->debug("cache hit: $cache_file");  
                                         my $ok = 1;  
                                         foreach my $f (qw(current_filename headline)) {  
                                                 if ($ds_ref->{$f}) {  
                                                         $self->{$f} = $ds_ref->{$f};  
                                                 } else {  
                                                         $ok = 0;  
                                                 }  
                                         };  
                                         if ($ok && $ds_ref->{'ds'}) {  
                                                 return @{ $ds_ref->{'ds'} };  
                                         } else {  
                                                 $log->warn("cache_data_structure $cache_path corrupt. Use rm $cache_path/* to re-create it on next run!");  
                                                 undef $self->{'cache_data_structure'};  
                                         }  
                                 }  
                         }  
                 }  
173          }          }
174    
         undef $self->{'currnet_filename'};  
         undef $self->{'headline'};  
   
175          my @sorted_tags;          my @sorted_tags;
176          if ($self->{tags_by_order}) {          if ($self->{tags_by_order}) {
177                  @sorted_tags = @{$self->{tags_by_order}};                  @sorted_tags = @{$self->{tags_by_order}};
# Line 160  sub data_structure { Line 180  sub data_structure {
180                  $self->{tags_by_order} = \@sorted_tags;                  $self->{tags_by_order} = \@sorted_tags;
181          }          }
182    
183          my @ds;          my $ds;
184    
185          $log->debug("tags: ",sub { join(", ",@sorted_tags) });          $log->debug("tags: ",sub { join(", ",@sorted_tags) });
186    
# Line 171  sub data_structure { Line 191  sub data_structure {
191  #print "field $field [",$self->{'tag'},"] = ",Dumper($self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}});  #print "field $field [",$self->{'tag'},"] = ",Dumper($self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}});
192    
193                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {
194                          my $format = $tag->{'value'} || $tag->{'content'};                          my $format;
195    
196                          $log->debug("format: $format");                          $log->logdie("expected tag HASH and got $tag") unless (ref($tag) eq 'HASH');
197                            $format = $tag->{'value'} || $tag->{'content'};
198    
199                          my @v;                          my @v;
200                          if ($self->{'lookup_regex'} && $format =~ $self->{'lookup_regex'}) {                          if ($self->{'lookup_regex'} && $format =~ $self->{'lookup_regex'}) {
201                                  @v = $self->fill_in_to_arr($rec,$format);                                  @v = $self->_rec_to_arr($rec,$format,'fill_in');
202                          } else {                          } else {
203                                  @v = $self->parse_to_arr($rec,$format);                                  @v = $self->_rec_to_arr($rec,$format,'parse');
204                            }
205                            if (! @v) {
206                                    $log->debug("$field <",$self->{tag},"> format: $format no values");
207                                    next;
208                            } else {
209                                    $log->debug("$field <",$self->{tag},"> format: $format values: ", join(",", @v));
210                          }                          }
                         next if (! @v);  
211    
212                          if ($tag->{'sort'}) {                          if ($tag->{'sort'}) {
213                                  @v = $self->sort_arr(@v);                                  @v = $self->sort_arr(@v);
# Line 192  sub data_structure { Line 218  sub data_structure {
218                                  @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;                                  @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;
219                          }                          }
220    
                         if ($field eq 'filename') {  
                                 $self->{'current_filename'} = join('',@v);  
                                 $log->debug("filename: ",$self->{'current_filename'});  
                         } elsif ($field eq 'headline') {  
                                 $self->{'headline'} .= join('',@v);  
                                 $log->debug("headline: ",$self->{'headline'});  
                                 next; # don't return headline in data_structure!  
                         }  
   
221                          # delimiter will join repeatable fields                          # delimiter will join repeatable fields
222                          if ($tag->{'delimiter'}) {                          if ($tag->{'delimiter'}) {
223                                  @v = ( join($tag->{'delimiter'}, @v) );                                  @v = ( join($tag->{'delimiter'}, @v) );
224                          }                          }
225    
226                          # default types                          # default types
227                          my @types = qw(display swish);                          my @types = qw(display search);
228                          # override by type attribute                          # override by type attribute
229                          @types = ( $tag->{'type'} ) if ($tag->{'type'});                          @types = ( $tag->{'type'} ) if ($tag->{'type'});
230    
231                          foreach my $type (@types) {                          foreach my $type (@types) {
232                                  # append to previous line?                                  # append to previous line?
233                                  $log->debug("type: $type ",sub { join(" ",@v) }, $row->{'append'} || 'no append');                                  $log->debug("tag $field / $type [",sub { join(",",@v) }, "] ", $row->{'append'} || 'no append');
234                                  if ($tag->{'append'}) {                                  if ($tag->{'append'}) {
235    
236                                          # I will delimit appended part with                                          # I will delimit appended part with
# Line 240  sub data_structure { Line 257  sub data_structure {
257    
258                          # TODO: name_sigular, name_plural                          # TODO: name_sigular, name_plural
259                          my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};                          my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
260                          $row->{'name'} = $name ? $self->_x($name) : $field;                          my $row_name = $name ? $self->_x($name) : $field;
261    
262                          # post-sort all values in field                          # post-sort all values in field
263                          if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {                          if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {
264                                  $log->warn("sort at field tag not implemented");                                  $log->warn("sort at field tag not implemented");
265                          }                          }
266    
267                          push @ds, $row;                          $ds->{$row_name} = $row;
268    
269                          $log->debug("row $field: ",sub { Dumper($row) });                          $log->debug("row $field: ",sub { Dumper($row) });
270                  }                  }
271    
272          }          }
273    
274          if ($cache_file) {          $self->{'db'}->save_ds(
275                  store {                  id => $id,
276                          ds => \@ds,                  ds => $ds,
277                          current_filename => $self->{'current_filename'},                  prefix => $self->{prefix},
278                          headline => $self->{'headline'},          ) if ($self->{'db'});
                 }, $cache_file;  
                 $log->debug("created storable cache file $cache_file");  
         }  
   
         return @ds;  
   
 }  
   
 =head2 apply_format  
   
 Apply format specified in tag with C<format_name="name"> and  
 C<format_delimiter=";;">.  
   
  my $text = $webpac->apply_format($format_name,$format_delimiter,$data);  
   
 Formats can contain C<lookup{...}> if you need them.  
   
 =cut  
   
 sub apply_format {  
         my $self = shift;  
   
         my ($name,$delimiter,$data) = @_;  
   
         my $log = $self->_get_logger();  
   
         if (! $self->{'import_xml'}->{'format'}->{$name}) {  
                 $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});  
                 return $data;  
         }  
   
         $log->warn("no delimiter for format $name") if (! $delimiter);  
279    
280          my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");          $log->debug("ds: ", sub { Dumper($ds) });
281    
282          my @data = split(/\Q$delimiter\E/, $data);          $log->logconfess("data structure returned is not array any more!") if wantarray;
283    
284          my $out = sprintf($format, @data);          return $ds;
         $log->debug("using format $name [$format] on $data to produce: $out");  
   
         if ($self->{'lookup_regex'} && $out =~ $self->{'lookup_regex'}) {  
                 return $self->lookup($out);  
         } else {  
                 return $out;  
         }  
285    
286  }  }
287    
# Line 315  return output or nothing depending on ev Line 293  return output or nothing depending on ev
293    
294   my $text = $webpac->parse($rec,'eval{"v901^a" eq "Deskriptor"}descriptor: v250^a', $i);   my $text = $webpac->parse($rec,'eval{"v901^a" eq "Deskriptor"}descriptor: v250^a', $i);
295    
296    Filters are implemented here. While simple form of filters looks like this:
297    
298      filter{name_of_filter}
299    
300    but, filters can also have variable number of parametars like this:
301    
302      filter{name_of_filter(param,param,param)}
303    
304  =cut  =cut
305    
306    my $warn_once;
307    
308  sub parse {  sub parse {
309          my $self = shift;          my $self = shift;
310    
311          my ($rec, $format_utf8, $i) = @_;          my ($rec, $format_utf8, $i, $rec_size) = @_;
312    
313          return if (! $format_utf8);          return if (! $format_utf8);
314    
# Line 334  sub parse { Line 322  sub parse {
322    
323          my @out;          my @out;
324    
325          $log->debug("format: $format");          $log->debug("format: $format [$i]");
326    
327          my $eval_code;          my $eval_code;
328          # remove eval{...} from beginning          # remove eval{...} from beginning
# Line 344  sub parse { Line 332  sub parse {
332          # remove filter{...} from beginning          # remove filter{...} from beginning
333          $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);          $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
334    
335            # did we found any (att all) field from format in row?
336            my $found_any;
337            # prefix before first field which we preserve it $found_any
338          my $prefix;          my $prefix;
339          my $all_found=0;  
340            my $f_step = 1;
341    
342          while ($format =~ s/^(.*?)(v|s)(\d+)(?:\^(\w))?//s) {          while ($format =~ s/^(.*?)(v|s)(\d+)(?:\^(\w))?//s) {
343    
344                  my $del = $1 || '';                  my $del = $1 || '';
345                  $prefix ||= $del if ($all_found == 0);                  $prefix = $del if ($f_step == 1);
346    
347                    my $fld_type = lc($2);
348    
349                  # repeatable index                  # repeatable index
350                  my $r = $i;                  my $r = $i;
351                  $r = 0 if (lc("$2") eq 's');                  if ($fld_type eq 's') {
352                            if ($found_any->{'v'}) {
353                                    $r = 0;
354                            } else {
355                                    return;
356                            }
357                    }
358    
359                  my $found = 0;                  my $found = 0;
360                  my $tmp = $self->get_data(\$rec,$3,$4,$r,\$found);                  my $tmp = $self->get_data(\$rec,$3,$4,$r,\$found,$rec_size);
361    
362                  if ($found) {                  if ($found) {
363                          push @out, $del;                          $found_any->{$fld_type} += $found;
364    
365                            # we will skip delimiter before first occurence of field!
366                            push @out, $del unless($found_any->{$fld_type} == 1);
367                          push @out, $tmp;                          push @out, $tmp;
                         $all_found += $found;  
368                  }                  }
369                    $f_step++;
370          }          }
371    
372          return if (! $all_found);          # test if any fields found?
373            return if (! $found_any->{'v'} && ! $found_any->{'s'});
374    
375          my $out = join('',@out);          my $out = join('',@out);
376    
# Line 386  sub parse { Line 390  sub parse {
390                  return if (! $self->_eval($eval));                  return if (! $self->_eval($eval));
391          }          }
392                    
393          if ($filter_name && $self->{'filter'}->{$filter_name}) {          if ($filter_name) {
394                  $log->debug("about to filter{$filter_name} format: $out");                  my @filter_args;
395                  $out = $self->{'filter'}->{$filter_name}->($out);                  if ($filter_name =~ s/(\w+)\((.*)\)/$1/) {
396                  return unless(defined($out));                          @filter_args = split(/,/, $2);
397                  $log->debug("filter result: $out");                  }
398                    if ($self->{'filter'}->{$filter_name}) {
399                            $log->debug("about to filter{$filter_name} format: $out with arguments: ", join(",", @filter_args));
400                            unshift @filter_args, $out;
401                            $out = $self->{'filter'}->{$filter_name}->(@filter_args);
402                            return unless(defined($out));
403                            $log->debug("filter result: $out");
404                    } elsif (! $warn_once->{$filter_name}) {
405                            $log->warn("trying to use undefined filter $filter_name");
406                            $warn_once->{$filter_name}++;
407                    }
408          }          }
409    
410          return $out;          return $out;
411  }  }
412    
413  =head2 parse_to_arr  =head2 fill_in
414    
415    Workhourse of all: takes record from in-memory structure of database and
416    strings with placeholders and returns string or array of with substituted
417    values from record.
418    
419     my $text = $webpac->fill_in($rec,'v250^a');
420    
421  Similar to C<parse>, but returns array of all repeatable fields  Optional argument is ordinal number for repeatable fields. By default,
422    it's assume to be first repeatable field (fields are perl array, so first
423    element is 0).
424    Following example will read second value from repeatable field.
425    
426   my @arr = $webpac->parse_to_arr($rec,'v250^a');   my $text = $webpac->fill_in($rec,'Title: v250^a',1);
427    
428    This function B<does not> perform parsing of format to inteligenty skip
429    delimiters before fields which aren't used.
430    
431    This method will automatically decode UTF-8 string to local code page
432    if needed.
433    
434    There is optional parametar C<$record_size> which can be used to get sizes of
435    all C<field^subfield> combinations in this format.
436    
437     my $text = $webpac->fill_in($rec,'got: v900^a v900^x',0,\$rec_size);
438    
439  =cut  =cut
440    
441  sub parse_to_arr {  sub fill_in {
442          my $self = shift;          my $self = shift;
443    
         my ($rec, $format_utf8) = @_;  
   
444          my $log = $self->_get_logger();          my $log = $self->_get_logger();
445    
446          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          my ($rec,$format,$i,$rec_size) = @_;
         return if (! $format_utf8);  
447    
448          my $i = 0;          $log->logconfess("need data record") unless ($rec);
449          my @arr;          $log->logconfess("need format to parse") unless($format);
450    
451            # iteration (for repeatable fields)
452            $i ||= 0;
453    
454            $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));
455    
456          while (my $v = $self->parse($rec,$format_utf8,$i++)) {          # FIXME remove for speedup?
457                  push @arr, $v;          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
458    
459            if (utf8::is_utf8($format)) {
460                    $format = $self->_x($format);
461          }          }
462    
463          $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);          my $found = 0;
464            my $just_single = 1;
465    
466          return @arr;          my $eval_code;
467            # remove eval{...} from beginning
468            $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
469    
470            my $filter_name;
471            # remove filter{...} from beginning
472            $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
473    
474            {
475                    # fix warnings
476                    no warnings 'uninitialized';
477    
478                    # do actual replacement of placeholders
479                    # repeatable fields
480                    if ($format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found,$rec_size)/ges) {
481                            $just_single = 0;
482                    }
483    
484                    # non-repeatable fields
485                    if ($format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found,$rec_size)/ges) {
486                            return if ($i > 0 && $just_single);
487                    }
488            }
489    
490            if ($found) {
491                    $log->debug("format: $format");
492                    if ($eval_code) {
493                            my $eval = $self->fill_in($rec,$eval_code,$i);
494                            return if (! $self->_eval($eval));
495                    }
496                    if ($filter_name && $self->{'filter'}->{$filter_name}) {
497                            $log->debug("filter '$filter_name' for $format");
498                            $format = $self->{'filter'}->{$filter_name}->($format);
499                            return unless(defined($format));
500                            $log->debug("filter result: $format");
501                    }
502                    # do we have lookups?
503                    if ($self->{'lookup'}) {
504                            if ($self->{'lookup'}->can('lookup')) {
505                                    my @lookup = $self->{lookup}->lookup($format);
506                                    $log->debug("lookup $format", join(", ", @lookup));
507                                    return @lookup;
508                            } else {
509                                    $log->warn("Have lookup object but can't invoke lookup method");
510                            }
511                    } else {
512                            return $format;
513                    }
514            } else {
515                    return;
516            }
517  }  }
518    
 =head2 fill_in_to_arr  
519    
520  Similar to C<fill_in>, but returns array of all repeatable fields. Usable  =head2 _rec_to_arr
521    
522    Similar to C<parse> and C<fill_in>, but returns array of all repeatable fields. Usable
523  for fields which have lookups, so they shouldn't be parsed but rather  for fields which have lookups, so they shouldn't be parsed but rather
524  C<fill_id>ed.  C<paste>d or C<fill_id>ed. Last argument is name of operation: C<paste> or C<fill_in>.
525    
526   my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]');   my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]','paste');
527    
528  =cut  =cut
529    
530  sub fill_in_to_arr {  sub _rec_to_arr {
531          my $self = shift;          my $self = shift;
532    
533          my ($rec, $format_utf8) = @_;          my ($rec, $format_utf8, $code) = @_;
534    
535          my $log = $self->_get_logger();          my $log = $self->_get_logger();
536    
537          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
538          return if (! $format_utf8);          return if (! $format_utf8);
539    
540            $log->debug("using $code on $format_utf8");
541    
542          my $i = 0;          my $i = 0;
543            my $max = 0;
544          my @arr;          my @arr;
545            my $rec_size = {};
546    
547          while (my @v = $self->fill_in($rec,$format_utf8,$i++)) {          while ($i <= $max) {
548                  push @arr, @v;                  my @v = $self->$code($rec,$format_utf8,$i++,\$rec_size);
549                    if ($rec_size) {
550                            foreach my $f (keys %{ $rec_size }) {
551                                    $max = $rec_size->{$f} if ($rec_size->{$f} > $max);
552                            }
553                            $log->debug("max set to $max");
554                            undef $rec_size;
555                    }
556                    if (@v) {
557                            push @arr, @v;
558                    } else {
559                            push @arr, '' if ($max > $i);
560                    }
561          }          }
562    
563          $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);          $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
# Line 458  sub fill_in_to_arr { Line 565  sub fill_in_to_arr {
565          return @arr;          return @arr;
566  }  }
567    
568    
569    =head2 get_data
570    
571    Returns value from record.
572    
573     my $text = $self->get_data(\$rec,$f,$sf,$i,\$found,\$rec_size);
574    
575    Required arguments are:
576    
577    =over 8
578    
579    =item C<$rec>
580    
581    record reference
582    
583    =item C<$f>
584    
585    field
586    
587    =item C<$sf>
588    
589    optional subfield
590    
591    =item C<$i>
592    
593    index offset for repeatable values ( 0 ... $rec_size->{'400^a'} )
594    
595    =item C<$found>
596    
597    optional variable that will be incremeted if preset
598    
599    =item C<$rec_size>
600    
601    hash to hold maximum occurances of C<field^subfield> combinations
602    (which can be accessed using keys in same format)
603    
604    =back
605    
606    Returns value or empty string, updates C<$found> and C<rec_size>
607    if present.
608    
609    =cut
610    
611    sub get_data {
612            my $self = shift;
613    
614            my ($rec,$f,$sf,$i,$found,$cache) = @_;
615    
616            return '' unless ($$rec->{$f} && ref($$rec->{$f}) eq 'ARRAY');
617    
618            if (defined($$cache)) {
619                    $$cache->{ $f . ( $sf ? '^' . $sf : '' ) } ||= scalar @{ $$rec->{$f} };
620            }
621    
622            return '' unless ($$rec->{$f}->[$i]);
623    
624            {
625                    no strict 'refs';
626                    if (defined($sf)) {
627                            $$found++ if (defined($$found) && $$rec->{$f}->[$i]->{$sf});
628                            return $$rec->{$f}->[$i]->{$sf};
629                    } else {
630                            $$found++ if (defined($$found));
631                            # it still might have subfields, just
632                            # not specified, so we'll dump some debug info
633                            if ($$rec->{$f}->[$i] =~ /HASH/o) {
634                                    my $out;
635                                    foreach my $k (keys %{$$rec->{$f}->[$i]}) {
636                                            $out .= '$' . $k .':' . $$rec->{$f}->[$i]->{$k}." ";
637                                    }
638                                    return $out;
639                            } else {
640                                    return $$rec->{$f}->[$i];
641                            }
642                    }
643            }
644    }
645    
646    
647    =head2 apply_format
648    
649    Apply format specified in tag with C<format_name="name"> and
650    C<format_delimiter=";;">.
651    
652     my $text = $webpac->apply_format($format_name,$format_delimiter,$data);
653    
654    Formats can contain C<lookup{...}> if you need them.
655    
656    =cut
657    
658    sub apply_format {
659            my $self = shift;
660    
661            my ($name,$delimiter,$data) = @_;
662    
663            my $log = $self->_get_logger();
664    
665            if (! $self->{'import_xml'}->{'format'}->{$name}) {
666                    $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});
667                    return $data;
668            }
669    
670            $log->warn("no delimiter for format $name") if (! $delimiter);
671    
672            my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");
673    
674            my @data = split(/\Q$delimiter\E/, $data);
675    
676            my $out = sprintf($format, @data);
677            $log->debug("using format $name [$format] on $data to produce: $out");
678    
679            if ($self->{'lookup_regex'} && $out =~ $self->{'lookup_regex'}) {
680                    return $self->{'lookup'}->lookup($out);
681            } else {
682                    return $out;
683            }
684    
685    }
686    
687  =head2 sort_arr  =head2 sort_arr
688    
689  Sort array ignoring case and html in data  Sort array ignoring case and html in data
# Line 484  sub sort_arr { Line 710  sub sort_arr {
710  }  }
711    
712    
713    =head1 INTERNAL METHODS
714    
715  =head2 _sort_by_order  =head2 _sort_by_order
716    
717  Sort xml tags data structure accoding to C<order=""> attribute.  Sort xml tags data structure accoding to C<order=""> attribute.
# Line 503  sub _sort_by_order { Line 731  sub _sort_by_order {
731    
732  =head2 _x  =head2 _x
733    
734  Convert strings from C<conf/normalize> encoding into application specific  Convert strings from C<conf/normalize/*.xml> encoding into application
735  (optinally specified using C<code_page> to C<new> constructor.  specific encoding (optinally specified using C<code_page> to C<new>
736    constructor).
737    
738   my $text = $n->_x('normalize text string');   my $text = $n->_x('normalize text string');
739    
# Line 531  under the same terms as Perl itself. Line 760  under the same terms as Perl itself.
760    
761  =cut  =cut
762    
763  1; # End of WebPAC::DB  1; # End of WebPAC::Normalize

Legend:
Removed from v.13  
changed lines
  Added in v.397

  ViewVC Help
Powered by ViewVC 1.1.26