/[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 436 by dpavlin, Sun Apr 30 12:17:19 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.09
17    
18  =cut  =cut
19    
20  our $VERSION = '0.01';  our $VERSION = '0.09';
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;
113    
114            my $log = $self->_get_logger();
115    
116            # those two must be in pair
117            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            $log->logdie("lookup must be WebPAC::Lookup object") if ($self->{'lookup'} && ! $self->{'lookup'}->isa('WebPAC::Lookup'));
123    
124            $log->warn("no prefix defined. please check that!") unless ($self->{'prefix'});
125    
126            $log->debug("using lookup regex: ", $self->{lookup_regex}) if ($r && $l);
127    
128            if (! $self->{filter} || ! $self->{filter}->{regex}) {
129                    $log->debug("adding built-in filter regex");
130                    $self->{filter}->{regex} = sub {
131                            my ($val, $regex) = @_;
132                            eval "\$val =~ $regex";
133                            return $val;
134                    };
135            }
136    
137          $self ? return $self : return undef;          $self ? return $self : return undef;
138  }  }
139    
140  =head2 setup_cache_dir  =head2 all_tags
141    
142  Check if specified cache directory exist, and if not, disable caching.  Returns all tags in document in specified order
143    
144   $setup_cache_dir('./cache/ds/');    my $sorted_tags = $self->all_tags();
   
 If you pass false or zero value to this function, it will disable  
 cacheing.  
145    
146  =cut  =cut
147    
148  sub setup_cache_dir {  sub all_tags {
149          my $self = shift;          my $self = shift;
150    
151          my $dir = shift;          if (! $self->{_tags_by_order}) {
152    
153          my $log = $self->_get_logger();                  my $log = $self->_get_logger;
154                    # sanity check
155                    $log->logdie("can't find self->{inport_xml}->{indexer}") unless ($self->{import_xml}->{indexer});
156    
157          if ($dir) {                  my @tags = keys %{ $self->{'import_xml'}->{'indexer'}};
158                  my $msg;                  $log->debug("unsorted tags: " . join(", ", @tags));
                 if (! -e $dir) {  
                         $msg = "doesn't exist";  
                 } elsif (! -d $dir) {  
                         $msg = "is not directory";  
                 } elsif (! -w $dir) {  
                         $msg = "not writable";  
                 }  
159    
160                  if ($msg) {                  @tags = sort { $self->_sort_by_order } @tags;
161                          undef $self->{'cache_data_structure'};  
162                          $log->warn("cache_data_structure $dir $msg, disabling...");                  $log->debug("sorted tags: " . join(",", @tags) );
163                  } else {  
164                          $log->debug("using cache dir $dir");                  $self->{_tags_by_order} = \@tags;
                 }  
         } else {  
                 $log->debug("disabling cache");  
                 undef $self->{'cache_data_structure'};  
165          }          }
166    
167            return $self->{_tags_by_order};
168  }  }
169    
170    
171    
172  =head2 data_structure  =head2 data_structure
173    
174  Create in-memory data structure which represents normalized layout from  Create in-memory data structure which represents normalized layout from
# Line 98  C<conf/normalize/*.xml>. Line 176  C<conf/normalize/*.xml>.
176    
177  This structures are used to produce output.  This structures are used to produce output.
178    
179   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.  
180    
181  =cut  =cut
182    
# Line 116  sub data_structure { Line 188  sub data_structure {
188          my $rec = shift;          my $rec = shift;
189          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
190    
191          my $cache_file;          $log->debug("data_structure rec = ", sub { Dumper($rec) });
192    
193          if (my $cache_path = $self->{'cache_data_structure'}) {          $log->logdie("need unique ID (mfn) in field 000 of record " . Dumper($rec) ) unless (defined($rec->{'000'}));
                 my $id = $rec->{'000'};  
                 $id = $rec->{'000'}->[0] if ($id =~ m/^ARRAY/o);  
                 unless (defined($id)) {  
                         $log->warn("Can't use cache_data_structure on records without unique identifier in field 000");  
                         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'};  
                                         }  
                                 }  
                         }  
                 }  
         }  
