/[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 915 by dpavlin, Tue Oct 30 20:27:20 2007 UTC revision 1012 by dpavlin, Wed Nov 7 09:19:29 2007 UTC
# Line 1  Line 1 
1  package WebPAC::Normalize;  package WebPAC::Normalize;
2  use Exporter 'import';  use Exporter 'import';
3  @EXPORT = qw/  our @EXPORT = qw/
4          _set_rec _set_lookup          _set_ds _set_lookup
5          _set_load_row          _set_load_row
6          _get_ds _clean_ds          _get_ds _clean_ds
7          _debug          _debug
8          _pack_subfields_hash          _pack_subfields_hash
9    
10          search_display search display          search_display search display sorted
11    
12          marc marc_indicators marc_repeatable_subfield          marc marc_indicators marc_repeatable_subfield
13          marc_compose marc_leader marc_fixed          marc_compose marc_leader marc_fixed
# Line 15  use Exporter 'import'; Line 15  use Exporter 'import';
15          marc_original_order          marc_original_order
16    
17          rec1 rec2 rec          rec1 rec2 rec
18            frec
19          regex prefix suffix surround          regex prefix suffix surround
20          first lookup join_with          first lookup join_with
21          save_into_lookup          save_into_lookup
# Line 23  use Exporter 'import'; Line 24  use Exporter 'import';
24    
25          get set          get set
26          count          count
27    
28  /;  /;
29    
30  use warnings;  use warnings;
# Line 36  use Carp qw/confess/; Line 38  use Carp qw/confess/;
38  # debugging warn(s)  # debugging warn(s)
39  my $debug = 0;  my $debug = 0;
40    
41    use WebPAC::Normalize::ISBN;
42    push @EXPORT, ( 'isbn_10', 'isbn_13' );
43    
44  =head1 NAME  =head1 NAME
45    
46  WebPAC::Normalize - describe normalisaton rules using sets  WebPAC::Normalize - describe normalisaton rules using sets
47    
 =head1 VERSION  
   
 Version 0.30  
   
48  =cut  =cut
49    
50  our $VERSION = '0.30';  our $VERSION = '0.32';
51    
52  =head1 SYNOPSIS  =head1 SYNOPSIS
53    
# Line 79  Return data structure Line 79  Return data structure
79          marc_encoding => 'utf-8',          marc_encoding => 'utf-8',
80          config => $config,          config => $config,
81          load_row_coderef => sub {          load_row_coderef => sub {
82                  my ($database,$input,$mfn) = shift;                  my ($database,$input,$mfn) = @_;
83                  $store->load_row( database => $database, input => $input, id => $mfn );                  $store->load_row( database => $database, input => $input, id => $mfn );
84          },          },
85    );    );
# Line 105  sub data_structure { Line 105  sub data_structure {
105          die "need row argument" unless ($arg->{row});          die "need row argument" unless ($arg->{row});
106          die "need normalisation argument" unless ($arg->{rules});          die "need normalisation argument" unless ($arg->{rules});
107    
         no strict 'subs';  
108          _set_lookup( $arg->{lookup} ) if defined($arg->{lookup});          _set_lookup( $arg->{lookup} ) if defined($arg->{lookup});
109          _set_rec( $arg->{row} );          _set_ds( $arg->{row} );
110          _set_config( $arg->{config} ) if defined($arg->{config});          _set_config( $arg->{config} ) if defined($arg->{config});
111          _clean_ds( %{ $arg } );          _clean_ds( %{ $arg } );
112          $load_row_coderef = $arg->{load_row_coderef};          $load_row_coderef = $arg->{load_row_coderef};
113    
114          eval "$arg->{rules}";          no strict 'subs';
115            no warnings 'redefine';
116            eval "$arg->{rules};";
117          die "error evaling $arg->{rules}: $@\n" if ($@);          die "error evaling $arg->{rules}: $@\n" if ($@);
118    
119          return _get_ds();          return _get_ds();
120  }  }
121    
122  =head2 _set_rec  =head2 _set_ds
123    
124  Set current record hash  Set current record hash
125    
126    _set_rec( $rec );    _set_ds( $rec );
127    
128  =cut  =cut
129    
130  my $rec;  my $rec;
131    
132  sub _set_rec {  sub _set_ds {
133          $rec = shift or die "no record hash";          $rec = shift or die "no record hash";
134  }  }
135    
# Line 172  my ($out, $marc_record, $marc_encoding, Line 173  my ($out, $marc_record, $marc_encoding,
173  my ($marc_record_offset, $marc_fetch_offset) = (0, 0);  my ($marc_record_offset, $marc_fetch_offset) = (0, 0);
174    
175  sub _get_ds {  sub _get_ds {
176    #warn "## out = ",dump($out);
177          return $out;          return $out;
178  }  }
179    
# Line 478  Define output just for I<display> Line 480  Define output just for I<display>
480    
481  =cut  =cut
482    
483  sub display {  sub _field {
484          my $name = shift or die "display needs name as first argument";          my $type = shift or confess "need type -- BUG?";
485            my $name = shift or confess "needs name as first argument";
486          my @o = grep { defined($_) && $_ ne '' } @_;          my @o = grep { defined($_) && $_ ne '' } @_;
487          return unless (@o);          return unless (@o);
488          $out->{$name}->{display} = \@o;          $out->{$name}->{$type} = \@o;
489  }  }
490    
491    sub display { _field( 'display', @_ ) }
492    
493  =head2 search  =head2 search
494    
495  Prepare values just for I<search>  Prepare values just for I<search>
# Line 493  Prepare values just for I<search> Line 498  Prepare values just for I<search>
498    
499  =cut  =cut
500    
501  sub search {  sub search { _field( 'search', @_ ) }
502          my $name = shift or die "search needs name as first argument";  
503          my @o = grep { defined($_) && $_ ne '' } @_;  =head2 sorted
504          return unless (@o);  
505          $out->{$name}->{search} = \@o;  Insert into lists which will be automatically sorted
506  }  
507     sorted('Title', rec('200','a') );
508    
509    =cut
510    
511    sub sorted { _field( 'sorted', @_ ) }
512    
513    
514  =head2 marc_leader  =head2 marc_leader
515    
# Line 1005  sub rec { Line 1016  sub rec {
1016          }          }
1017  }  }
1018    
1019    =head2 frec
1020    
1021    Returns first value from field
1022    
1023      $v = frec('200');
1024      $v = frec('200','a');
1025    
1026    =cut
1027    
1028    sub frec {
1029            my @out = rec(@_);
1030            warn "rec(",dump(@_),") has more than one return value, ignoring\n" if $#out > 0;
1031            return shift @out;
1032    }
1033    
1034  =head2 regex  =head2 regex
1035    
1036  Apply regex to some or all values  Apply regex to some or all values

Legend:
Removed from v.915  
changed lines
  Added in v.1012

  ViewVC Help
Powered by ViewVC 1.1.26