/[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 547 by dpavlin, Thu Jun 29 23:19:26 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          marc marc_indicators marc_repeatable_subfield          marc marc_indicators marc_repeatable_subfield
# 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 125  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,$marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators) = (undef);          ($out,$marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators) = ();
134          $marc_encoding = $a->{marc_encoding};          $marc_encoding = $a->{marc_encoding};
135  }  }
136    
# Line 149  Get all fields defined by calls to C<mar Line 154  Get all fields defined by calls to C<mar
154    
155          $marc->add_fields( WebPAC::Normalize:_get_marc_fields() );          $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  You can change behaviour of that using C<marc_repeatable_subfield>.    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      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_marc_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 (@{ $marc_record }) {          # 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                                  ( $last->[3] ne $row->[3] ||                            # and subfield is different                  warn "## marc_repeatable_subfield ", dump( $marc_repeatable_subfield ), $/;
205                                  $last->[3] eq $row->[3] &&                                      # or subfield is same,                  warn "## marc_record ", dump( $marc_record ), $/;
206                                  $marc_repeatable_subfield->{ $row->[3] }        # but is repeatable                  warn "## sorted_marc_record ", dump( \@sorted_marc_record ), $/;
207                          )                  warn "## subfield count ", dump( $u ), $/;
208                  ) {          }
209                          push @$last, ( $row->[3] , $row->[4] );  
210                          warn "## ++ added $row->[0] ^$row->[3] to $last->[0]\n";          my $len = $#sorted_marc_record;
211                          next;          my $visited;
212                  } elsif ($last) {          my $i = 0;
213                          push @m, $last;          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                  $last = $row;                  # 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                    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 262  sub marc { Line 369  sub marc {
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 @{ $marc_record }, [                  my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');
373                          $f,                  push @{ $marc_record }, [ $f, $i1, $i2, $sf => $v ];
                         $marc_indicators->{$f}->{i1} || ' ',  
                         $marc_indicators->{$f}->{i2} || ' ',  
                         $sf => $v  
                 ];  
374          }          }
375  }  }
376    
# Line 280  Save values for MARC repetable subfield Line 383  Save values for MARC repetable subfield
383  =cut  =cut
384    
385  sub marc_repeatable_subfield {  sub marc_repeatable_subfield {
386          die "marc_repeatable_subfield need subfield!\n" unless (defined($_[1]));          my ($f,$sf) = @_;
387          $marc_repeatable_subfield->{ $_[1] }++;          die "marc_repeatable_subfield need field and subfield!\n" unless ($f && $sf);
388            $marc_repeatable_subfield->{ $f . $sf }++;
389          marc(@_);          marc(@_);
390  }  }
391    
# Line 303  sub marc_indicators { Line 407  sub marc_indicators {
407    
408          $i1 = ' ' if ($i1 !~ /^\d$/);          $i1 = ' ' if ($i1 !~ /^\d$/);
409          $i2 = ' ' if ($i2 !~ /^\d$/);          $i2 = ' ' if ($i2 !~ /^\d$/);
410          $marc_indicators->{$f}->{i1} = $i1;          @{ $marc_indicators->{$f} } = ($i1,$i2);
         $marc_indicators->{$f}->{i2} = $i2;  
411  }  }
412    
413    
# Line 382  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.547  
changed lines
  Added in v.554

  ViewVC Help
Powered by ViewVC 1.1.26