/[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 1036 by dpavlin, Mon Nov 12 11:10:48 2007 UTC revision 1367 by dpavlin, Thu Dec 15 21:40:37 2011 UTC
# Line 7  our @EXPORT = qw/ Line 7  our @EXPORT = qw/
7          _debug          _debug
8          _pack_subfields_hash          _pack_subfields_hash
9    
10            to
11          search_display search display sorted          search_display search display sorted
12    
13          rec1 rec2 rec          rec1 rec2 rec
# Line 20  our @EXPORT = qw/ Line 21  our @EXPORT = qw/
21          get set          get set
22          count          count
23    
24            row
25            rec_array
26    
27  /;  /;
28    
29  use warnings;  use warnings;
# Line 27  use strict; Line 31  use strict;
31    
32  #use base qw/WebPAC::Common/;  #use base qw/WebPAC::Common/;
33  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
 use Storable qw/dclone/;  
34  use Carp qw/confess/;  use Carp qw/confess/;
35    
36  # debugging warn(s)  # debugging warn(s)
37  my $debug = 0;  my $debug = 0;
38    _debug( $debug );
39    
40  # FIXME  # FIXME
41  use WebPAC::Normalize::ISBN;  use WebPAC::Normalize::ISBN;
# Line 46  push @EXPORT, ( qw/ Line 50  push @EXPORT, ( qw/
50          marc_template          marc_template
51  /);  /);
52    
53    use Storable qw/dclone/;
54    
55  =head1 NAME  =head1 NAME
56    
57  WebPAC::Normalize - describe normalisaton rules using sets  WebPAC::Normalize - describe normalisaton rules using sets
58    
59  =cut  =cut
60    
61  our $VERSION = '0.35';  our $VERSION = '0.36';
62    
63  =head1 SYNOPSIS  =head1 SYNOPSIS
64    
# Line 117  sub data_structure { Line 123  sub data_structure {
123          $load_row_coderef = $arg->{load_row_coderef};          $load_row_coderef = $arg->{load_row_coderef};
124    
125          no strict 'subs';          no strict 'subs';
126          no warnings 'redefine';          no warnings 'all';
127          eval "$arg->{rules};";          eval "$arg->{rules};";
128          die "error evaling $arg->{rules}: $@\n" if ($@);          die "error evaling $arg->{rules}: $@\n" if ($@);
129    
# Line 139  sub _set_ds { Line 145  sub _set_ds {
145          $WebPAC::Normalize::MARC::rec = $rec;          $WebPAC::Normalize::MARC::rec = $rec;
146  }  }
147    
148  =head2  =head2 _get_rec
149    
150    my $rec = _get_rec();    my $rec = _get_rec();
151    
# Line 147  sub _set_ds { Line 153  sub _set_ds {
153    
154  sub _get_rec { $rec };  sub _get_rec { $rec };
155    
156    =head2 _set_rec
157    
158      _set_rec( $rec );
159    
160    =cut
161    
162    sub _set_rec { $rec = $_[0] }
163    
164  =head2 _set_config  =head2 _set_config
165    
166  Set current config hash  Set current config hash
# Line 269  sub _debug { Line 283  sub _debug {
283    
284  Those functions generally have to first in your normalization file.  Those functions generally have to first in your normalization file.
285    
286    =head2 to
287    
288    Generic way to set values for some name
289    
290      to('field-name', 'name-value' => rec('200','a') );
291    
292    There are many helpers defined below which might be easier to use.
293    
294    =cut
295    
296    sub to {
297            my $type = shift or confess "need type -- BUG?";
298            my $name = shift or confess "needs name as first argument";
299            my @o = grep { defined($_) && $_ ne '' } @_;
300            return unless (@o);
301            $out->{$name}->{$type} = \@o;
302    }
303    
304  =head2 search_display  =head2 search_display
305    
306  Define output for L<search> and L<display> at the same time  Define output for L<search> and L<display> at the same time
307    
308    search_display('Title', rec('200','a') );    search_display('Title', rec('200','a') );
309    
   
