/[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 543 by dpavlin, Thu Jun 29 21:19:08 2006 UTC revision 550 by dpavlin, Fri Jun 30 18:48:33 2006 UTC
# Line 5  use Exporter 'import'; Line 5  use Exporter 'import';
5          _get_ds _clean_ds          _get_ds _clean_ds
6    
7          tag search display          tag search display
8          marc21          marc marc_indicators marc_repeatable_subfield
9    
10          rec1 rec2 rec          rec1 rec2 rec
11          regex prefix suffix surround          regex prefix suffix surround
# Line 16  use warnings; Line 16  use warnings;
16  use strict;  use strict;
17    
18  #use base qw/WebPAC::Common/;  #use base qw/WebPAC::Common/;
19  use Data::Dumper;  use Data::Dump qw/dump/;
20  use Encode qw/from_to/;  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 - describe normalisaton rules using sets  WebPAC::Normalize - describe normalisaton rules using sets
# Line 43  C<perl -c normalize.pl>. Line 47  C<perl -c normalize.pl>.
47    
48  Normalisation can generate multiple output normalized data. For now, supported output  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  types (on the left side of definition) are: C<tag>, C<display>, C<search> and
50  C<marc21>.  C<marc>.
51    
52  =head1 FUNCTIONS  =head1 FUNCTIONS
53    
# Line 109  Return hash formatted as data structure Line 113  Return hash formatted as data structure
113    
114  =cut  =cut
115    
116  my $out;  my ($out,$marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators);
 my $marc21;  
 my $marc_encoding;  
117    
118  sub _get_ds {  sub _get_ds {
119          return $out;          return $out;
# Line 127  Clean data structure hash for next recor Line 129  Clean data structure hash for next recor
129    
130  sub _clean_ds {  sub _clean_ds {
131          my $a = {@_};          my $a = {@_};
132          $out = undef;          ($out,$marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators) = ();
         $marc21 = undef;  
133          $marc_encoding = $a->{marc_encoding};          $marc_encoding = $a->{marc_encoding};
134  }  }
135    
# Line 146  sub _set_lookup { Line 147  sub _set_lookup {
147          $lookup = shift;          $lookup = shift;
148  }  }
149    
150  =head2 _get_marc21_fields  =head2 _get_marc_fields
151    
152  Get all fields defined by calls to C<marc21>  Get all fields defined by calls to C<marc>
153    
154          $marc->add_fields( WebPAC::Normalize:_get_marc21_fields() );          $marc->add_fields( WebPAC::Normalize:_get_marc_fields() );
155    
156    
157    
# Line 161  Repeatable field is created if there is Line 162  Repeatable field is created if there is
162  if any of indicators are different. This is sane for most cases except for  if any of indicators are different. This is sane for most cases except for
163  non-repeatable fields with repeatable subfields.  non-repeatable fields with repeatable subfields.
164    
165  B<TODO>: implement exceptions to magic  You can change behaviour of that using C<marc_repeatable_subfield>.
166    
167  =cut  =cut
168    
169  sub _get_marc21_fields {  sub _get_marc_fields {
170    
171    
172            # first, sort all existing fields
173            # XXX might not be needed, but modern perl might randomize elements in hash
174            my @sorted_marc_record = sort {
175                    $a->[0] . $a->[3] cmp $b->[0] . $b->[3]
176            } @{ $marc_record };
177    
178            # output marc fields
179          my @m;          my @m;
180          my $last;  
181          foreach my $row (@{ $marc21 }) {          # count unique field-subfields (used for offset when walking to next subfield)
182                  if ($last &&          my $u;
183                          $last->[0] eq $row->[0] &&              # check if field is same          map { $u->{ $_->[0] . $_->[3]  }++ } @sorted_marc_record;
184                          $last->[1] eq $row->[1] &&              # check for i1  
185                          $last->[2] eq $row->[2]                 # and for i2          if ($debug) {
186                  ) {                  warn "## marc_repeatable_subfield ", dump( $marc_repeatable_subfield ), $/;
187                          push @$last, ( $row->[3] , $row->[4] );                  warn "## marc_record ", dump( $marc_record ), $/;
188                          warn "## ++ added $row->[0] ^$row->[3] to $last->[0]\n";                  warn "## sorted_marc_record ", dump( \@sorted_marc_record ), $/;
189                          next;                  warn "## subfield count ", dump( $u ), $/;
190                  } elsif ($last) {          }
191                          push @m, $last;  
192            my $len = $#sorted_marc_record;
193            my $visited;
194            my $i = 0;
195            my $field;
196    
197            foreach ( 0 .. $len ) {
198    
199                    # find next element which isn't visited
200                    while ($visited->{$i}) {
201                            $i = ($i + 1) % ($len + 1);
202                  }                  }
203    
204                  $last = $row;                  # mark it visited
205                    $visited->{$i}++;
206    
207                    my $row = $sorted_marc_record[$i];
208    
209                    # field and subfield which is key for
210                    # marc_repeatable_subfield and u
211                    my $fsf = $row->[0] . $row->[3];
212    
213                    if ($debug > 1) {
214    
215                            print "### field so far [", $#$field, "] : ", dump( $field ), " ", $field ? 'T' : 'F', $/;
216                            print "### this [$i]: ", dump( $row ),$/;
217                            print "### sf: ", $row->[3], " vs ", $field->[3],
218                                    $marc_repeatable_subfield->{ $row->[0] . $row->[3] } ? ' (repeatable)' : '', $/,
219                                    if ($#$field >= 0);
220    
221                    }
222    
223                    # if field exists
224                    if ( $#$field >= 0 ) {
225                            if (
226                                    $row->[0] ne $field->[0] ||             # field
227                                    $row->[1] ne $field->[1] ||             # i1
228                                    $row->[2] ne $field->[2]                # i2
229                            ) {
230                                    push @m, $field;
231                                    warn "## saved/1 ", dump( $field ),$/ if ($debug);
232                                    $field = $row;
233    
234                            } elsif (
235                                    ( $row->[3] lt $field->[-2] )           # subfield which is not next (e.g. a after c)
236                                    ||
237                                    ( $row->[3] eq $field->[-2] &&          # same subfield, but not repeatable
238                                            ! $marc_repeatable_subfield->{ $fsf }
239                                    )
240                            ) {
241                                    push @m, $field;
242                                    warn "## saved/2 ", dump( $field ),$/ if ($debug);
243                                    $field = $row;
244    
245                            } else {
246                                    # append new subfields to existing field
247                                    push @$field, ( $row->[3], $row->[4] );
248                            }
249                    } else {
250                            # insert first field
251                            $field = $row;
252                    }
253    
254                    if (! $marc_repeatable_subfield->{ $fsf }) {
255                            # make step to next subfield
256                            $i = ($i + $u->{ $fsf } ) % ($len + 1);
257                    }
258          }          }
259    
260          push @m, $last if ($last);          if ($#$field >= 0) {
261                    push @m, $field;
262                    warn "## saved/3 ", dump( $field ),$/ if ($debug);
263            }
264    
265          return @m;          return @m;
266  }  }
# Line 243  sub search { Line 319  sub search {
319          $out->{$name}->{search} = \@o;          $out->{$name}->{search} = \@o;
320  }  }
321    
322  =head2 marc21  =head2 marc
323    
324  Save value for MARC field  Save value for MARC field
325    
326    marc21('900','a', rec('200','a') );    marc('900','a', rec('200','a') );
327    
328  =cut  =cut
329    
330  sub marc21 {  sub marc {
331          my $f = shift or die "marc21 needs field";          my $f = shift or die "marc needs field";
332          die "marc21 field must be numer" unless ($f =~ /^\d+$/);          die "marc field must be numer" unless ($f =~ /^\d+$/);
333    
334          my $sf = shift or die "marc21 needs subfield";          my $sf = shift or die "marc needs subfield";
335    
336          foreach (@_) {          foreach (@_) {
337                  my $v = $_;             # make var read-write for Encode                  my $v = $_;             # make var read-write for Encode
338                  next unless (defined($v) && $v !~ /^\s*$/);                  next unless (defined($v) && $v !~ /^\s*$/);
339                  from_to($v, 'iso-8859-2', $marc_encoding) if ($marc_encoding);                  from_to($v, 'iso-8859-2', $marc_encoding) if ($marc_encoding);
340                  push @{ $marc21 }, [ $f, ' ', ' ', $sf => $v ];                  my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');
341                    push @{ $marc_record }, [ $f, $i1, $i2, $sf => $v ];
342          }          }
343  }  }
344    
345    =head2 marc_repeatable_subfield
346    
347    Save values for MARC repetable subfield
348    
349      marc_repeatable_subfield('910', 'z', rec('909') );
350    
351    =cut
352    
353    sub marc_repeatable_subfield {
354            my ($f,$sf) = @_;
355            die "marc_repeatable_subfield need field and subfield!\n" unless ($f && $sf);
356            $marc_repeatable_subfield->{ $f . $sf }++;
357            marc(@_);
358    }
359    
360    =head2 marc_indicators
361    
362    Set both indicators for MARC field
363    
364      marc_indicators('900', ' ', 1);
365    
366    Any indicator value other than C<0-9> will be treated as undefined.
367    
368    =cut
369    
370    sub marc_indicators {
371            my $f = shift || die "marc_indicators need field!\n";
372            my ($i1,$i2) = @_;
373            die "marc_indicators($f, ...) need i1!\n" unless(defined($i1));
374            die "marc_indicators($f, $i1, ...) need i2!\n" unless(defined($i2));
375    
376            $i1 = ' ' if ($i1 !~ /^\d$/);
377            $i2 = ' ' if ($i2 !~ /^\d$/);
378            @{ $marc_indicators->{$f} } = ($i1,$i2);
379    }
380    
381    
382  =head1 Functions to extract data from input  =head1 Functions to extract data from input
383    
384  This function should be used inside functions to create C<data_structure> described  This function should be used inside functions to create C<data_structure> described
# Line 339  Apply regex to some or all values Line 453  Apply regex to some or all values
453  sub regex {  sub regex {
454          my $r = shift;          my $r = shift;
455          my @out;          my @out;
456          #warn "r: $r\n",Dumper(\@_);          #warn "r: $r\n", dump(\@_);
457          foreach my $t (@_) {          foreach my $t (@_) {
458                  next unless ($t);                  next unless ($t);
459                  eval "\$t =~ $r";                  eval "\$t =~ $r";

Legend:
Removed from v.543  
changed lines
  Added in v.550

  ViewVC Help
Powered by ViewVC 1.1.26