/[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 436 by dpavlin, Sun Apr 30 12:17:19 2006 UTC revision 1364 by dpavlin, Thu Apr 21 17:10:04 2011 UTC
# Line 1  Line 1 
1  package WebPAC::Normalize;  package WebPAC::Normalize;
2    use Exporter 'import';
3    our @EXPORT = qw/
4            _set_ds _set_lookup
5            _set_load_row
6            _get_ds _clean_ds
7            _debug
8            _pack_subfields_hash
9    
10            to
11            search_display search display sorted
12    
13            rec1 rec2 rec
14            frec frec_eq frec_ne
15            regex prefix suffix surround
16            first lookup join_with
17            save_into_lookup
18    
19            split_rec_on
20    
21            get set
22            count
23    
24            row
25            rec_array
26    
27    /;
28    
29  use warnings;  use warnings;
30  use strict;  use strict;
 use blib;  
 use WebPAC::Common;  
 use base 'WebPAC::Common';  
 use Data::Dumper;  
31    
32  =head1 NAME  #use base qw/WebPAC::Common/;
33    use Data::Dump qw/dump/;
34    use Carp qw/confess/;
35    
36    # debugging warn(s)
37    my $debug = 0;
38    _debug( $debug );
39    
40    # FIXME
41    use WebPAC::Normalize::ISBN;
42    push @EXPORT, ( 'isbn_10', 'isbn_13' );
43    
44    use WebPAC::Normalize::MARC;
45    push @EXPORT, ( qw/
46            marc marc_indicators marc_repeatable_subfield
47            marc_compose marc_leader marc_fixed
48            marc_duplicate marc_remove marc_count
49            marc_original_order
50            marc_template
51    /);
52    
53  WebPAC::Normalize - data mungling for normalisation  use Storable qw/dclone/;
54    
55  =head1 VERSION  =head1 NAME
56    
57  Version 0.09  WebPAC::Normalize - describe normalisaton rules using sets
58    
59  =cut  =cut
60    
61  our $VERSION = '0.09';  our $VERSION = '0.36';
62    
63  =head1 SYNOPSIS  =head1 SYNOPSIS
64    
65  This package contains code that mungle data to produce normalized format.  This module uses C<conf/normalize/*.pl> files to perform normalisation
66    from input records using perl functions which are specialized for set
67    processing.
68    
69    Sets are implemented as arrays, and normalisation file is valid perl, which
70    means that you check it's validity before running WebPAC using
71    C<perl -c normalize.pl>.
72    
73    Normalisation can generate multiple output normalized data. For now, supported output
74    types (on the left side of definition) are: C<search_display>, C<display>, C<search> and
75    C<marc>.
76    
77  It contains several assumptions:  =head1 FUNCTIONS
78    
79  =over  Functions which start with C<_> are private and used by WebPAC internally.
80    All other functions are available for use within normalisation rules.
81    
82  =item *  =head2 data_structure
83    
84  format of fields is defined using C<v123^a> notation for repeatable fields  Return data structure
 or C<s123^a> for single (or first) value, where C<123> is field number and  
 C<a> is subfield.  
85    
86  =item *    my $ds = WebPAC::Normalize::data_structure(
87            lookup => $lookup_hash,
88            row => $row,
89            rules => $normalize_pl_config,
90            marc_encoding => 'utf-8',
91            config => $config,
92            load_row_coderef => sub {
93                    my ($database,$input,$mfn) = @_;
94                    $store->load_row( database => $database, input => $input, id => $mfn );
95            },
96      );
97    
98  source data records (C<$rec>) have unique identifiers in field C<000>  Options C<row>, C<rules> and C<log> are mandatory while all
99    other are optional.
100    
101  =item *  C<load_row_coderef> is closure only used when executing lookups, so they will
102    die if it's not defined.
103    
104  optional C<eval{length('v123^a') == 3}> tag at B<beginning of format> will be  This function will B<die> if normalizastion can't be evaled.
 perl code that is evaluated before producing output (value of field will be  
 interpolated before that)  
105    
106  =item *  Since this function isn't exported you have to call it with
107    C<WebPAC::Normalize::data_structure>.
108    
109  optional C<filter{filter_name}> at B<begining of format> will apply perl  =cut
 code defined as code ref on format after field substitution to producing  
 output  
110    
111  There is one built-in filter called C<regex> which can be use like this:  my $load_row_coderef;
112    
113    filter{regex(s/foo/bar/)}  sub data_structure {
114            my $arg = {@_};
115    
116  =item *          die "need row argument" unless ($arg->{row});
117            die "need normalisation argument" unless ($arg->{rules});
118    
119  optional C<lookup{...}> will be then performed. See C<WebPAC::Lookups>.          _set_lookup( $arg->{lookup} ) if defined($arg->{lookup});
120            _set_ds( $arg->{row} );
121            _set_config( $arg->{config} ) if defined($arg->{config});
122            _clean_ds( %{ $arg } );
123            $load_row_coderef = $arg->{load_row_coderef};
124    
125  =item *          no strict 'subs';
126            no warnings 'all';
127            eval "$arg->{rules};";
128            die "error evaling $arg->{rules}: $@\n" if ($@);
129    
130  at end, optional C<format>s rules are resolved. Format rules are similar to          return _get_ds();
131  C<sprintf> and can also contain C<lookup{...}> which is performed after  }
 values are inserted in format.  
132    
133  =back  =head2 _set_ds
134    
135  This also describes order in which transformations are applied (eval,  Set current record hash
 filter, lookup, format) which is important to undestand when deciding how to  
 solve your data mungling and normalisation process.  
136    
137      _set_ds( $rec );
138    
139    =cut
140    
141    my $rec;
142    
143  =head1 FUNCTIONS  sub _set_ds {
144            $rec = shift or die "no record hash";
145            $WebPAC::Normalize::MARC::rec = $rec;
146    }
147    
148  =head2 new  =head2
149    
150  Create new normalisation object    my $rec = _get_rec();
151    
152    my $n = new WebPAC::Normalize::Something(  =cut
         filter => {  
                 'filter_name_1' => sub {  
                         # filter code  
                         return length($_);  
                 }, ...  
         },  
         db => $db_obj,  
         lookup_regex => $lookup->regex,  
         lookup => $lookup_obj,  
         prefix => 'foobar',  
   );  
153    
154  Parametar C<filter> defines user supplied snippets of perl code which can  sub _get_rec { $rec };
 be use with C<filter{...}> notation.  
155    
156  C<prefix> is used to form filename for database record (to support multiple  =head2 _set_config
 source files which are joined in one database).  
157    
158  Recommended parametar C<lookup_regex> is used to enable parsing of lookups  Set current config hash
 in structures. If you pass this parametar, you must also pass C<lookup>  
 which is C<WebPAC::Lookup> object.  
159    
160  =cut    _set_config( $config );
161    
162  sub new {  Magic keys are:
         my $class = shift;  
         my $self = {@_};  
         bless($self, $class);  
163    
164          my $r = $self->{'lookup_regex'} ? 1 : 0;  =over 4
         my $l = $self->{'lookup'} ? 1 : 0;  
165    
166          my $log = $self->_get_logger();  =item _
167    
168          # those two must be in pair  Code of current database
169          if ( ($r & $l) != ($r || $l) ) {  
170                  my $log = $self->_get_logger();  =item _mfn
                 $log->logdie("lookup_regex and lookup must be in pair");  
         }  
171    
172          $log->logdie("lookup must be WebPAC::Lookup object") if ($self->{'lookup'} && ! $self->{'lookup'}->isa('WebPAC::Lookup'));  Current MFN
173    
174          $log->warn("no prefix defined. please check that!") unless ($self->{'prefix'});  =back
175    
176          $log->debug("using lookup regex: ", $self->{lookup_regex}) if ($r && $l);  =cut
177    
178          if (! $self->{filter} || ! $self->{filter}->{regex}) {  my $config;
                 $log->debug("adding built-in filter regex");  
                 $self->{filter}->{regex} = sub {  
                         my ($val, $regex) = @_;  
                         eval "\$val =~ $regex";  
                         return $val;  
                 };  
         }  
179    
180          $self ? return $self : return undef;  sub _set_config {
181            $config = shift;
182  }  }
183    
184  =head2 all_tags  =head2 _get_ds
185    
186  Returns all tags in document in specified order  Return hash formatted as data structure
187    
188    my $sorted_tags = $self->all_tags();    my $ds = _get_ds();
189    
190  =cut  =cut
191    
192  sub all_tags {  my $out;
         my $self = shift;  
193    
194          if (! $self->{_tags_by_order}) {  sub _get_ds {
195    #warn "## out = ",dump($out);
196                  my $log = $self->_get_logger;          return $out;
197                  # sanity check  }
                 $log->logdie("can't find self->{inport_xml}->{indexer}") unless ($self->{import_xml}->{indexer});  
198    
199                  my @tags = keys %{ $self->{'import_xml'}->{'indexer'}};  =head2 _clean_ds
                 $log->debug("unsorted tags: " . join(", ", @tags));  
200    
201                  @tags = sort { $self->_sort_by_order } @tags;  Clean data structure hash for next record
202    
203                  $log->debug("sorted tags: " . join(",", @tags) );    _clean_ds();
204    
205                  $self->{_tags_by_order} = \@tags;  =cut
         }  
206    
207          return $self->{_tags_by_order};  sub _clean_ds {
208            my $a = {@_};
209            $out = undef;
210            WebPAC::Normalize::MARC::_clean();
211  }  }
212    
213    =head2 _set_lookup
214    
215    Set current lookup hash
216    
217  =head2 data_structure    _set_lookup( $lookup );
218    
219  Create in-memory data structure which represents normalized layout from  =cut
220  C<conf/normalize/*.xml>.  
221    my $lookup;
222    
223    sub _set_lookup {
224            $lookup = shift;
225    }
226    
227    =head2 _get_lookup
228    
229  This structures are used to produce output.  Get current lookup hash
230    
231   my $ds = $webpac->data_structure($rec);    my $lookup = _get_lookup();
232    
233  =cut  =cut
234    
235  sub data_structure {  sub _get_lookup {
236          my $self = shift;          return $lookup;
237    }
238    
239          my $log = $self->_get_logger();  =head2 _set_load_row
240    
241          my $rec = shift;  Setup code reference which will return L<data_structure> from
242          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);  L<WebPAC::Store>
243    
244          $log->debug("data_structure rec = ", sub { Dumper($rec) });    _set_load_row(sub {
245                    my ($database,$input,$mfn) = @_;
246                    $store->load_row( database => $database, input => $input, id => $mfn );
247      });
248    
249          $log->logdie("need unique ID (mfn) in field 000 of record " . Dumper($rec) ) unless (defined($rec->{'000'}));  =cut
250    
251          my $id = $rec->{'000'}->[0] || $log->logdie("field 000 isn't array!");  sub _set_load_row {
252            my $coderef = shift;
253            confess "argument isn't CODE" unless ref($coderef) eq 'CODE';
254    
255          my $cache_file;          $load_row_coderef = $coderef;
256    }
257    
258          if ($self->{'db'}) {  =head2 _debug
                 my $ds = $self->{'db'}->load_ds( id => $id, prefix => $self->{prefix} );  
                 $log->debug("load_ds( rec = ", sub { Dumper($rec) }, ") = ", sub { Dumper($ds) });  
                 return $ds if ($ds);  
                 $log->debug("cache miss, creating");  
         }  
259    
260          my $tags = $self->all_tags();  Change level of debug warnings
261    
262          $log->debug("tags: ",sub { join(", ",@{ $tags }) });    _debug( 2 );
263    
264          my $ds;  =cut
265    
266          foreach my $field (@{ $tags }) {  sub _debug {
267            my $l = shift;
268            return $debug unless defined($l);
269            warn "debug level $l",$/ if ($l > 0);
270            $debug = $l;
271            $WebPAC::Normalize::MARC::debug = $debug;
272    }
273    
274                  my $row;  =head1 Functions to create C<data_structure>
275    
276  #print "field $field [",$self->{'tag'},"] = ",Dumper($self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}});  Those functions generally have to first in your normalization file.
277    
278                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {  =head2 to
                         my $format;  
279    
280                          $log->logdie("expected tag HASH and got $tag") unless (ref($tag) eq 'HASH');  Generic way to set values for some name
                         $format = $tag->{'value'} || $tag->{'content'};  
281    
282                          my @v;    to('field-name', 'name-value' => rec('200','a') );
                         if ($self->{'lookup_regex'} && $format =~ $self->{'lookup_regex'}) {  
                                 @v = $self->_rec_to_arr($rec,$format,'fill_in');  
                         } else {  
                                 @v = $self->_rec_to_arr($rec,$format,'parse');  
                         }  
                         if (! @v) {  
                                 $log->debug("$field <",$self->{tag},"> format: $format no values");  
                                 next;  
                         } else {  
                                 $log->debug("$field <",$self->{tag},"> format: $format values: ", join(",", @v));  
                         }  
283    
284                          if ($tag->{'sort'}) {  There are many helpers defined below which might be easier to use.
                                 @v = $self->sort_arr(@v);  
                         }  
285    
286                          # use format?  =cut
                         if ($tag->{'format_name'}) {  
                                 @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;  
                         }  
287    
288                          # delimiter will join repeatable fields  sub to {
289                          if ($tag->{'delimiter'}) {          my $type = shift or confess "need type -- BUG?";
290                                  @v = ( join($tag->{'delimiter'}, @v) );          my $name = shift or confess "needs name as first argument";
291                          }          my @o = grep { defined($_) && $_ ne '' } @_;
292            return unless (@o);
293            $out->{$name}->{$type} = \@o;
294    }
295    
296                          # default types  =head2 search_display
                         my @types = qw(display search);  
                         # override by type attribute  
                         @types = ( $tag->{'type'} ) if ($tag->{'type'});  
   
                         foreach my $type (@types) {  
                                 # append to previous line?  
                                 $log->debug("tag $field / $type [",sub { join(",",@v) }, "] ", $row->{'append'} || 'no append');  
                                 if ($tag->{'append'}) {  
   
                                         # I will delimit appended part with  
                                         # delimiter (or ,)  
                                         my $d = $tag->{'delimiter'};  
                                         # default delimiter  
                                         $d ||= " ";  
   
                                         my $last = pop @{$row->{$type}};  
                                         $d = "" if (! $last);  
                                         $last .= $d . join($d, @v);  
                                         push @{$row->{$type}}, $last;  
297    
298                                  } else {  Define output for L<search> and L<display> at the same time
                                         push @{$row->{$type}}, @v;  
                                 }  
                         }  
299    
300      search_display('Title', rec('200','a') );
301    
302                  }  =cut
303    
304                  if ($row) {  sub search_display {
305                          $row->{'tag'} = $field;          my $name = shift or die "search_display needs name as first argument";
306            my @o = grep { defined($_) && $_ ne '' } @_;
307            return unless (@o);
308            $out->{$name}->{search} = \@o;
309            $out->{$name}->{display} = \@o;
310    }
311    
312                          # TODO: name_sigular, name_plural  =head2 tag
                         my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};  
                         my $row_name = $name ? $self->_x($name) : $field;  
   
                         # post-sort all values in field  
                         if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {  
                                 $log->warn("sort at field tag not implemented");  
                         }  
313    
314                          $ds->{$row_name} = $row;  Old name for L<search_display>, it will probably be removed at one point.
315    
316                          $log->debug("row $field: ",sub { Dumper($row) });  =cut
                 }  
317    
318          }  sub tag {
319            search_display( @_ );
320    }
321    
322          $self->{'db'}->save_ds(  =head2 display
                 id => $id,  
                 ds => $ds,  
                 prefix => $self->{prefix},  
         ) if ($self->{'db'});  
323    
324          $log->debug("ds: ", sub { Dumper($ds) });  Define output just for I<display>
325    
326          $log->logconfess("data structure returned is not array any more!") if wantarray;    @v = display('Title', rec('200','a') );
327    
328          return $ds;  =cut
329    
330  }  sub display { to( 'display', @_ ) }
331    
332  =head2 parse  =head2 search
333    
334  Perform smart parsing of string, skipping delimiters for fields which aren't  Prepare values just for I<search>
 defined. It can also eval code in format starting with C<eval{...}> and  
 return output or nothing depending on eval code.  
335    
336   my $text = $webpac->parse($rec,'eval{"v901^a" eq "Deskriptor"}descriptor: v250^a', $i);    @v = search('Title', rec('200','a') );
337    
338  Filters are implemented here. While simple form of filters looks like this:  =cut
339    
340    sub search { to( 'search', @_ ) }
341    
342    filter{name_of_filter}  =head2 sorted
343    
344  but, filters can also have variable number of parametars like this:  Insert into lists which will be automatically sorted
345    
346    filter{name_of_filter(param,param,param)}   sorted('Title', rec('200','a') );
347    
348  =cut  =cut
349    
350  my $warn_once;  sub sorted { to( 'sorted', @_ ) }
351    
352  sub parse {  =head2 row
         my $self = shift;  
353    
354          my ($rec, $format_utf8, $i, $rec_size) = @_;  Insert new row of data into output module
355    
356          return if (! $format_utf8);    row( column => 'foo', column2 => 'bar' );
357    
358          my $log = $self->_get_logger();  =cut
359    
360          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);  use Data::Dump qw/dump/;
361    
362          $i = 0 if (! $i);  sub row {
363            die "array doesn't have odd number of elements but $#_: ",dump( @_ ) if $#_ % 2 == 1;
364            my $table = shift @_;
365            push @{ $out->{'_rows'}->{$table} }, {@_};
366    }
367    
         my $format = $self->_x($format_utf8) || $log->logconfess("can't convert '$format_utf8' from UTF-8 to ",$self->{'code_page'});  
368    
369          my @out;  =head1 Functions to extract data from input
370    
371          $log->debug("format: $format [$i]");  This function should be used inside functions to create C<data_structure> described
372    above.
373    
374          my $eval_code;  =head2 _pack_subfields_hash
         # remove eval{...} from beginning  
         $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);  
375    
376          my $filter_name;   @subfields = _pack_subfields_hash( $h );
377          # remove filter{...} from beginning   $subfields = _pack_subfields_hash( $h, 1 );
         $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);  
378    
379          # did we found any (att all) field from format in row?  Return each subfield value in array or pack them all together and return scalar
380          my $found_any;  with subfields (denoted by C<^>) and values.
         # prefix before first field which we preserve it $found_any  
         my $prefix;  
381    
382          my $f_step = 1;  =cut
383    
384          while ($format =~ s/^(.*?)(v|s)(\d+)(?:\^(\w))?//s) {  sub _pack_subfields_hash {
385    
386                  my $del = $1 || '';          warn "## _pack_subfields_hash( ",dump(@_), " )\n" if ($debug > 1);
                 $prefix = $del if ($f_step == 1);  
387    
388                  my $fld_type = lc($2);          my ($hash,$include_subfields) = @_;
389    
390                  # repeatable index          # sanity and ease of use
391                  my $r = $i;          return $hash if (ref($hash) ne 'HASH');
                 if ($fld_type eq 's') {  
                         if ($found_any->{'v'}) {  
                                 $r = 0;  
                         } else {  
                                 return;  
                         }  
                 }  
392    
393                  my $found = 0;          my $h = dclone( $hash );
                 my $tmp = $self->get_data(\$rec,$3,$4,$r,\$found,$rec_size);  
394    
395                  if ($found) {          if ( defined($h->{subfields}) ) {
396                          $found_any->{$fld_type} += $found;                  my $sfs = delete $h->{subfields} || die "no subfields?";
397                    my @out;
398                    while (@$sfs) {
399                            my $sf = shift @$sfs;
400                            push @out, '^' . $sf if ($include_subfields);
401                            my $o = shift @$sfs;
402                            if ($o == 0 && ref( $h->{$sf} ) ne 'ARRAY' ) {
403                                    # single element subfields are not arrays
404    #warn "====> $sf $o / $#$sfs ", dump( $sfs, $h->{$sf} ), "\n";
405    
406                          # we will skip delimiter before first occurence of field!                                  push @out, $h->{$sf};
407                          push @out, $del unless($found_any->{$fld_type} == 1);                          } else {
408                          push @out, $tmp if ($tmp);  #warn "====> $sf $o / $#$sfs ", dump( $sfs, $h->{$sf} ), "\n";
409                                    push @out, $h->{$sf}->[$o];
410                            }
411                    }
412                    if ($include_subfields) {
413                            return join('', @out);
414                    } else {
415                            return @out;
416                    }
417            } else {
418                    if ($include_subfields) {
419                            my $out = '';
420                            foreach my $sf (sort keys %$h) {
421                                    if (ref($h->{$sf}) eq 'ARRAY') {
422                                            $out .= '^' . $sf . join('^' . $sf, @{ $h->{$sf} });
423                                    } else {
424                                            $out .= '^' . $sf . $h->{$sf};
425                                    }
426                            }
427                            return $out;
428                    } else {
429                            # FIXME this should probably be in alphabetical order instead of hash order
430                            values %{$h};
431                  }                  }
                 $f_step++;  
432          }          }
433    }
434    
435          # test if any fields found?  =head2 rec1
         return if (! $found_any->{'v'} && ! $found_any->{'s'});  
436    
437          my $out = join('',@out);  Return all values in some field
438    
439          if ($out) {    @v = rec1('200')
                 # add rest of format (suffix)  
                 $out .= $format;  
440    
441                  # add prefix if not there  TODO: order of values is probably same as in source data, need to investigate that
                 $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);  
442    
443                  $log->debug("result: $out");  =cut
         }  
444    
445          if ($eval_code) {  sub rec1 {
446                  my $eval = $self->fill_in($rec,$eval_code,$i) || return;          my $f = shift;
447                  $log->debug("about to eval{$eval} format: $out");          warn "rec1($f) = ", dump( $rec->{$f} ), $/ if ($debug > 1);
448                  return if (! $self->_eval($eval));          return unless (defined($rec) && defined($rec->{$f}));
449          }          warn "rec1($f) = ", dump( $rec->{$f} ), $/ if ($debug > 1);
450                    if (ref($rec->{$f}) eq 'ARRAY') {
451          if ($filter_name) {                  my @out;
452                  my @filter_args;                  foreach my $h ( @{ $rec->{$f} } ) {
453                  if ($filter_name =~ s/(\w+)\((.*)\)/$1/) {                          if (ref($h) eq 'HASH') {
454                          @filter_args = split(/,/, $2);                                  push @out, ( _pack_subfields_hash( $h ) );
455                  }                          } else {
456                  if ($self->{'filter'}->{$filter_name}) {                                  push @out, $h;
457                          $log->debug("about to filter{$filter_name} format: $out with arguments: ", join(",", @filter_args));                          }
                         unshift @filter_args, $out;  
                         $out = $self->{'filter'}->{$filter_name}->(@filter_args);  
                         return unless(defined($out));  
                         $log->debug("filter result: $out");  
                 } elsif (! $warn_once->{$filter_name}) {  
                         $log->warn("trying to use undefined filter $filter_name");  
                         $warn_once->{$filter_name}++;  
458                  }                  }
459                    return @out;
460            } elsif( defined($rec->{$f}) ) {
461                    return $rec->{$f};
462          }          }
463    }
464    
465          return $out;  =head2 rec2
466    
467    Return all values in specific field and subfield
468    
469      @v = rec2('200','a')
470    
471    =cut
472    
473    sub rec2 {
474            my $f = shift;
475            return unless (defined($rec && $rec->{$f}));
476            my $sf = shift;
477            warn "rec2($f,$sf) = ", dump( $rec->{$f} ), $/ if ($debug > 1);
478            return map {
479                    if (ref($_->{$sf}) eq 'ARRAY') {
480                            @{ $_->{$sf} };
481                    } else {
482                            $_->{$sf};
483                    }
484            } grep { ref($_) eq 'HASH' && defined $_->{$sf} } @{ $rec->{$f} };
485  }  }
486    
487  =head2 fill_in  =head2 rec
488    
489  Workhourse of all: takes record from in-memory structure of database and  syntaxtic sugar for
 strings with placeholders and returns string or array of with substituted  
 values from record.  
490    
491   my $text = $webpac->fill_in($rec,'v250^a');    @v = rec('200')
492      @v = rec('200','a')
493    
494  Optional argument is ordinal number for repeatable fields. By default,  If rec() returns just single value, it will
495  it's assume to be first repeatable field (fields are perl array, so first  return scalar, not array.
 element is 0).  
 Following example will read second value from repeatable field.  
496    
497   my $text = $webpac->fill_in($rec,'Title: v250^a',1);  =cut
498    
499  This function B<does not> perform parsing of format to inteligenty skip  sub rec {
500  delimiters before fields which aren't used.          my @out;
501            if ($#_ == 0) {
502                    @out = rec1(@_);
503            } elsif ($#_ == 1) {
504                    @out = rec2(@_);
505            }
506            if ($#out == 0 && ! wantarray) {
507                    return $out[0];
508            } elsif (@out) {
509                    return @out;
510            } else {
511                    return '';
512            }
513    }
514    
515  This method will automatically decode UTF-8 string to local code page  =head2 frec
 if needed.  
516    
517  There is optional parametar C<$record_size> which can be used to get sizes of  Returns first value from field
 all C<field^subfield> combinations in this format.  
518    
519   my $text = $webpac->fill_in($rec,'got: v900^a v900^x',0,\$rec_size);    $v = frec('200');
520      $v = frec('200','a');
521    
522  =cut  =cut
523    
524  sub fill_in {  sub frec {
525          my $self = shift;          my @out = rec(@_);
526            warn "rec(",dump(@_),") has more than one return value, ignoring\n" if $#out > 0;
527            return shift @out;
528    }
529    
530          my $log = $self->_get_logger();  =head2 frec_eq
531    
532          my ($rec,$format,$i,$rec_size) = @_;  =head2 frec_ne
533    
534          $log->logconfess("need data record") unless ($rec);  Check if first values from two fields are same or different
         $log->logconfess("need format to parse") unless($format);  
535    
536          # iteration (for repeatable fields)    if ( frec_eq( 900 => 'a', 910 => 'c' ) ) {
537          $i ||= 0;          # values are same
538      } else {
539        # values are different
540      }
541    
542          $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));  Strictly speaking C<frec_eq> and C<frec_ne> wouldn't be needed if you
543    could write something like:
544    
545          # FIXME remove for speedup?    if ( frec( '900','a' ) eq frec( '910','c' ) ) {
546          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          # yada tada
547      }
548    
549          if (utf8::is_utf8($format)) {  but you can't since our parser L<WebPAC::Parser> will remove all whitespaces
550                  $format = $self->_x($format);  in order to parse text and create invalid function C<eqfrec>.
         }  
551    
552          my $found = 0;  =cut
         my $just_single = 1;  
553    
554          my $eval_code;  sub frec_eq {
555          # remove eval{...} from beginning          my ( $f1,$sf1, $f2, $sf2 ) = @_;
556          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          return (rec( $f1, $sf1 ))[0] eq (rec( $f2, $sf2 ))[0];
557    }
558    
559          my $filter_name;  sub frec_ne {
560          # remove filter{...} from beginning          return ! frec_eq( @_ );
561          $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);  }
562    
563          {  =head2 regex
                 # fix warnings  
                 no warnings 'uninitialized';  
564    
565                  # do actual replacement of placeholders  Apply regex to some or all values
                 # repeatable fields  
                 if ($format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found,$rec_size)/ges) {  
                         $just_single = 0;  
                 }  
566    
567                  # non-repeatable fields    @v = regex( 's/foo/bar/g', @v );
                 if ($format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found,$rec_size)/ges) {  
                         return if ($i > 0 && $just_single);  
                 }  
         }  
568    
569          if ($found) {  =cut
570                  $log->debug("format: $format");  
571                  if ($eval_code) {  sub regex {
572                          my $eval = $self->fill_in($rec,$eval_code,$i);          my $r = shift;
573                          return if (! $self->_eval($eval));          my @out;
574                  }          #warn "r: $r\n", dump(\@_);
575                  if ($filter_name && $self->{'filter'}->{$filter_name}) {          foreach my $t (@_) {
576                          $log->debug("filter '$filter_name' for $format");                  next unless ($t);
577                          $format = $self->{'filter'}->{$filter_name}->($format);                  eval "\$t =~ $r";
578                          return unless(defined($format));                  push @out, $t if ($t && $t ne '');
                         $log->debug("filter result: $format");  
                 }  
                 # do we have lookups?  
                 if ($self->{'lookup'}) {  
                         if ($self->{'lookup'}->can('lookup')) {  
                                 my @lookup = $self->{lookup}->lookup($format);  
                                 $log->debug("lookup $format", join(", ", @lookup));  
                                 return @lookup;  
                         } else {  
                                 $log->warn("Have lookup object but can't invoke lookup method");  
                         }  
                 } else {  
                         return $format;  
                 }  
         } else {  
                 return;  
579          }          }
580            return @out;
581  }  }
582    
583    =head2 prefix
584    
585  =head2 _rec_to_arr  Prefix all values with a string
586    
587  Similar to C<parse> and C<fill_in>, but returns array of all repeatable fields. Usable    @v = prefix( 'my_', @v );
 for fields which have lookups, so they shouldn't be parsed but rather  
 C<paste>d or C<fill_id>ed. Last argument is name of operation: C<paste> or C<fill_in>.  
588    
589   my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]','paste');  =cut
590    
591    sub prefix {
592            my $p = shift;
593            return @_ unless defined( $p );
594            return map { $p . $_ } grep { defined($_) } @_;
595    }
596    
597    =head2 suffix
598    
599    suffix all values with a string
600    
601      @v = suffix( '_my', @v );
602    
603  =cut  =cut
604    
605  sub _rec_to_arr {  sub suffix {
606          my $self = shift;          my $s = shift;
607            return @_ unless defined( $s );
608            return map { $_ . $s } grep { defined($_) } @_;
609    }
610    
611          my ($rec, $format_utf8, $code) = @_;  =head2 surround
612    
613          my $log = $self->_get_logger();  surround all values with a two strings
614    
615          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);    @v = surround( 'prefix_', '_suffix', @v );
         return if (! $format_utf8);  
616    
617          $log->debug("using $code on $format_utf8");  =cut
618    
619          my $i = 0;  sub surround {
620          my $max = 0;          my $p = shift;
621          my @arr;          my $s = shift;
622          my $rec_size = {};          $p = '' unless defined( $p );
623            $s = '' unless defined( $s );
624            return map { $p . $_ . $s } grep { defined($_) } @_;
625    }
626    
627          while ($i <= $max) {  =head2 first
628                  my @v = $self->$code($rec,$format_utf8,$i++,\$rec_size);  
629                  if ($rec_size) {  Return first element
                         foreach my $f (keys %{ $rec_size }) {  
                                 $max = $rec_size->{$f} if ($rec_size->{$f} > $max);  
                         }  
                         $log->debug("max set to $max");  
                         undef $rec_size;  
                 }  
                 if (@v) {  
                         push @arr, @v;  
                 } else {  
                         push @arr, '' if ($max > $i);  
                 }  
         }  
630    
631          $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);    $v = first( @v );
632    
633          return @arr;  =cut
634    
635    sub first {
636            my $r = shift;
637            return $r;
638  }  }
639    
640    =head2 lookup
641    
642  =head2 get_data  Consult lookup hashes for some value
643    
644  Returns value from record.    @v = lookup(
645            sub {
646                    'ffkk/peri/mfn'.rec('000')
647            },
648            'ffkk','peri','200-a-200-e',
649            sub {
650                    first(rec(200,'a')).' '.first(rec('200','e'))
651            }
652      );
653    
654   my $text = $self->get_data(\$rec,$f,$sf,$i,\$found,\$rec_size);  Code like above will be B<automatically generated> using L<WebPAC::Parse> from
655    normal lookup definition in C<conf/lookup/something.pl> which looks like:
656    
657  Required arguments are:    lookup(
658            # which results to return from record recorded in lookup
659            sub { 'ffkk/peri/mfn' . rec('000') },
660            # from which database and input
661            'ffkk','peri',
662            # such that following values match
663            sub { first(rec(200,'a')) . ' ' . first(rec('200','e')) },
664            # if this part is missing, we will try to match same fields
665            # from lookup record and current one, or you can override
666            # which records to use from current record using
667            sub { rec('900','x') . ' ' . rec('900','y') },
668      )
669    
670  =over 8  You can think about this lookup as SQL (if that helps):
671    
672  =item C<$rec>    select
673            sub { what }
674      from
675            database, input
676      where
677        sub { filter from lookuped record }
678      having
679        sub { optional filter on current record }
680    
681  record reference  Easy as pie, right?
682    
683  =item C<$f>  =cut
684    
685  field  sub lookup {
686            my ($what, $database, $input, $key, $having) = @_;
687    
688  =item C<$sf>          confess "lookup needs 5 arguments: what, database, input, key, having\n" unless ($#_ == 4);
689    
690  optional subfield          warn "## lookup ($database, $input, $key)", $/ if ($debug > 1);
691            return unless (defined($lookup->{$database}->{$input}->{$key}));
692    
693  =item C<$i>          confess "lookup really need load_row_coderef added to data_structure\n" unless ($load_row_coderef);
694    
695  index offset for repeatable values ( 0 ... $rec_size->{'400^a'} )          my $mfns;
696            my @having = $having->();
697    
698  =item C<$found>          warn "## having = ", dump( @having ) if ($debug > 2);
699    
700  optional variable that will be incremeted if preset          foreach my $h ( @having ) {
701                    if (defined($lookup->{$database}->{$input}->{$key}->{$h})) {
702                            warn "lookup for $database/$input/$key/$h return ",dump($lookup->{$database}->{$input}->{$key}->{$h}),"\n" if ($debug);
703                            $mfns->{$_}++ foreach keys %{ $lookup->{$database}->{$input}->{$key}->{$h} };
704                    }
705            }
706    
707  =item C<$rec_size>          return unless ($mfns);
708    
709  hash to hold maximum occurances of C<field^subfield> combinations          my @mfns = sort keys %$mfns;
 (which can be accessed using keys in same format)  
710    
711  =back          warn "# lookup loading $database/$input/$key mfn ", join(",",@mfns)," having ",dump(@having),"\n" if ($debug);
712    
713  Returns value or empty string, updates C<$found> and C<rec_size>          my $old_rec = $rec;
714  if present.          my @out;
715    
716  =cut          foreach my $mfn (@mfns) {
717                    $rec = $load_row_coderef->( $database, $input, $mfn );
718    
719  sub get_data {                  warn "got $database/$input/$mfn = ", dump($rec), $/ if ($debug);
         my $self = shift;  
720    
721          my ($rec,$f,$sf,$i,$found,$cache) = @_;                  my @vals = $what->();
722    
723          return '' unless ($$rec->{$f} && ref($$rec->{$f}) eq 'ARRAY');                  push @out, ( @vals );
724    
725          if (defined($$cache)) {                  warn "lookup for mfn $mfn returned ", dump(@vals), $/ if ($debug);
                 $$cache->{ $f . ( $sf ? '^' . $sf : '' ) } ||= scalar @{ $$rec->{$f} };  
726          }          }
727    
728          return '' unless ($$rec->{$f}->[$i]);  #       if (ref($lookup->{$k}) eq 'ARRAY') {
729    #               return @{ $lookup->{$k} };
730    #       } else {
731    #               return $lookup->{$k};
732    #       }
733    
734          {          $rec = $old_rec;
735                  no strict 'refs';  
736                  if (defined($sf)) {          warn "## lookup returns = ", dump(@out), $/ if ($debug);
737                          $$found++ if (defined($$found) && $$rec->{$f}->[$i]->{$sf});  
738                          return $$rec->{$f}->[$i]->{$sf};          if ($#out == 0) {
739                  } else {                  return $out[0];
740                          $$found++ if (defined($$found));          } else {
741                          # it still might have subfields, just                  return @out;
                         # not specified, so we'll dump some debug info  
                         if ($$rec->{$f}->[$i] =~ /HASH/o) {  
                                 my $out;  
                                 foreach my $k (keys %{$$rec->{$f}->[$i]}) {  
                                         my $v = $$rec->{$f}->[$i]->{$k};  
                                         $out .= '$' . $k .':' . $v if ($v);  
                                 }  
                                 return $out;  
                         } else {  
                                 return $$rec->{$f}->[$i];  
                         }  
                 }  
742          }          }
743  }  }
744    
745    =head2 save_into_lookup
746    
747    Save value into lookup. It associates current database, input
748    and specific keys with one or more values which will be
749    associated over MFN.
750    
751  =head2 apply_format  MFN will be extracted from first occurence current of field 000
752    in current record, or if it doesn't exist from L<_set_config> C<_mfn>.
753    
754  Apply format specified in tag with C<format_name="name"> and    my $nr = save_into_lookup($database,$input,$key,sub {
755  C<format_delimiter=";;">.          # code which produce one or more values
756      });
757    
758   my $text = $webpac->apply_format($format_name,$format_delimiter,$data);  It returns number of items saved.
759    
760  Formats can contain C<lookup{...}> if you need them.  This function shouldn't be called directly, it's called from code created by
761    L<WebPAC::Parser>.
762    
763  =cut  =cut
764    
765  sub apply_format {  sub save_into_lookup {
766          my $self = shift;          my ($database,$input,$key,$coderef) = @_;
767            die "save_into_lookup needs database" unless defined($database);
768            die "save_into_lookup needs input" unless defined($input);
769            die "save_into_lookup needs key" unless defined($key);
770            die "save_into_lookup needs CODE" unless ( defined($coderef) && ref($coderef) eq 'CODE' );
771    
772            warn "## save_into_lookup rec = ", dump($rec), " config = ", dump($config), $/ if ($debug > 2);
773    
774          my ($name,$delimiter,$data) = @_;          my $mfn =
775                    defined($rec->{'000'}->[0])     ?       $rec->{'000'}->[0]      :
776                    defined($config->{_mfn})        ?       $config->{_mfn}         :
777                                                                                    die "mfn not defined or zero";
778    
779          my $log = $self->_get_logger();          my $nr = 0;
780    
781          if (! $self->{'import_xml'}->{'format'}->{$name}) {          foreach my $v ( $coderef->() ) {
782                  $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});                  $lookup->{$database}->{$input}->{$key}->{$v}->{$mfn}++;
783                  return $data;                  warn "# saved lookup $database/$input/$key [$v] $mfn\n" if ($debug > 1);
784                    $nr++;
785          }          }
786    
787          $log->warn("no delimiter for format $name") if (! $delimiter);          return $nr;
788    }
789    
790    =head2 config
791    
792    Consult config values stored in C<config.yml>
793    
794      # return database code (key under databases in yaml)
795      $database_code = config();    # use _ from hash
796      $database_name = config('name');
797      $database_input_name = config('input name');
798    
799    Up to three levels are supported.
800    
801    =cut
802    
803    sub config {
804            return unless ($config);
805    
806            my $p = shift;
807    
808          my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");          $p ||= '';
809    
810          my @data = split(/\Q$delimiter\E/, $data);          my $v;
811    
812          my $out = sprintf($format, @data);          warn "### getting config($p)\n" if ($debug > 1);
         $log->debug("using format $name [$format] on $data to produce: $out");  
813    
814          if ($self->{'lookup_regex'} && $out =~ $self->{'lookup_regex'}) {          my @p = split(/\s+/,$p);
815                  return $self->{'lookup'}->lookup($out);          if ($#p < 0) {
816                    $v = $config->{ '_' };  # special, database code
817          } else {          } else {
818                  return $out;  
819                    my $c = dclone( $config );
820    
821                    foreach my $k (@p) {
822                            warn "### k: $k c = ",dump($c),$/ if ($debug > 1);
823                            if (ref($c) eq 'ARRAY') {
824                                    $c = shift @$c;
825                                    warn "config($p) taking first occurence of '$k', probably not what you wanted!\n";
826                                    last;
827                            }
828    
829                            if (! defined($c->{$k}) ) {
830                                    $c = undef;
831                                    last;
832                            } else {
833                                    $c = $c->{$k};
834                            }
835                    }
836                    $v = $c if ($c);
837    
838          }          }
839    
840            warn "## config( '$p' ) = ",dump( $v ),$/ if ($v && $debug);
841            warn "config( '$p' ) is empty\n" if (! $v);
842    
843            return $v;
844  }  }
845    
846  =head2 sort_arr  =head2 id
847    
848  Sort array ignoring case and html in data  Returns unique id of this record
849    
850   my @sorted = $webpac->sort_arr(@unsorted);    $id = id();
851    
852    Returns C<42/2> for 2nd occurence of MFN 42.
853    
854  =cut  =cut
855    
856  sub sort_arr {  sub id {
857          my $self = shift;          my $mfn = $config->{_mfn} || die "no _mfn in config data";
858            return $mfn . ( WebPAC::Normalize::MARC::_created_marc_records() || '' );
859    }
860    
861    =head2 join_with
862    
863          my $log = $self->_get_logger();  Joins walues with some delimiter
864    
865          # FIXME add Schwartzian Transformation?    $v = join_with(", ", @v);
866    
867          my @sorted = sort {  =cut
                 $a =~ s#<[^>]+/*>##;  
                 $b =~ s#<[^>]+/*>##;  
                 lc($b) cmp lc($a)  
         } @_;  
         $log->debug("sorted values: ",sub { join(", ",@sorted) });  
868    
869          return @sorted;  sub join_with {
870            my $d = shift;
871            warn "### join_with('$d',",dump(@_),")\n" if ($debug > 2);
872            my $v = join($d, grep { defined($_) && $_ ne '' } @_);
873            return '' unless defined($v);
874            return $v;
875  }  }
876    
877    =head2 split_rec_on
878    
879    Split record subfield on some regex and take one of parts out
880    
881  =head1 INTERNAL METHODS    $a_before_semi_column =
882            split_rec_on('200','a', /\s*;\s*/, $part);
883    
884  =head2 _sort_by_order  C<$part> is optional number of element. First element is
885    B<1>, not 0!
886    
887  Sort xml tags data structure accoding to C<order=""> attribute.  If there is no C<$part> parameter or C<$part> is 0, this function will
888    return all values produced by splitting.
889    
890  =cut  =cut
891    
892  sub _sort_by_order {  sub split_rec_on {
893          my $self = shift;          die "split_rec_on need (fld,sf,regex[,part]" if ($#_ < 2);
894    
895            my ($fld, $sf, $regex, $part) = @_;
896            warn "### regex ", ref($regex), $regex, $/ if ($debug > 2);
897    
898          my $va = $self->{'import_xml'}->{'indexer'}->{$a}->{'order'} ||          my @r = rec( $fld, $sf );
899                  $self->{'import_xml'}->{'indexer'}->{$a};          my $v = shift @r;
900          my $vb = $self->{'import_xml'}->{'indexer'}->{$b}->{'order'} ||          warn "### first rec($fld,$sf) = ",dump($v),$/ if ($debug > 2);
                 $self->{'import_xml'}->{'indexer'}->{$b};  
901    
902          return $va <=> $vb;          return '' if ( ! defined($v) || $v =~ /^\s*$/);
903    
904            my @s = split( $regex, $v );
905            warn "## split_rec_on($fld,$sf,$regex,$part) = ",dump(@s),$/ if ($debug > 1);
906            if ($part && $part > 0) {
907                    return $s[ $part - 1 ];
908            } else {
909                    return @s;
910            }
911  }  }
912    
913  =head2 _x  my $hash;
914    
915    =head2 set
916    
917      set( key => 'value' );
918    
919    =cut
920    
921  Convert strings from C<conf/normalize/*.xml> encoding into application  sub set {
922  specific encoding (optinally specified using C<code_page> to C<new>          my ($k,$v) = @_;
923  constructor).          warn "## set ( $k => ", dump($v), " )", $/ if ( $debug );
924            $hash->{$k} = $v;
925    };
926    
927   my $text = $n->_x('normalize text string');  =head2 get
928    
929  This is a stub so that other modules doesn't have to implement it.    get( 'key' );
930    
931  =cut  =cut
932    
933  sub _x {  sub get {
934          my $self = shift;          my $k = shift || return;
935          return shift;          my $v = $hash->{$k};
936            warn "## get $k = ", dump( $v ), $/ if ( $debug );
937            return $v;
938  }  }
939    
940    =head2 count
941    
942      if ( count( @result ) == 1 ) {
943            # do something if only 1 result is there
944      }
945    
946  =head1 AUTHOR  =cut
947    
948  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  sub count {
949            warn "## count ",dump(@_),$/ if ( $debug );
950            return @_ . '';
951    }
952    
953  =head1 COPYRIGHT & LICENSE  =head2 rec_array
954    
955  Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.  Always return field as array
956    
957  This program is free software; you can redistribute it and/or modify it    foreach my $d ( rec_array('field') ) {
958  under the same terms as Perl itself.          warn $d;
959      }
960    
961  =cut  =cut
962    
963  1; # End of WebPAC::Normalize  sub rec_array {
964            my $d = $rec->{ $_[0] };
965            return @$d if ref($d) eq 'ARRAY';
966            return ($d);
967    }
968    
969    # END
970    1;

Legend:
Removed from v.436  
changed lines
  Added in v.1364

  ViewVC Help
Powered by ViewVC 1.1.26