/[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 554 by dpavlin, Sat Jul 1 10:19:29 2006 UTC
# Line 3  use Exporter 'import'; Line 3  use Exporter 'import';
3  @EXPORT = qw/  @EXPORT = qw/
4          _set_rec _set_lookup          _set_rec _set_lookup
5          _get_ds _clean_ds          _get_ds _clean_ds
6            _debug
7    
8          tag search display          tag search display
9          marc21          marc marc_indicators marc_repeatable_subfield
10    
11          rec1 rec2 rec          rec1 rec2 rec
12          regex prefix suffix surround          regex prefix suffix surround
# Line 16  use warnings; Line 17  use warnings;
17  use strict;  use strict;
18    
19  #use base qw/WebPAC::Common/;  #use base qw/WebPAC::Common/;
20  use Data::Dumper;  use Data::Dump qw/dump/;
21  use Encode qw/from_to/;  use Encode qw/from_to/;
22    
23    # debugging warn(s)
24    my $debug = 0;
25    
26    
27  =head1 NAME  =head1 NAME
28    
29  WebPAC::Normalize - describe normalisaton rules using sets  WebPAC::Normalize - describe normalisaton rules using sets
30    
31  =head1 VERSION  =head1 VERSION
32    
33  Version 0.06  Version 0.07
34    
35  =cut  =cut
36    
37  our $VERSION = '0.06';  our $VERSION = '0.07';
38    
39  =head1 SYNOPSIS  =head1 SYNOPSIS
40    
# Line 43  C<perl -c normalize.pl>. Line 48  C<perl -c normalize.pl>.
48    
49  Normalisation can generate multiple output normalized data. For now, supported output  Normalisation can generate multiple output normalized data. For now, supported output
50  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
51  C<marc21>.  C<marc>.
52    
53  =head1 FUNCTIONS  =head1 FUNCTIONS
54    
# Line 109  Return hash formatted as data structure Line 114  Return hash formatted as data structure
114    
115  =cut  =cut
116    
117  my $out;  my ($out,$marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators);
 my $marc21;  
 my $marc_encoding;  
118    
119  sub _get_ds {  sub _get_ds {
120          return $out;          return $out;
# Line 127  Clean data structure hash for next recor Line 130  Clean data structure hash for next recor
130    
131  sub _clean_ds {  sub _clean_ds {
132          my $a = {@_};          my $a = {@_};
133          $out = undef;          ($out,$marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators) = ();
         $marc21 = undef;  
134          $marc_encoding = $a->{marc_encoding};          $marc_encoding = $a->{marc_encoding};
135  }  }
136    
# Line 146  sub _set_lookup { Line 148  sub _set_lookup {
148          $lookup = shift;          $lookup = shift;
149  }  }
150    
151  =head2 _get_marc21_fields  =head2 _get_marc_fields
   
 Get all fields defined by calls to C<marc21>  
   
         $marc->add_fields( WebPAC::Normalize:_get_marc21_fields() );  
152    
153    Get all fields defined by calls to C<marc>
154    
155            $marc->add_fields( WebPAC::Normalize:_get_marc_fields() );
156    
157  We are using I<magic> which detect repeatable fields only from  We are using I<magic> which detect repeatable fields only from
158  sequence of field/subfield data generated by normalization.  sequence of field/subfield data generated by normalization.
159    
160  Repeatable field is created if there is second occurence of same subfield or  Repeatable field is created when there is second occurence of same subfield or
161  if any of indicators are different. This is sane for most cases except for  if any of indicators are different.
162  non-repeatable fields with repeatable subfields.  
163    This is sane for most cases. Something like:
164    
165      900a-1 900b-1 900c-1
166      900a-2 900b-2
167      900a-3
168    
169    will be created from any combination of:
170    
171  B<TODO>: implement exceptions to magic    900a-1 900a-2 900a-3 900b-1 900b-2 900c-1
172    
173    and following rules:
174    
175      marc('900','a', rec('200','a') );
176      marc('900','b', rec('200','b') );
177      marc('900','c', rec('200','c') );
178    
179    which might not be what you have in mind. If you need repeatable subfield,
180    define it using C<marc_repeatable_subfield> like this:
181    
182    ....
183    
184  =cut  =cut
185    
186  sub _get_marc21_fields {  sub _get_marc_fields {
187    
188            return if (! $marc_record || ref($marc_record) ne 'ARRAY' || $#{ $marc_record } < 0);
189    
190            # first, sort all existing fields
191            # XXX might not be needed, but modern perl might randomize elements in hash
192            my @sorted_marc_record = sort {
193                    $a->[0] . $a->[3] cmp $b->[0] . $b->[3]
194            } @{ $marc_record };
195    
196            # output marc fields
197          my @m;          my @m;
198          my $last;  
199          foreach my $row (@{ $marc21 }) {          # count unique field-subfields (used for offset when walking to next subfield)
200                  if ($last &&          my $u;
201                          $last->[0] eq $row->[0] &&              # check if field is same          map { $u->{ $_->[0] . $_->[3]  }++ } @sorted_marc_record;
202                          $last->[1] eq $row->[1] &&              # check for i1  
203                          $last->[2] eq $row->[2]                 # and for i2          if ($debug) {
204                  ) {                  warn "## marc_repeatable_subfield ", dump( $marc_repeatable_subfield ), $/;
205                          push @$last, ( $row->[3] , $row->[4] );                  warn "## marc_record ", dump( $marc_record ), $/;
206                          warn "## ++ added $row->[0] ^$row->[3] to $last->[0]\n";                  warn "## sorted_marc_record ", dump( \@sorted_marc_record ), $/;
207                          next;                  warn "## subfield count ", dump( $u ), $/;
208                  } elsif ($last) {          }
209                          push @m, $last;  
210            my $len = $#sorted_marc_record;
211            my $visited;
212            my $i = 0;
213            my $field;
214    
215            foreach ( 0 .. $len ) {
216    
217                    # find next element which isn't visited
218                    while ($visited->{$i}) {
219                            $i = ($i + 1) % ($len + 1);
220                    }
221    
222                    # mark it visited
223                    $visited->{$i}++;
224    
225                    my $row = $sorted_marc_record[$i];
226    
227                    # field and subfield which is key for
228                    # marc_repeatable_subfield and u
229                    my $fsf = $row->[0] . $row->[3];
230    
231                    if ($debug > 1) {
232    
233                            print "### field so far [", $#$field, "] : ", dump( $field ), " ", $field ? 'T' : 'F', $/;
234                            print "### this [$i]: ", dump( $row ),$/;
235                            print "### sf: ", $row->[3], " vs ", $field->[3],
236                                    $marc_repeatable_subfield->{ $row->[0] . $row->[3] } ? ' (repeatable)' : '', $/,
237                                    if ($#$field >= 0);
238    
239                    }
240    
241                    # if field exists
242                    if ( $#$field >= 0 ) {
243                            if (
244                                    $row->[0] ne $field->[0] ||             # field
245                                    $row->[1] ne $field->[1] ||             # i1
246                                    $row->[2] ne $field->[2]                # i2
247                            ) {
248                                    push @m, $field;
249                                    warn "## saved/1 ", dump( $field ),$/ if ($debug);
250                                    $field = $row;
251    
252                            } elsif (
253                                    ( $row->[3] lt $field->[-2] )           # subfield which is not next (e.g. a after c)
254                                    ||
255                                    ( $row->[3] eq $field->[-2] &&          # same subfield, but not repeatable
256                                            ! $marc_repeatable_subfield->{ $fsf }
257                                    )
258                            ) {
259                                    push @m, $field;
260                                    warn "## saved/2 ", dump( $field ),$/ if ($debug);
261                                    $field = $row;
262    
263                            } else {
264                                    # append new subfields to existing field
265                                    push @$field, ( $row->[3], $row->[4] );
266                            }
267                    } else {
268                            # insert first field
269                            $field = $row;
270                  }                  }
271    
272                  $last = $row;                  if (! $marc_repeatable_subfield->{ $fsf }) {
273                            # make step to next subfield
274                            $i = ($i + $u->{ $fsf } ) % ($len + 1);
275                    }
276          }          }
277    
278          push @m, $last if ($last);          if ($#$field >= 0) {
279                    push @m, $field;
280                    warn "## saved/3 ", dump( $field ),$/ if ($debug);
281            }
282    
283          return @m;          return @m;
284  }  }
285    
286    =head2 _debug
287    
288    Change level of debug warnings
289    
290      _debug( 2 );
291    
292    =cut
293    
294    sub _debug {
295            my $l = shift;
296            return $debug unless defined($l);
297            $debug = $l;
298    }
299    
300  =head1 Functions to create C<data_structure>  =head1 Functions to create C<data_structure>
301    
302  Those functions generally have to first in your normalization file.  Those functions generally have to first in your normalization file.
# Line 243  sub search { Line 351  sub search {
351          $out->{$name}->{search} = \@o;          $out->{$name}->{search} = \@o;
352  }  }
353    
354  =head2 marc21  =head2 marc
355    
356  Save value for MARC field  Save value for MARC field
357    
358    marc21('900','a', rec('200','a') );    marc('900','a', rec('200','a') );
359    
360  =cut  =cut
361    
362  sub marc21 {  sub marc {
363          my $f = shift or die "marc21 needs field";          my $f = shift or die "marc needs field";
364          die "marc21 field must be numer" unless ($f =~ /^\d+$/);          die "marc field must be numer" unless ($f =~ /^\d+$/);
365    
366          my $sf = shift or die "marc21 needs subfield";          my $sf = shift or die "marc needs subfield";
367    
368          foreach (@_) {          foreach (@_) {
369                  my $v = $_;             # make var read-write for Encode                  my $v = $_;             # make var read-write for Encode
370                  next unless (defined($v) && $v !~ /^\s*$/);                  next unless (defined($v) && $v !~ /^\s*$/);
371                  from_to($v, 'iso-8859-2', $marc_encoding) if ($marc_encoding);                  from_to($v, 'iso-8859-2', $marc_encoding) if ($marc_encoding);
372                  push @{ $marc21 }, [ $f, ' ', ' ', $sf => $v ];                  my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');
373                    push @{ $marc_record }, [ $f, $i1, $i2, $sf => $v ];
374          }          }
375  }  }
376    
377    =head2 marc_repeatable_subfield
378    
379    Save values for MARC repetable subfield
380    
381      marc_repeatable_subfield('910', 'z', rec('909') );
382    
383    =cut
384    
385    sub marc_repeatable_subfield {
386            my ($f,$sf) = @_;
387            die "marc_repeatable_subfield need field and subfield!\n" unless ($f && $sf);
388            $marc_repeatable_subfield->{ $f . $sf }++;
389            marc(@_);
390    }
391    
392    =head2 marc_indicators
393    
394    Set both indicators for MARC field
395    
396      marc_indicators('900', ' ', 1);
397    
398    Any indicator value other than C<0-9> will be treated as undefined.
399    
400    =cut
401    
402    sub marc_indicators {
403            my $f = shift || die "marc_indicators need field!\n";
404            my ($i1,$i2) = @_;
405            die "marc_indicators($f, ...) need i1!\n" unless(defined($i1));
406            die "marc_indicators($f, $i1, ...) need i2!\n" unless(defined($i2));
407    
408            $i1 = ' ' if ($i1 !~ /^\d$/);
409            $i2 = ' ' if ($i2 !~ /^\d$/);
410            @{ $marc_indicators->{$f} } = ($i1,$i2);
411    }
412    
413    
414  =head1 Functions to extract data from input  =head1 Functions to extract data from input
415    
416  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 485  Apply regex to some or all values
485  sub regex {  sub regex {
486          my $r = shift;          my $r = shift;
487          my @out;          my @out;
488          #warn "r: $r\n",Dumper(\@_);          #warn "r: $r\n", dump(\@_);
489          foreach my $t (@_) {          foreach my $t (@_) {
490                  next unless ($t);                  next unless ($t);
491                  eval "\$t =~ $r";                  eval "\$t =~ $r";
Legend:
Removed from v.543  
changed lines
  Added in v.554
  ViewVC Help
Powered by ViewVC 1.1.26