310  =cut  =cut
311    
312  sub search_display {  sub search_display {
# Line 288  sub search_display { Line 319  sub search_display {
319    
320  =head2 tag  =head2 tag
321    
322  Old name for L<search_display>, but supported  Old name for L<search_display>, it will probably be removed at one point.
323    
324  =cut  =cut
325    
# Line 304  Define output just for I<display> Line 335  Define output just for I<display>
335    
336  =cut  =cut
337    
338  sub _field {  sub display { to( 'display', @_ ) }
         my $type = shift or confess "need type -- BUG?";  
         my $name = shift or confess "needs name as first argument";  
         my @o = grep { defined($_) && $_ ne '' } @_;  
         return unless (@o);  
         $out->{$name}->{$type} = \@o;  
 }  
   
 sub display { _field( 'display', @_ ) }  
339    
340  =head2 search  =head2 search
341    
# Line 322  Prepare values just for I<search> Line 345  Prepare values just for I<search>
345    
346  =cut  =cut
347    
348  sub search { _field( 'search', @_ ) }  sub search { to( 'search', @_ ) }
349    
350  =head2 sorted  =head2 sorted
351    
# Line 332  Insert into lists which will be automati Line 355  Insert into lists which will be automati
355    
356  =cut  =cut
357    
358  sub sorted { _field( 'sorted', @_ ) }  sub sorted { to( 'sorted', @_ ) }
359    
360    =head2 row
361    
362    Insert new row of data into output module
363    
364      row( column => 'foo', column2 => 'bar' );
365    
366    =cut
367    
368    use Data::Dump qw/dump/;
369    
370    sub row {
371            die "array doesn't have odd number of elements but $#_: ",dump( @_ ) if $#_ % 2 == 1;
372            my $table = shift @_;
373            push @{ $out->{'_rows'}->{$table} }, {@_};
374    }
375    
376    
377  =head1 Functions to extract data from input  =head1 Functions to extract data from input
# Line 355  sub _pack_subfields_hash { Line 393  sub _pack_subfields_hash {
393    
394          warn "## _pack_subfields_hash( ",dump(@_), " )\n" if ($debug > 1);          warn "## _pack_subfields_hash( ",dump(@_), " )\n" if ($debug > 1);
395    
396          my ($h,$include_subfields) = @_;          my ($hash,$include_subfields) = @_;
397    
398          # sanity and ease of use          # sanity and ease of use
399          return $h if (ref($h) ne 'HASH');          return $hash if (ref($hash) ne 'HASH');
400    
401            my $h = dclone( $hash );
402    
403          if ( defined($h->{subfields}) ) {          if ( defined($h->{subfields}) ) {
404                  my $sfs = delete $h->{subfields} || die "no subfields?";                  my $sfs = delete $h->{subfields} || die "no subfields?";
# Line 449  sub rec2 { Line 489  sub rec2 {
489                  } else {                  } else {
490                          $_->{$sf};                          $_->{$sf};
491                  }                  }
492          } grep { ref($_) eq 'HASH' && $_->{$sf} } @{ $rec->{$f} };          } grep { ref($_) eq 'HASH' && defined $_->{$sf} } @{ $rec->{$f} };
493  }  }
494    
495  =head2 rec  =head2 rec
# Line 918  sub count { Line 958  sub count {
958          return @_ . '';          return @_ . '';
959  }  }
960    
961    =head2 rec_array
962    
963    Always return field as array
964    
965      foreach my $d ( rec_array('field') ) {
966            warn $d;
967      }
968    
969    =cut
970    
971    sub rec_array {
972            my $d = $rec->{ $_[0] };
973            return @$d if ref($d) eq 'ARRAY';
974            return ($d);
975    }
976    
977  # END  # END
978  1;  1;

Legend:
Removed from v.1036  
changed lines
  Added in v.1367

  ViewVC Help
Powered by ViewVC 1.1.26