194    
195          undef $self->{'currnet_filename'};          my $id = $rec->{'000'}->[0] || $log->logdie("field 000 isn't array!");
         undef $self->{'headline'};  
196    
197          my @sorted_tags;          my $cache_file;
198          if ($self->{tags_by_order}) {  
199                  @sorted_tags = @{$self->{tags_by_order}};          if ($self->{'db'}) {
200          } else {                  my $ds = $self->{'db'}->load_ds( id => $id, prefix => $self->{prefix} );
201                  @sorted_tags = sort { $self->_sort_by_order } keys %{$self->{'import_xml'}->{'indexer'}};                  $log->debug("load_ds( rec = ", sub { Dumper($rec) }, ") = ", sub { Dumper($ds) });
202                  $self->{tags_by_order} = \@sorted_tags;                  return $ds if ($ds);
203                    $log->debug("cache miss, creating");
204          }          }
205    
206          my @ds;          my $tags = $self->all_tags();
207    
208            $log->debug("tags: ",sub { join(", ",@{ $tags }) });
209    
210          $log->debug("tags: ",sub { join(", ",@sorted_tags) });          my $ds;
211    
212          foreach my $field (@sorted_tags) {          foreach my $field (@{ $tags }) {
213    
214                  my $row;                  my $row;
215    
216  #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'}});
217    
218                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {
219                          my $format = $tag->{'value'} || $tag->{'content'};                          my $format;
220    
221                          $log->debug("format: $format");                          $log->logdie("expected tag HASH and got $tag") unless (ref($tag) eq 'HASH');
222                            $format = $tag->{'value'} || $tag->{'content'};
223    
224                          my @v;                          my @v;
225                          if ($self->{'lookup_regex'} && $format =~ $self->{'lookup_regex'}) {                          if ($self->{'lookup_regex'} && $format =~ $self->{'lookup_regex'}) {
226                                  @v = $self->fill_in_to_arr($rec,$format);                                  @v = $self->_rec_to_arr($rec,$format,'fill_in');
227                            } else {
228                                    @v = $self->_rec_to_arr($rec,$format,'parse');
229                            }
230                            if (! @v) {
231                                    $log->debug("$field <",$self->{tag},"> format: $format no values");
232                                    next;
233                          } else {                          } else {
234                                  @v = $self->parse_to_arr($rec,$format);                                  $log->debug("$field <",$self->{tag},"> format: $format values: ", join(",", @v));
235                          }                          }
                         next if (! @v);  
236    
237                          if ($tag->{'sort'}) {                          if ($tag->{'sort'}) {
238                                  @v = $self->sort_arr(@v);                                  @v = $self->sort_arr(@v);
# Line 192  sub data_structure { Line 243  sub data_structure {
243                                  @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;                                  @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;
244                          }                          }
245    
                         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!  
                         }  
   
246                          # delimiter will join repeatable fields                          # delimiter will join repeatable fields
247                          if ($tag->{'delimiter'}) {                          if ($tag->{'delimiter'}) {
248                                  @v = ( join($tag->{'delimiter'}, @v) );                                  @v = ( join($tag->{'delimiter'}, @v) );
249                          }                          }
250    
251                          # default types                          # default types
252                          my @types = qw(display swish);                          my @types = qw(display search);
253                          # override by type attribute                          # override by type attribute
254                          @types = ( $tag->{'type'} ) if ($tag->{'type'});                          @types = ( $tag->{'type'} ) if ($tag->{'type'});
255    
256                          foreach my $type (@types) {                          foreach my $type (@types) {
257                                  # append to previous line?                                  # append to previous line?
258                                  $log->debug("type: $type ",sub { join(" ",@v) }, $row->{'append'} || 'no append');                                  $log->debug("tag $field / $type [",sub { join(",",@v) }, "] ", $row->{'append'} || 'no append');
259                                  if ($tag->{'append'}) {                                  if ($tag->{'append'}) {
260    
261                                          # I will delimit appended part with                                          # I will delimit appended part with
# Line 240  sub data_structure { Line 282  sub data_structure {
282    
283                          # TODO: name_sigular, name_plural                          # TODO: name_sigular, name_plural
284                          my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};                          my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
285                          $row->{'name'} = $name ? $self->_x($name) : $field;                          my $row_name = $name ? $self->_x($name) : $field;
286    
287                          # post-sort all values in field                          # post-sort all values in field
288                          if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {                          if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {
289                                  $log->warn("sort at field tag not implemented");                                  $log->warn("sort at field tag not implemented");
290                          }                          }
291    
292                          push @ds, $row;                          $ds->{$row_name} = $row;
293    
294                          $log->debug("row $field: ",sub { Dumper($row) });                          $log->debug("row $field: ",sub { Dumper($row) });
295                  }                  }
296    
297          }          }
298    
299          if ($cache_file) {          $self->{'db'}->save_ds(
300                  store {                  id => $id,
301                          ds => \@ds,                  ds => $ds,
302                          current_filename => $self->{'current_filename'},                  prefix => $self->{prefix},
303                          headline => $self->{'headline'},          ) if ($self->{'db'});
                 }, $cache_file;  
                 $log->debug("created storable cache file $cache_file");  
         }  
304    
305          return @ds;          $log->debug("ds: ", sub { Dumper($ds) });
306    
307  }          $log->logconfess("data structure returned is not array any more!") if wantarray;
   
 =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;  
