/[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 252 by dpavlin, Thu Dec 15 17:01:04 2005 UTC revision 551 by dpavlin, Fri Jun 30 20:43:09 2006 UTC
# Line 1  Line 1 
1  package WebPAC::Normalize;  package WebPAC::Normalize;
2    use Exporter 'import';
3    @EXPORT = qw/
4            _set_rec _set_lookup
5            _get_ds _clean_ds
6    
7            tag search display
8            marc marc_indicators marc_repeatable_subfield
9    
10            rec1 rec2 rec
11            regex prefix suffix surround
12            first lookup join_with
13    /;
14    
15  use warnings;  use warnings;
16  use strict;  use strict;
17  use base 'WebPAC::Common';  
18  use Data::Dumper;  #use base qw/WebPAC::Common/;
19    use Data::Dump qw/dump/;
20    use Encode qw/from_to/;
21    
22    # debugging warn(s)
23    my $debug = 0;
24    
25    
26  =head1 NAME  =head1 NAME
27    
28  WebPAC::Normalize - data mungling for normalisation  WebPAC::Normalize - describe normalisaton rules using sets
29    
30  =head1 VERSION  =head1 VERSION
31    
32  Version 0.04  Version 0.06
33    
34  =cut  =cut
35    
36  our $VERSION = '0.04';  our $VERSION = '0.06';
37    
38  =head1 SYNOPSIS  =head1 SYNOPSIS
39    
40  This package contains code that mungle data to produce normalized format.  This module uses C<conf/normalize/*.pl> files to perform normalisation
41    from input records using perl functions which are specialized for set
42  It contains several assumptions:  processing.
43    
44  =over  Sets are implemented as arrays, and normalisation file is valid perl, which
45    means that you check it's validity before running WebPAC using
46    C<perl -c normalize.pl>.
47    
48    Normalisation can generate multiple output normalized data. For now, supported output
49    types (on the left side of definition) are: C<tag>, C<display>, C<search> and
50    C<marc>.
51    
52  =item *  =head1 FUNCTIONS
   
 format of fields is defined using C<v123^a> notation for repeatable fields  
 or C<s123^a> for single (or first) value, where C<123> is field number and  
 C<a> is subfield.  
   
 =item *  
53    
54  source data records (C<$rec>) have unique identifiers in field C<000>  Functions which start with C<_> are private and used by WebPAC internally.
55    All other functions are available for use within normalisation rules.
56    
57  =item *  =head2 data_structure
58    
59  optional C<eval{length('v123^a') == 3}> tag at B<beginning of format> will be  Return data structure
 perl code that is evaluated before producing output (value of field will be  
 interpolated before that)  
60    
61  =item *    my $ds = WebPAC::Normalize::data_structure(
62            lookup => $lookup->lookup_hash,
63            row => $row,
64            rules => $normalize_pl_config,
65            marc_encoding => 'utf-8',
66      );
67    
68  optional C<filter{filter_name}> at B<begining of format> will apply perl  Options C<lookup>, C<row>, C<rules> and C<log> are mandatory while all
69  code defined as code ref on format after field substitution to producing  other are optional.
 output  
70    
71  =item *  This function will B<die> if normalizastion can't be evaled.
72    
73  optional C<lookup{...}> will be then performed. See C<WebPAC::Lookups>.  Since this function isn't exported you have to call it with
74    C<WebPAC::Normalize::data_structure>.
75    
76  =item *  =cut
77    
78  at end, optional C<format>s rules are resolved. Format rules are similar to  sub data_structure {
79  C<sprintf> and can also contain C<lookup{...}> which is performed after          my $arg = {@_};
 values are inserted in format.  
80    
81  =back          die "need row argument" unless ($arg->{row});
82            die "need normalisation argument" unless ($arg->{rules});
83    
84  This also describes order in which transformations are applied (eval,          no strict 'subs';
85  filter, lookup, format) which is important to undestand when deciding how to          _set_lookup( $arg->{lookup} );
86  solve your data mungling and normalisation process.          _set_rec( $arg->{row} );
87            _clean_ds( %{ $arg } );
88            eval "$arg->{rules}";
89            die "error evaling $arg->{rules}: $@\n" if ($@);
90    
91            return _get_ds();
92    }
93    
94    =head2 _set_rec
95    
96    Set current record hash
97    
98  =head1 FUNCTIONS    _set_rec( $rec );
99    
100  =head2 new  =cut
101    
102  Create new normalisation object  my $rec;
103    
104    my $n = new WebPAC::Normalize::Something(  sub _set_rec {
105          filter => {          $rec = shift or die "no record hash";
106                  'filter_name_1' => sub {  }
                         # filter code  
                         return length($_);  
                 }, ...  
         },  
         db => $db_obj,  
         lookup_regex => $lookup->regex,  
         lookup => $lookup_obj,  
         prefix => 'foobar',  
   );  
107    
108  Parametar C<filter> defines user supplied snippets of perl code which can  =head2 _get_ds
 be use with C<filter{...}> notation.  
109    
110  C<prefix> is used to form filename for database record (to support multiple  Return hash formatted as data structure
 source files which are joined in one database).  
111    
112  Recommended parametar C<lookup_regex> is used to enable parsing of lookups    my $ds = _get_ds();
 in structures. If you pass this parametar, you must also pass C<lookup>  
 which is C<WebPAC::Lookup> object.  
113    
114  =cut  =cut
115    
116  sub new {  my ($out,$marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators);
         my $class = shift;  
         my $self = {@_};  
         bless($self, $class);  
117    
118          my $r = $self->{'lookup_regex'} ? 1 : 0;  sub _get_ds {
119          my $l = $self->{'lookup'} ? 1 : 0;          return $out;
120    }
         my $log = $self->_get_logger();  
121    
122          # those two must be in pair  =head2 _clean_ds
         if ( ($r & $l) != ($r || $l) ) {  
                 my $log = $self->_get_logger();  
                 $log->logdie("lookup_regex and lookup must be in pair");  
         }  
123    
124          $log->logdie("lookup must be WebPAC::Lookup object") if ($self->{'lookup'} && ! $self->{'lookup'}->isa('WebPAC::Lookup'));  Clean data structure hash for next record
125    
126          $log->warn("no prefix defined. please check that!") unless ($self->{'prefix'});    _clean_ds();
127    
128          $log->debug("using lookup regex: ", $self->{lookup_regex}) if ($r && $l);  =cut
129    
130          $self ? return $self : return undef;  sub _clean_ds {
131            my $a = {@_};
132            ($out,$marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators) = ();
133            $marc_encoding = $a->{marc_encoding};
134  }  }
135    
136    =head2 _set_lookup
137    
138  =head2 data_structure  Set current lookup hash
   
 Create in-memory data structure which represents normalized layout from  
 C<conf/normalize/*.xml>.  
   
 This structures are used to produce output.  
139    
140   my $ds = $webpac->data_structure($rec);    _set_lookup( $lookup );
141    
142  =cut  =cut
143    
144  sub data_structure {  my $lookup;
         my $self = shift;  
   
         my $log = $self->_get_logger();  
145    
146          my $rec = shift;  sub _set_lookup {
147          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $lookup = shift;
148    }
149    
150          $log->debug("data_structure rec = ", sub { Dumper($rec) });  =head2 _get_marc_fields
151    
152          $log->logdie("need unique ID (mfn) in field 000 of record ", sub { Dumper($rec) } ) unless (defined($rec->{'000'}));  Get all fields defined by calls to C<marc>
153    
154          my $id = $rec->{'000'}->[0] || $log->logdie("field 000 isn't array!");          $marc->add_fields( WebPAC::Normalize:_get_marc_fields() );
155    
         my $cache_file;  
156    
         if ($self->{'db'}) {  
                 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");  
         }  
157    
158          undef $self->{'currnet_filename'};  We are using I<magic> which detect repeatable fields only from
159          undef $self->{'headline'};  sequence of field/subfield data generated by normalization.
160    
161          my @sorted_tags;  Repeatable field is created if there is second occurence of same subfield or
162          if ($self->{tags_by_order}) {  if any of indicators are different. This is sane for most cases except for
163                  @sorted_tags = @{$self->{tags_by_order}};  non-repeatable fields with repeatable subfields.
         } else {  
                 @sorted_tags = sort { $self->_sort_by_order } keys %{$self->{'import_xml'}->{'indexer'}};  
                 $self->{tags_by_order} = \@sorted_tags;  
         }  
164    
165          my $ds;  You can change behaviour of that using C<marc_repeatable_subfield>.
166    
167          $log->debug("tags: ",sub { join(", ",@sorted_tags) });  =cut
168    
169          foreach my $field (@sorted_tags) {  sub _get_marc_fields {
170    
171                  my $row;          return if (! $marc_record || ref($marc_record) ne 'ARRAY' || $#{ $marc_record } < 0);
172    
173  #print "field $field [",$self->{'tag'},"] = ",Dumper($self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}});          # first, sort all existing fields
174            # XXX might not be needed, but modern perl might randomize elements in hash
175            my @sorted_marc_record = sort {
176                    $a->[0] . $a->[3] cmp $b->[0] . $b->[3]
177            } @{ $marc_record };
178    
179                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {          # output marc fields
180                          my $format;          my @m;
181    
182                          $log->logdie("expected tag HASH and got $tag") unless (ref($tag) eq 'HASH');          # count unique field-subfields (used for offset when walking to next subfield)
183                          $format = $tag->{'value'} || $tag->{'content'};          my $u;
184            map { $u->{ $_->[0] . $_->[3]  }++ } @sorted_marc_record;
185    
186                          $log->debug("format: $format");          if ($debug) {
187                    warn "## marc_repeatable_subfield ", dump( $marc_repeatable_subfield ), $/;
188                    warn "## marc_record ", dump( $marc_record ), $/;
189                    warn "## sorted_marc_record ", dump( \@sorted_marc_record ), $/;
190                    warn "## subfield count ", dump( $u ), $/;
191            }
192    
193                          my @v;          my $len = $#sorted_marc_record;
194                          if ($self->{'lookup_regex'} && $format =~ $self->{'lookup_regex'}) {          my $visited;
195                                  @v = $self->fill_in_to_arr($rec,$format);          my $i = 0;
196                          } else {          my $field;
                                 @v = $self->parse_to_arr($rec,$format);  
                         }  
                         next if (! @v);  
197    
198                          if ($tag->{'sort'}) {          foreach ( 0 .. $len ) {
                                 @v = $self->sort_arr(@v);  
                         }  
199    
200                          # use format?                  # find next element which isn't visited
201                          if ($tag->{'format_name'}) {                  while ($visited->{$i}) {
202                                  @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;                          $i = ($i + 1) % ($len + 1);
203                          }                  }
204    
205                          # delimiter will join repeatable fields                  # mark it visited
206                          if ($tag->{'delimiter'}) {                  $visited->{$i}++;
                                 @v = ( join($tag->{'delimiter'}, @v) );  
                         }  
207    
208                          # default types                  my $row = $sorted_marc_record[$i];
                         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("type: $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;  
   
                                 } else {  
                                         push @{$row->{$type}}, @v;  
                                 }  
                         }  
209    
210                    # field and subfield which is key for
211                    # marc_repeatable_subfield and u
212                    my $fsf = $row->[0] . $row->[3];
213    
214                    if ($debug > 1) {
215    
216                            print "### field so far [", $#$field, "] : ", dump( $field ), " ", $field ? 'T' : 'F', $/;
217                            print "### this [$i]: ", dump( $row ),$/;
218                            print "### sf: ", $row->[3], " vs ", $field->[3],
219                                    $marc_repeatable_subfield->{ $row->[0] . $row->[3] } ? ' (repeatable)' : '', $/,
220                                    if ($#$field >= 0);
221    
222                  }                  }
223    
224                  if ($row) {                  # if field exists
225                          $row->{'tag'} = $field;                  if ( $#$field >= 0 ) {
226                            if (
227                                    $row->[0] ne $field->[0] ||             # field
228                                    $row->[1] ne $field->[1] ||             # i1
229                                    $row->[2] ne $field->[2]                # i2
230                            ) {
231                                    push @m, $field;
232                                    warn "## saved/1 ", dump( $field ),$/ if ($debug);
233                                    $field = $row;
234    
235                            } elsif (
236                                    ( $row->[3] lt $field->[-2] )           # subfield which is not next (e.g. a after c)
237                                    ||
238                                    ( $row->[3] eq $field->[-2] &&          # same subfield, but not repeatable
239                                            ! $marc_repeatable_subfield->{ $fsf }
240                                    )
241                            ) {
242                                    push @m, $field;
243                                    warn "## saved/2 ", dump( $field ),$/ if ($debug);
244                                    $field = $row;
245    
246                          # TODO: name_sigular, name_plural                          } else {
247                          my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};                                  # append new subfields to existing field
248                          my $row_name = $name ? $self->_x($name) : $field;                                  push @$field, ( $row->[3], $row->[4] );
   
                         # post-sort all values in field  
                         if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {  
                                 $log->warn("sort at field tag not implemented");  
249                          }                          }
250                    } else {
251                          $ds->{$row_name} = $row;                          # insert first field
252                            $field = $row;
                         $log->debug("row $field: ",sub { Dumper($row) });  
253                  }                  }
254    
255                    if (! $marc_repeatable_subfield->{ $fsf }) {
256                            # make step to next subfield
257                            $i = ($i + $u->{ $fsf } ) % ($len + 1);
258                    }
259          }          }
260    
261          $self->{'db'}->save_ds(          if ($#$field >= 0) {
262                  id => $id,                  push @m, $field;
263                  ds => $ds,                  warn "## saved/3 ", dump( $field ),$/ if ($debug);
264                  prefix => $self->{prefix},          }
         ) if ($self->{'db'});  
   
         $log->debug("ds: ", sub { Dumper($ds) });  
   
         $log->logconfess("data structure returned is not array any more!") if wantarray;  
   
         return $ds;  
265    
266            return @m;
267  }  }
268    
269  =head2 parse  =head1 Functions to create C<data_structure>
   
 Perform smart parsing of string, skipping delimiters for fields which aren't  
 defined. It can also eval code in format starting with C<eval{...}> and  
 return output or nothing depending on eval code.  
270    
271   my $text = $webpac->parse($rec,'eval{"v901^a" eq "Deskriptor"}descriptor: v250^a', $i);  Those functions generally have to first in your normalization file.
   
 =cut  
272    
273  sub parse {  =head2 tag
         my $self = shift;  
274    
275          my ($rec, $format_utf8, $i) = @_;  Define new tag for I<search> and I<display>.
276    
277          return if (! $format_utf8);    tag('Title', rec('200','a') );
278    
         my $log = $self->_get_logger();  
279    
280          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);  =cut
281    
282          $i = 0 if (! $i);  sub tag {
283            my $name = shift or die "tag needs name as first argument";
284            my @o = grep { defined($_) && $_ ne '' } @_;
285            return unless (@o);
286            $out->{$name}->{tag} = $name;
287            $out->{$name}->{search} = \@o;
288            $out->{$name}->{display} = \@o;
289    }
290    
291          my $format = $self->_x($format_utf8) || $log->logconfess("can't convert '$format_utf8' from UTF-8 to ",$self->{'code_page'});  =head2 display
292    
293          my @out;  Define tag just for I<display>
294    
295          $log->debug("format: $format");    @v = display('Title', rec('200','a') );
296    
297          my $eval_code;  =cut
         # remove eval{...} from beginning  
         $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);  
298    
299          my $filter_name;  sub display {
300          # remove filter{...} from beginning          my $name = shift or die "display needs name as first argument";
301          $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);          my @o = grep { defined($_) && $_ ne '' } @_;
302            return unless (@o);
303            $out->{$name}->{tag} = $name;
304            $out->{$name}->{display} = \@o;
305    }
306    
307          my $prefix;  =head2 search
         my $all_found=0;  
308    
309          while ($format =~ s/^(.*?)(v|s)(\d+)(?:\^(\w))?//s) {  Prepare values just for I<search>
310    
311                  my $del = $1 || '';    @v = search('Title', rec('200','a') );
                 $prefix ||= $del if ($all_found == 0);  
312    
313                  # repeatable index  =cut
                 my $r = $i;  
                 $r = 0 if (lc("$2") eq 's');  
314    
315                  my $found = 0;  sub search {
316                  my $tmp = $self->get_data(\$rec,$3,$4,$r,\$found);          my $name = shift or die "search needs name as first argument";
317            my @o = grep { defined($_) && $_ ne '' } @_;
318            return unless (@o);
319            $out->{$name}->{tag} = $name;
320            $out->{$name}->{search} = \@o;
321    }
322    
323                  if ($found) {  =head2 marc
                         push @out, $del;  
                         push @out, $tmp;  
                         $all_found += $found;  
                 }  
         }  
324    
325          return if (! $all_found);  Save value for MARC field
326    
327          my $out = join('',@out);    marc('900','a', rec('200','a') );
328    
329          if ($out) {  =cut
                 # add rest of format (suffix)  
                 $out .= $format;  
330    
331                  # add prefix if not there  sub marc {
332                  $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);          my $f = shift or die "marc needs field";
333            die "marc field must be numer" unless ($f =~ /^\d+$/);
334    
335                  $log->debug("result: $out");          my $sf = shift or die "marc needs subfield";
         }  
336    
337          if ($eval_code) {          foreach (@_) {
338                  my $eval = $self->fill_in($rec,$eval_code,$i) || return;                  my $v = $_;             # make var read-write for Encode
339                  $log->debug("about to eval{$eval} format: $out");                  next unless (defined($v) && $v !~ /^\s*$/);
340                  return if (! $self->_eval($eval));                  from_to($v, 'iso-8859-2', $marc_encoding) if ($marc_encoding);
341          }                  my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');
342                            push @{ $marc_record }, [ $f, $i1, $i2, $sf => $v ];
         if ($filter_name && $self->{'filter'}->{$filter_name}) {  
                 $log->debug("about to filter{$filter_name} format: $out");  
                 $out = $self->{'filter'}->{$filter_name}->($out);  
                 return unless(defined($out));  
                 $log->debug("filter result: $out");  
343          }          }
   
         return $out;  
344  }  }
345    
346  =head2 parse_to_arr  =head2 marc_repeatable_subfield
347    
348  Similar to C<parse>, but returns array of all repeatable fields  Save values for MARC repetable subfield
349    
350   my @arr = $webpac->parse_to_arr($rec,'v250^a');    marc_repeatable_subfield('910', 'z', rec('909') );
351    
352  =cut  =cut
353    
354  sub parse_to_arr {  sub marc_repeatable_subfield {
355          my $self = shift;          my ($f,$sf) = @_;
356            die "marc_repeatable_subfield need field and subfield!\n" unless ($f && $sf);
357            $marc_repeatable_subfield->{ $f . $sf }++;
358            marc(@_);
359    }
360    
361          my ($rec, $format_utf8) = @_;  =head2 marc_indicators
362    
363          my $log = $self->_get_logger();  Set both indicators for MARC field
364    
365          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);    marc_indicators('900', ' ', 1);
         return if (! $format_utf8);  
366    
367          my $i = 0;  Any indicator value other than C<0-9> will be treated as undefined.
         my @arr;  
368    
369          while (my $v = $self->parse($rec,$format_utf8,$i++)) {  =cut
                 push @arr, $v;  
         }  
370    
371          $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);  sub marc_indicators {
372            my $f = shift || die "marc_indicators need field!\n";
373            my ($i1,$i2) = @_;
374            die "marc_indicators($f, ...) need i1!\n" unless(defined($i1));
375            die "marc_indicators($f, $i1, ...) need i2!\n" unless(defined($i2));
376    
377          return @arr;          $i1 = ' ' if ($i1 !~ /^\d$/);
378            $i2 = ' ' if ($i2 !~ /^\d$/);
379            @{ $marc_indicators->{$f} } = ($i1,$i2);
380  }  }
381    
382    
383  =head2 fill_in  =head1 Functions to extract data from input
384    
385  Workhourse of all: takes record from in-memory structure of database and  This function should be used inside functions to create C<data_structure> described
386  strings with placeholders and returns string or array of with substituted  above.
 values from record.  
387    
388   my $text = $webpac->fill_in($rec,'v250^a');  =head2 rec1
389    
390  Optional argument is ordinal number for repeatable fields. By default,  Return all values in some field
 it's assume to be first repeatable field (fields are perl array, so first  
 element is 0).  
 Following example will read second value from repeatable field.  
391    
392   my $text = $webpac->fill_in($rec,'Title: v250^a',1);    @v = rec1('200')
393    
394  This function B<does not> perform parsing of format to inteligenty skip  TODO: order of values is probably same as in source data, need to investigate that
 delimiters before fields which aren't used.  
   
 This method will automatically decode UTF-8 string to local code page  
 if needed.  
395    
396  =cut  =cut
397    
398  sub fill_in {  sub rec1 {
399          my $self = shift;          my $f = shift;
400            return unless (defined($rec) && defined($rec->{$f}));
401          my $log = $self->_get_logger();          if (ref($rec->{$f}) eq 'ARRAY') {
402                    return map {
403          my $rec = shift || $log->logconfess("need data record");                          if (ref($_) eq 'HASH') {
404          my $format = shift || $log->logconfess("need format to parse");                                  values %{$_};
         # iteration (for repeatable fields)  
         my $i = shift || 0;  
   
         $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));  
   
         # FIXME remove for speedup?  
         $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);  
   
         if (utf8::is_utf8($format)) {  
                 $format = $self->_x($format);  
         }  
   
         my $found = 0;  
   
         my $eval_code;  
         # remove eval{...} from beginning  
         $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);  
   
         my $filter_name;  
         # remove filter{...} from beginning  
         $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);  
   
         # do actual replacement of placeholders  
         # repeatable fields  
         $format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;  
         # non-repeatable fields  
         $format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found)/ges;  
   
         if ($found) {  
                 $log->debug("format: $format");  
                 if ($eval_code) {  
                         my $eval = $self->fill_in($rec,$eval_code,$i);  
                         return if (! $self->_eval($eval));  
                 }  
                 if ($filter_name && $self->{'filter'}->{$filter_name}) {  
                         $log->debug("filter '$filter_name' for $format");  
                         $format = $self->{'filter'}->{$filter_name}->($format);  
                         return unless(defined($format));  
                         $log->debug("filter result: $format");  
                 }  
                 # do we have lookups?  
                 if ($self->{'lookup'}) {  
                         if ($self->{'lookup'}->can('lookup')) {  
                                 my @lookup = $self->{lookup}->lookup($format);  
                                 $log->debug('lookup $format', join(", ", @lookup));  
                                 return @lookup;  
405                          } else {                          } else {
406                                  $log->warn("Have lookup object but can't invoke lookup method");                                  $_;
407                          }                          }
408                  } else {                  } @{ $rec->{$f} };
409                          return $format;          } elsif( defined($rec->{$f}) ) {
410                  }                  return $rec->{$f};
         } else {  
                 return;  
411          }          }
412  }  }
413    
414    =head2 rec2
415    
416  =head2 fill_in_to_arr  Return all values in specific field and subfield
417    
418  Similar to C<fill_in>, but returns array of all repeatable fields. Usable    @v = rec2('200','a')
 for fields which have lookups, so they shouldn't be parsed but rather  
 C<fill_id>ed.  
   
  my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]');  
419    
420  =cut  =cut
421    
422  sub fill_in_to_arr {  sub rec2 {
423          my $self = shift;          my $f = shift;
424            return unless (defined($rec && $rec->{$f}));
425            my $sf = shift;
426            return map { $_->{$sf} } grep { ref($_) eq 'HASH' && $_->{$sf} } @{ $rec->{$f} };
427    }
428    
429          my ($rec, $format_utf8) = @_;  =head2 rec
430    
431          my $log = $self->_get_logger();  syntaxtic sugar for
432    
433          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);    @v = rec('200')
434          return if (! $format_utf8);    @v = rec('200','a')
435    
436          my $i = 0;  =cut
         my @arr;  
437    
438          while (my @v = $self->fill_in($rec,$format_utf8,$i++)) {  sub rec {
439                  push @arr, @v;          if ($#_ == 0) {
440                    return rec1(@_);
441            } elsif ($#_ == 1) {
442                    return rec2(@_);
443          }          }
   
         $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);  
   
         return @arr;  
444  }  }
445    
446    =head2 regex
447    
448  =head2 get_data  Apply regex to some or all values
   
 Returns value from record.  
   
  my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);  
449    
450  Arguments are:    @v = regex( 's/foo/bar/g', @v );
 record reference C<$rec>,  
 field C<$f>,  
 optional subfiled C<$sf>,  
 index for repeatable values C<$i>.  
   
 Optinal variable C<$found> will be incremeted if there  
 is field.  
   
 Returns value or empty string.  
451    
452  =cut  =cut
453    
454  sub get_data {  sub regex {
455          my $self = shift;          my $r = shift;
456            my @out;
457          my ($rec,$f,$sf,$i,$found) = @_;          #warn "r: $r\n", dump(\@_);
458            foreach my $t (@_) {
459          if ($$rec->{$f}) {                  next unless ($t);
460                  return '' if (! $$rec->{$f}->[$i]);                  eval "\$t =~ $r";
461                  no strict 'refs';                  push @out, $t if ($t && $t ne '');
                 if ($sf && $$rec->{$f}->[$i]->{$sf}) {  
                         $$found++ if (defined($$found));  
                         return $$rec->{$f}->[$i]->{$sf};  
                 } elsif (! $sf && $$rec->{$f}->[$i]) {  
                         $$found++ if (defined($$found));  
                         # it still might have subfield, just  
                         # not specified, so we'll dump all  
                         if ($$rec->{$f}->[$i] =~ /HASH/o) {  
                                 my $out;  
                                 foreach my $k (keys %{$$rec->{$f}->[$i]}) {  
                                         $out .= $$rec->{$f}->[$i]->{$k}." ";  
                                 }  
                                 return $out;  
                         } else {  
                                 return $$rec->{$f}->[$i];  
                         }  
                 } else {  
                         return '';  
                 }  
         } else {  
                 return '';  
462          }          }
463            return @out;
464  }  }
465    
466    =head2 prefix
467    
468  =head2 apply_format  Prefix all values with a string
   
 Apply format specified in tag with C<format_name="name"> and  
 C<format_delimiter=";;">.  
   
  my $text = $webpac->apply_format($format_name,$format_delimiter,$data);  
469    
470  Formats can contain C<lookup{...}> if you need them.    @v = prefix( 'my_', @v );
471    
472  =cut  =cut
473    
474  sub apply_format {  sub prefix {
475          my $self = shift;          my $p = shift or die "prefix needs string as first argument";
476            return map { $p . $_ } grep { defined($_) } @_;
477          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);  
478    
479          my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");  =head2 suffix
480    
481          my @data = split(/\Q$delimiter\E/, $data);  suffix all values with a string
482    
483          my $out = sprintf($format, @data);    @v = suffix( '_my', @v );
         $log->debug("using format $name [$format] on $data to produce: $out");  
484    
485          if ($self->{'lookup_regex'} && $out =~ $self->{'lookup_regex'}) {  =cut
                 return $self->{'lookup'}->lookup($out);  
         } else {  
                 return $out;  
         }  
486    
487    sub suffix {
488            my $s = shift or die "suffix needs string as first argument";
489            return map { $_ . $s } grep { defined($_) } @_;
490  }  }
491    
492  =head2 sort_arr  =head2 surround
493    
494  Sort array ignoring case and html in data  surround all values with a two strings
495    
496   my @sorted = $webpac->sort_arr(@unsorted);    @v = surround( 'prefix_', '_suffix', @v );
497    
498  =cut  =cut
499    
500  sub sort_arr {  sub surround {
501          my $self = shift;          my $p = shift or die "surround need prefix as first argument";
502            my $s = shift or die "surround needs suffix as second argument";
503          my $log = $self->_get_logger();          return map { $p . $_ . $s } grep { defined($_) } @_;
   
         # FIXME add Schwartzian Transformation?  
   
         my @sorted = sort {  
                 $a =~ s#<[^>]+/*>##;  
                 $b =~ s#<[^>]+/*>##;  
                 lc($b) cmp lc($a)  
         } @_;  
         $log->debug("sorted values: ",sub { join(", ",@sorted) });  
   
         return @sorted;  
504  }  }
505    
506    =head2 first
507    
508  =head1 INTERNAL METHODS  Return first element
   
 =head2 _sort_by_order  
509    
510  Sort xml tags data structure accoding to C<order=""> attribute.    $v = first( @v );
511    
512  =cut  =cut
513    
514  sub _sort_by_order {  sub first {
515          my $self = shift;          my $r = shift;
516            return $r;
         my $va = $self->{'import_xml'}->{'indexer'}->{$a}->{'order'} ||  
                 $self->{'import_xml'}->{'indexer'}->{$a};  
         my $vb = $self->{'import_xml'}->{'indexer'}->{$b}->{'order'} ||  
                 $self->{'import_xml'}->{'indexer'}->{$b};  
   
         return $va <=> $vb;  
517  }  }
518    
519  =head2 _x  =head2 lookup
520    
521  Convert strings from C<conf/normalize/*.xml> encoding into application  Consult lookup hashes for some value
 specific encoding (optinally specified using C<code_page> to C<new>  
 constructor).  
522    
523   my $text = $n->_x('normalize text string');    @v = lookup( $v );
524      @v = lookup( @v );
 This is a stub so that other modules doesn't have to implement it.  
525    
526  =cut  =cut
527    
528  sub _x {  sub lookup {
529          my $self = shift;          my $k = shift or return;
530          return shift;          return unless (defined($lookup->{$k}));
531            if (ref($lookup->{$k}) eq 'ARRAY') {
532                    return @{ $lookup->{$k} };
533            } else {
534                    return $lookup->{$k};
535            }
536  }  }
537    
538    =head2 join_with
539    
540  =head1 AUTHOR  Joins walues with some delimiter
   
 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  
541    
542  =head1 COPYRIGHT & LICENSE    $v = join_with(", ", @v);
   
 Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.  
   
 This program is free software; you can redistribute it and/or modify it  
 under the same terms as Perl itself.  
543    
544  =cut  =cut
545    
546  1; # End of WebPAC::Normalize  sub join_with {
547            my $d = shift;
548            return join($d, grep { defined($_) && $_ ne '' } @_);
549    }
550    
551    # END
552    1;

Legend:
Removed from v.252  
changed lines
  Added in v.551

  ViewVC Help
Powered by ViewVC 1.1.26