/[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 541 by dpavlin, Thu Jun 29 21:18:50 2006 UTC revision 551 by dpavlin, Fri Jun 30 20:43:09 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<marc>
153    
154            $marc->add_fields( WebPAC::Normalize:_get_marc_fields() );
155    
156    
 Get all fields defined by calls to C<marc21>  
157    
158          $marc->add_fields( WebPAC::Normalize:_get_marc21_fields() );  We are using I<magic> which detect repeatable fields only from
159    sequence of field/subfield data generated by normalization.
160    
161    Repeatable field is created if there is second occurence of same subfield or
162    if any of indicators are different. This is sane for most cases except for
163    non-repeatable fields with repeatable subfields.
164    
165    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          return @{$marc21};  
171            return if (! $marc_record || ref($marc_record) ne 'ARRAY' || $#{ $marc_record } < 0);
172    
173            # 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            # output marc fields
180            my @m;
181    
182            # count unique field-subfields (used for offset when walking to next subfield)
183            my $u;
184            map { $u->{ $_->[0] . $_->[3]  }++ } @sorted_marc_record;
185    
186            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 $len = $#sorted_marc_record;
194            my $visited;
195            my $i = 0;
196            my $field;
197    
198            foreach ( 0 .. $len ) {
199    
200                    # find next element which isn't visited
201                    while ($visited->{$i}) {
202                            $i = ($i + 1) % ($len + 1);
203                    }
204    
205                    # mark it visited
206                    $visited->{$i}++;
207    
208                    my $row = $sorted_marc_record[$i];
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 field exists
225                    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                            } else {
247                                    # append new subfields to existing field
248                                    push @$field, ( $row->[3], $row->[4] );
249                            }
250                    } else {
251                            # insert first field
252                            $field = $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            if ($#$field >= 0) {
262                    push @m, $field;
263                    warn "## saved/3 ", dump( $field ),$/ if ($debug);
264            }
265    
266            return @m;
267  }  }
268    
269  =head1 Functions to create C<data_structure>  =head1 Functions to create C<data_structure>
# Line 212  sub search { Line 320  sub search {
320          $out->{$name}->{search} = \@o;          $out->{$name}->{search} = \@o;
321  }  }
322    
323  =head2 marc21  =head2 marc
324    
325  Save value for MARC field  Save value for MARC field
326    
327    marc21('900','a', rec('200','a') );    marc('900','a', rec('200','a') );
328    
329  =cut  =cut
330    
331  sub marc21 {  sub marc {
332          my $f = shift or die "marc21 needs field";          my $f = shift or die "marc needs field";
333          die "marc21 field must be numer" unless ($f =~ /^\d+$/);          die "marc field must be numer" unless ($f =~ /^\d+$/);
334    
335          my $sf = shift or die "marc21 needs subfield";          my $sf = shift or die "marc needs subfield";
336    
337          foreach (@_) {          foreach (@_) {
338                  my $v = $_;             # make var read-write for Encode                  my $v = $_;             # make var read-write for Encode
339                  next unless (defined($v) && $v !~ /^\s+$/);                  next unless (defined($v) && $v !~ /^\s*$/);
340                  from_to($v, 'iso-8859-2', $marc_encoding) if ($marc_encoding);                  from_to($v, 'iso-8859-2', $marc_encoding) if ($marc_encoding);
341                  push @{ $marc21 }, [ $f, ' ', ' ', $sf => $v ];                  my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');
342                    push @{ $marc_record }, [ $f, $i1, $i2, $sf => $v ];
343          }          }
344  }  }
345    
346    =head2 marc_repeatable_subfield
347    
348    Save values for MARC repetable subfield
349    
350      marc_repeatable_subfield('910', 'z', rec('909') );
351    
352    =cut
353    
354    sub marc_repeatable_subfield {
355            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    =head2 marc_indicators
362    
363    Set both indicators for MARC field
364    
365      marc_indicators('900', ' ', 1);
366    
367    Any indicator value other than C<0-9> will be treated as undefined.
368    
369    =cut
370    
371    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            $i1 = ' ' if ($i1 !~ /^\d$/);
378            $i2 = ' ' if ($i2 !~ /^\d$/);
379            @{ $marc_indicators->{$f} } = ($i1,$i2);
380    }
381    
382    
383  =head1 Functions to extract data from input  =head1 Functions to extract data from input
384    
385  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 308  Apply regex to some or all values Line 454  Apply regex to some or all values
454  sub regex {  sub regex {
455          my $r = shift;          my $r = shift;
456          my @out;          my @out;
457          #warn "r: $r\n",Dumper(\@_);          #warn "r: $r\n", dump(\@_);
458          foreach my $t (@_) {          foreach my $t (@_) {
459                  next unless ($t);                  next unless ($t);
460                  eval "\$t =~ $r";                  eval "\$t =~ $r";

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

  ViewVC Help
Powered by ViewVC 1.1.26