308    
309          my ($name,$delimiter,$data) = @_;          return $ds;
   
         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);  
   
         my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");  
   
         my @data = split(/\Q$delimiter\E/, $data);  
   
         my $out = sprintf($format, @data);  
         $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;  
         }  
310    
311  }  }
312    
# Line 315  return output or nothing depending on ev Line 318  return output or nothing depending on ev
318    
319   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);
320    
321    Filters are implemented here. While simple form of filters looks like this:
322    
323      filter{name_of_filter}
324    
325    but, filters can also have variable number of parametars like this:
326    
327      filter{name_of_filter(param,param,param)}
328    
329  =cut  =cut
330    
331    my $warn_once;
332    
333  sub parse {  sub parse {
334          my $self = shift;          my $self = shift;
335    
336          my ($rec, $format_utf8, $i) = @_;          my ($rec, $format_utf8, $i, $rec_size) = @_;
337    
338          return if (! $format_utf8);          return if (! $format_utf8);
339    
# Line 334  sub parse { Line 347  sub parse {
347    
348          my @out;          my @out;
349    
350          $log->debug("format: $format");          $log->debug("format: $format [$i]");
351    
352          my $eval_code;          my $eval_code;
353          # remove eval{...} from beginning          # remove eval{...} from beginning
# Line 344  sub parse { Line 357  sub parse {
357          # remove filter{...} from beginning          # remove filter{...} from beginning
358          $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);          $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
359    
360            # did we found any (att all) field from format in row?
361            my $found_any;
362            # prefix before first field which we preserve it $found_any
363          my $prefix;          my $prefix;
364          my $all_found=0;  
365            my $f_step = 1;
366    
367          while ($format =~ s/^(.*?)(v|s)(\d+)(?:\^(\w))?//s) {          while ($format =~ s/^(.*?)(v|s)(\d+)(?:\^(\w))?//s) {
368    
369                  my $del = $1 || '';                  my $del = $1 || '';
370                  $prefix ||= $del if ($all_found == 0);                  $prefix = $del if ($f_step == 1);
371    
372                    my $fld_type = lc($2);
373    
374                  # repeatable index                  # repeatable index
375                  my $r = $i;                  my $r = $i;
376                  $r = 0 if (lc("$2") eq 's');                  if ($fld_type eq 's') {
377                            if ($found_any->{'v'}) {
378                                    $r = 0;
379                            } else {
380                                    return;
381                            }
382                    }
383    
384                  my $found = 0;                  my $found = 0;
385                  my $tmp = $self->get_data(\$rec,$3,$4,$r,\$found);                  my $tmp = $self->get_data(\$rec,$3,$4,$r,\$found,$rec_size);
386    
387                  if ($found) {                  if ($found) {
388                          push @out, $del;                          $found_any->{$fld_type} += $found;
389                          push @out, $tmp;  
390                          $all_found += $found;                          # we will skip delimiter before first occurence of field!
391                            push @out, $del unless($found_any->{$fld_type} == 1);
392                            push @out, $tmp if ($tmp);
393                  }                  }
394                    $f_step++;
395          }          }
396    
397          return if (! $all_found);          # test if any fields found?
398            return if (! $found_any->{'v'} && ! $found_any->{'s'});
399    
400          my $out = join('',@out);          my $out = join('',@out);
401    
# Line 386  sub parse { Line 415  sub parse {
415                  return if (! $self->_eval($eval));                  return if (! $self->_eval($eval));
416          }          }
417                    
418          if ($filter_name && $self->{'filter'}->{$filter_name}) {          if ($filter_name) {
419                  $log->debug("about to filter{$filter_name} format: $out");                  my @filter_args;
420                  $out = $self->{'filter'}->{$filter_name}->($out);                  if ($filter_name =~ s/(\w+)\((.*)\)/$1/) {
421                  return unless(defined($out));                          @filter_args = split(/,/, $2);
422                  $log->debug("filter result: $out");                  }
423                    if ($self->{'filter'}->{$filter_name}) {
424                            $log->debug("about to filter{$filter_name} format: $out with arguments: ", join(",", @filter_args));
425                            unshift @filter_args, $out;
426                            $out = $self->{'filter'}->{$filter_name}->(@filter_args);
427                            return unless(defined($out));
428                            $log->debug("filter result: $out");
429                    } elsif (! $warn_once->{$filter_name}) {
430                            $log->warn("trying to use undefined filter $filter_name");
431                            $warn_once->{$filter_name}++;
432                    }
433          }          }
434    
435          return $out;          return $out;
436  }  }
437    
438  =head2 parse_to_arr  =head2 fill_in
439    
440  Similar to C<parse>, but returns array of all repeatable fields  Workhourse of all: takes record from in-memory structure of database and
441    strings with placeholders and returns string or array of with substituted
442    values from record.
443    
444   my @arr = $webpac->parse_to_arr($rec,'v250^a');   my $text = $webpac->fill_in($rec,'v250^a');
445    
446    Optional argument is ordinal number for repeatable fields. By default,
447    it's assume to be first repeatable field (fields are perl array, so first
448    element is 0).
449    Following example will read second value from repeatable field.
450    
451     my $text = $webpac->fill_in($rec,'Title: v250^a',1);
452    
453    This function B<does not> perform parsing of format to inteligenty skip
454    delimiters before fields which aren't used.
455    
456    This method will automatically decode UTF-8 string to local code page
457    if needed.
458    
459    There is optional parametar C<$record_size> which can be used to get sizes of
460    all C<field^subfield> combinations in this format.
461    
462     my $text = $webpac->fill_in($rec,'got: v900^a v900^x',0,\$rec_size);
463    
464  =cut  =cut
465    
466  sub parse_to_arr {  sub fill_in {
467          my $self = shift;          my $self = shift;
468    
         my ($rec, $format_utf8) = @_;  
   
469          my $log = $self->_get_logger();          my $log = $self->_get_logger();
470    
471          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          my ($rec,$format,$i,$rec_size) = @_;
         return if (! $format_utf8);  
472    
473          my $i = 0;          $log->logconfess("need data record") unless ($rec);
474          my @arr;          $log->logconfess("need format to parse") unless($format);
475    
476            # iteration (for repeatable fields)
477            $i ||= 0;
478    
479            $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));
480    
481            # FIXME remove for speedup?
482            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
483    
484          while (my $v = $self->parse($rec,$format_utf8,$i++)) {          if (utf8::is_utf8($format)) {
485                  push @arr, $v;                  $format = $self->_x($format);
486          }          }
487    
488          $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);          my $found = 0;
489            my $just_single = 1;
490    
491          return @arr;          my $eval_code;
492            # remove eval{...} from beginning
493            $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
494    
495            my $filter_name;
496            # remove filter{...} from beginning
497            $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
498    
499            {
500                    # fix warnings
501                    no warnings 'uninitialized';
502    
503                    # do actual replacement of placeholders
504                    # repeatable fields
505                    if ($format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found,$rec_size)/ges) {
506                            $just_single = 0;
507                    }
508    
509                    # non-repeatable fields
510                    if ($format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found,$rec_size)/ges) {
511                            return if ($i > 0 && $just_single);
512                    }
513            }
514    
515            if ($found) {
516                    $log->debug("format: $format");
517                    if ($eval_code) {
518                            my $eval = $self->fill_in($rec,$eval_code,$i);
519                            return if (! $self->_eval($eval));
520                    }
521                    if ($filter_name && $self->{'filter'}->{$filter_name}) {
522                            $log->debug("filter '$filter_name' for $format");
523                            $format = $self->{'filter'}->{$filter_name}->($format);
524                            return unless(defined($format));
525                            $log->debug("filter result: $format");
526                    }
527                    # do we have lookups?
528                    if ($self->{'lookup'}) {
529                            if ($self->{'lookup'}->can('lookup')) {
530                                    my @lookup = $self->{lookup}->lookup($format);
531                                    $log->debug("lookup $format", join(", ", @lookup));
532                                    return @lookup;
533                            } else {
534                                    $log->warn("Have lookup object but can't invoke lookup method");
535                            }
536                    } else {
537                            return $format;
538                    }
539            } else {
540                    return;
541            }
542  }  }
543    
 =head2 fill_in_to_arr  
