/[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 538 by dpavlin, Thu Jun 29 15:29:19 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
10    
11          rec1 rec2 rec          rec1 rec2 rec
12          regex prefix suffix surround          regex prefix suffix surround
13          first lookup join_with          first lookup join_with
# Line 14  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/;
22    
23    # debugging warn(s)
24    my $debug = 0;
25    
26    
27  =head1 NAME  =head1 NAME
28    
# Line 22  WebPAC::Normalize - describe normalisato Line 30  WebPAC::Normalize - describe normalisato
30    
31  =head1 VERSION  =head1 VERSION
32    
33  Version 0.05  Version 0.07
34    
35  =cut  =cut
36    
37  our $VERSION = '0.05';  our $VERSION = '0.07';
38    
39  =head1 SYNOPSIS  =head1 SYNOPSIS
40    
# Line 39  means that you check it's validity befor Line 47  means that you check it's validity befor
47  C<perl -c normalize.pl>.  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> and C<search>.  types (on the left side of definition) are: C<tag>, C<display>, C<search> and
51    C<marc>.
52    
53  =head1 FUNCTIONS  =head1 FUNCTIONS
54    
# Line 54  Return data structure Line 63  Return data structure
63          lookup => $lookup->lookup_hash,          lookup => $lookup->lookup_hash,
64          row => $row,          row => $row,
65          rules => $normalize_pl_config,          rules => $normalize_pl_config,
66            marc_encoding => 'utf-8',
67    );    );
68    
69    Options C<lookup>, C<row>, C<rules> and C<log> are mandatory while all
70    other are optional.
71    
72  This function will B<die> if normalizastion can't be evaled.  This function will B<die> if normalizastion can't be evaled.
73    
74  Since this function isn't exported you have to call it with  Since this function isn't exported you have to call it with
# Line 72  sub data_structure { Line 85  sub data_structure {
85          no strict 'subs';          no strict 'subs';
86          _set_lookup( $arg->{lookup} );          _set_lookup( $arg->{lookup} );
87          _set_rec( $arg->{row} );          _set_rec( $arg->{row} );
88          _clean_ds();          _clean_ds( %{ $arg } );
89          eval "$arg->{rules}";          eval "$arg->{rules}";
90          die "error evaling $arg->{rules}: $@\n" if ($@);          die "error evaling $arg->{rules}: $@\n" if ($@);
91    
92          return _get_ds();          return _get_ds();
93  }  }
94    
# Line 100  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);
118    
119  sub _get_ds {  sub _get_ds {
120          return $out;          return $out;
# Line 115  Clean data structure hash for next recor Line 129  Clean data structure hash for next recor
129  =cut  =cut
130    
131  sub _clean_ds {  sub _clean_ds {
132          $out = undef;          my $a = {@_};
133            ($out,$marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators) = ();
134            $marc_encoding = $a->{marc_encoding};
135  }  }
136    
137  =head2 _set_lookup  =head2 _set_lookup
# Line 132  sub _set_lookup { Line 148  sub _set_lookup {
148          $lookup = shift;          $lookup = shift;
149  }  }
150    
151    =head2 _get_marc_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
158    sequence of field/subfield data generated by normalization.
159    
160    Repeatable field is created when there is second occurence of same subfield or
161    if any of indicators are different.
162    
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      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
185    
186    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;
198    
199            # count unique field-subfields (used for offset when walking to next subfield)
200            my $u;
201            map { $u->{ $_->[0] . $_->[3]  }++ } @sorted_marc_record;
202    
203            if ($debug) {
204                    warn "## marc_repeatable_subfield ", dump( $marc_repeatable_subfield ), $/;
205                    warn "## marc_record ", dump( $marc_record ), $/;
206                    warn "## sorted_marc_record ", dump( \@sorted_marc_record ), $/;
207                    warn "## subfield count ", dump( $u ), $/;
208            }
209    
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                    if (! $marc_repeatable_subfield->{ $fsf }) {
273                            # make step to next subfield
274                            $i = ($i + $u->{ $fsf } ) % ($len + 1);
275                    }
276            }
277    
278            if ($#$field >= 0) {
279                    push @m, $field;
280                    warn "## saved/3 ", dump( $field ),$/ if ($debug);
281            }
282    
283            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>
301    
302    Those functions generally have to first in your normalization file.
303    
304  =head2 tag  =head2 tag
305    
306  Define new tag for I<search> and I<display>.  Define new tag for I<search> and I<display>.
# Line 182  sub search { Line 351  sub search {
351          $out->{$name}->{search} = \@o;          $out->{$name}->{search} = \@o;
352  }  }
353    
354    =head2 marc
355    
356    Save value for MARC field
357    
358      marc('900','a', rec('200','a') );
359    
360    =cut
361    
362    sub marc {
363            my $f = shift or die "marc needs field";
364            die "marc field must be numer" unless ($f =~ /^\d+$/);
365    
366            my $sf = shift or die "marc needs subfield";
367    
368            foreach (@_) {
369                    my $v = $_;             # make var read-write for Encode
370                    next unless (defined($v) && $v !~ /^\s*$/);
371                    from_to($v, 'iso-8859-2', $marc_encoding) if ($marc_encoding);
372                    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
415    
416    This function should be used inside functions to create C<data_structure> described
417    above.
418    
419  =head2 rec1  =head2 rec1
420    
421  Return all values in some field  Return all values in some field
# Line 251  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.538  
changed lines
  Added in v.554
  ViewVC Help
Powered by ViewVC 1.1.26