544    
545  Similar to C<fill_in>, but returns array of all repeatable fields. Usable  =head2 _rec_to_arr
546    
547    Similar to C<parse> and C<fill_in>, but returns array of all repeatable fields. Usable
548  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
549  C<fill_id>ed.  C<paste>d or C<fill_id>ed. Last argument is name of operation: C<paste> or C<fill_in>.
550    
551   my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]');   my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]','paste');
552    
553  =cut  =cut
554    
555  sub fill_in_to_arr {  sub _rec_to_arr {
556          my $self = shift;          my $self = shift;
557    
558          my ($rec, $format_utf8) = @_;          my ($rec, $format_utf8, $code) = @_;
559    
560          my $log = $self->_get_logger();          my $log = $self->_get_logger();
561    
562          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
563          return if (! $format_utf8);          return if (! $format_utf8);
564    
565            $log->debug("using $code on $format_utf8");
566    
567          my $i = 0;          my $i = 0;
568            my $max = 0;
569          my @arr;          my @arr;
570            my $rec_size = {};
571    
572          while (my @v = $self->fill_in($rec,$format_utf8,$i++)) {          while ($i <= $max) {
573                  push @arr, @v;                  my @v = $self->$code($rec,$format_utf8,$i++,\$rec_size);
574                    if ($rec_size) {
575                            foreach my $f (keys %{ $rec_size }) {
576                                    $max = $rec_size->{$f} if ($rec_size->{$f} > $max);
577                            }
578                            $log->debug("max set to $max");
579                            undef $rec_size;
580                    }
581                    if (@v) {
582                            push @arr, @v;
583                    } else {
584                            push @arr, '' if ($max > $i);
585                    }
586          }          }
587    
588          $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 590  sub fill_in_to_arr {
590          return @arr;          return @arr;
591  }  }
592    
593    
594    =head2 get_data
595    
596    Returns value from record.
597    
598     my $text = $self->get_data(\$rec,$f,$sf,$i,\$found,\$rec_size);
599    
600    Required arguments are:
601    
602    =over 8
603    
604    =item C<$rec>
605    
606    record reference
607    
608    =item C<$f>
609    
610    field
611    
612    =item C<$sf>
613    
614    optional subfield
615    
616    =item C<$i>
617    
618    index offset for repeatable values ( 0 ... $rec_size->{'400^a'} )
619    
620    =item C<$found>
621    
622    optional variable that will be incremeted if preset
623    
624    =item C<$rec_size>
625    
626    hash to hold maximum occurances of C<field^subfield> combinations
627    (which can be accessed using keys in same format)
628    
629    =back
630    
631    Returns value or empty string, updates C<$found> and C<rec_size>
632    if present.
633    
634    =cut
635    
636    sub get_data {
637            my $self = shift;
638    
639            my ($rec,$f,$sf,$i,$found,$cache) = @_;
640    
641            return '' unless ($$rec->{$f} && ref($$rec->{$f}) eq 'ARRAY');
642    
643            if (defined($$cache)) {
644                    $$cache->{ $f . ( $sf ? '^' . $sf : '' ) } ||= scalar @{ $$rec->{$f} };
645            }
646    
647            return '' unless ($$rec->{$f}->[$i]);
648    
649            {
650                    no strict 'refs';
651                    if (defined($sf)) {
652                            $$found++ if (defined($$found) && $$rec->{$f}->[$i]->{$sf});
653                            return $$rec->{$f}->[$i]->{$sf};
654                    } else {
655                            $$found++ if (defined($$found));
656                            # it still might have subfields, just
657                            # not specified, so we'll dump some debug info
658                            if ($$rec->{$f}->[$i] =~ /HASH/o) {
659                                    my $out;
660                                    foreach my $k (keys %{$$rec->{$f}->[$i]}) {
661                                            my $v = $$rec->{$f}->[$i]->{$k};
662                                            $out .= '$' . $k .':' . $v if ($v);
663                                    }
664                                    return $out;
665                            } else {
666                                    return $$rec->{$f}->[$i];
667                            }
668                    }
669            }
670    }
671    
672    
673    =head2 apply_format
674    
675    Apply format specified in tag with C<format_name="name"> and
676    C<format_delimiter=";;">.
677    
678     my $text = $webpac->apply_format($format_name,$format_delimiter,$data);
679    
680    Formats can contain C<lookup{...}> if you need them.
681    
682    =cut
683    
684    sub apply_format {
685            my $self = shift;
686    
687            my ($name,$delimiter,$data) = @_;
688    
689            my $log = $self->_get_logger();
690    
691            if (! $self->{'import_xml'}->{'format'}->{$name}) {
692                    $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});
693                    return $data;
694            }
695    
696            $log->warn("no delimiter for format $name") if (! $delimiter);
697    
698            my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");
699    
700            my @data = split(/\Q$delimiter\E/, $data);
701    
702            my $out = sprintf($format, @data);
703            $log->debug("using format $name [$format] on $data to produce: $out");
704    
705            if ($self->{'lookup_regex'} && $out =~ $self->{'lookup_regex'}) {
706                    return $self->{'lookup'}->lookup($out);
707            } else {
708                    return $out;
709            }
710    
711    }
712    
713  =head2 sort_arr  =head2 sort_arr
714    
715  Sort array ignoring case and html in data  Sort array ignoring case and html in data
# Line 484  sub sort_arr { Line 736  sub sort_arr {
736  }  }
737    
738    
739    =head1 INTERNAL METHODS
740    
741  =head2 _sort_by_order  =head2 _sort_by_order
742    
743  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 757  sub _sort_by_order {
757    
758  =head2 _x  =head2 _x
759    
760  Convert strings from C<conf/normalize> encoding into application specific  Convert strings from C<conf/normalize/*.xml> encoding into application
761  (optinally specified using C<code_page> to C<new> constructor.  specific encoding (optinally specified using C<code_page> to C<new>
762    constructor).
763    
764   my $text = $n->_x('normalize text string');   my $text = $n->_x('normalize text string');
765    
# Line 531  under the same terms as Perl itself. Line 786  under the same terms as Perl itself.
786    
787  =cut  =cut
788    
789  1; # End of WebPAC::DB  1; # End of WebPAC::Normalize
Legend:
Removed from v.13  
changed lines
  Added in v.436
  ViewVC Help
Powered by ViewVC 1.1.26