/[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!

Diff of /trunk/lib/WebPAC/Normalize.pm

Parent Directory | Revision Log | View Patch Patch

-revision 817 by dpavlin,
Thu Apr  5 21:50:14 2007 UTC
+revision 923 by dpavlin,
Wed Oct 31 00:26:43 2007 UTC
 Line 7 
 use Exporter 'import';
          _debug
          _pack_subfields_hash
-         tag search display
+         search_display search display sorted
          marc marc_indicators marc_repeatable_subfield
          marc_compose marc_leader marc_fixed
          marc_duplicate marc_remove marc_count
-Line 40 
 my $debug = 0;
+Line 41 
 my $debug = 0;
  WebPAC::Normalize - describe normalisaton rules using sets
- =head1 VERSION
- Version 0.28
  =cut
- our $VERSION = '0.28';
+ our $VERSION = '0.31';
  =head1 SYNOPSIS
-Line 59 
 means that you check it's validity befor
+Line 56 
 means that you check it's validity befor
  C<perl -c normalize.pl>.
  Normalisation can generate multiple output normalized data. For now, supported output
- types (on the left side of definition) are: C<tag>, C<display>, C<search> and
+ types (on the left side of definition) are: C<search_display>, C<display>, C<search> and
  C<marc>.
  =head1 FUNCTIONS
-Line 442 
 sub _debug {
+Line 439 
 sub _debug {
  Those functions generally have to first in your normalization file.
- =head2 tag
+ =head2 search_display
- Define new tag for I<search> and I<display>.
+ Define output for L<search> and L<display> at the same time
-   tag('Title', rec('200','a') );
+   search_display('Title', rec('200','a') );
  =cut
- sub tag {
+ sub search_display {
-         my $name = shift or die "tag needs name as first argument";
+         my $name = shift or die "search_display needs name as first argument";
          my @o = grep { defined($_) && $_ ne '' } @_;
          return unless (@o);
-         $out->{$name}->{tag} = $name;
          $out->{$name}->{search} = \@o;
          $out->{$name}->{display} = \@o;
  }
+ =head2 tag
+ Old name for L<search_display>, but supported
+ =cut
+ sub tag {
+         search_display( @_ );
+ }
  =head2 display
- Define tag just for I<display>
+ Define output just for I<display>
    @v = display('Title', rec('200','a') );
  =cut
- sub display {
+ sub _field {
-         my $name = shift or die "display needs name as first argument";
+         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}->{tag} = $name;
+         $out->{$name}->{$type} = \@o;
-         $out->{$name}->{display} = \@o;
  }
+ sub display { _field( 'display', @_ ) }
  =head2 search
  Prepare values just for I<search>
-Line 484 
 Prepare values just for I<search>
+Line 492 
 Prepare values just for I<search>
  =cut
- sub search {
+ sub search { _field( 'search', @_ ) }
-         my $name = shift or die "search needs name as first argument";
-         my @o = grep { defined($_) && $_ ne '' } @_;
+ =head2 sorted
-         return unless (@o);
-         $out->{$name}->{tag} = $name;
+ Insert into lists which will be automatically sorted
-         $out->{$name}->{search} = \@o;
- }
+  sorted('Title', rec('200','a') );
+ =cut
+ sub sorted { _field( 'sorted', @_ ) }
  =head2 marc_leader
-Line 535 
 sub marc_fixed {
+Line 548 
 sub marc_fixed {
          my ($f, $pos, $val) = @_;
          die "need marc(field, position, value)" unless defined($f) && defined($pos);
+         confess "need val" unless defined $val;
          my $update = 0;
          map {
                  if ($_->[0] eq $f) {
                          my $old = $_->[1];
-                         if (length($old) < $pos) {
+                         if (length($old) <= $pos) {
                                  $_->[1] .= ' ' x ( $pos - length($old) ) . $val;
                                  warn "## marc_fixed($f,$pos,'$val') append '$old' -> '$_->[1]'\n" if ($debug > 1);
                          } else {
-Line 872 
 sub _pack_subfields_hash {
+Line 887 
 sub _pack_subfields_hash {
          my ($h,$include_subfields) = @_;
+         # sanity and ease of use
+         return $h if (ref($h) ne 'HASH');
          if ( defined($h->{subfields}) ) {
                  my $sfs = delete $h->{subfields} || die "no subfields?";
                  my @out;
-Line 1021 
 Prefix all values with a string
+Line 1039 
 Prefix all values with a string
  =cut
  sub prefix {
-         my $p = shift or return;
+         my $p = shift;
+         return @_ unless defined( $p );
          return map { $p . $_ } grep { defined($_) } @_;
  }
-Line 1034 
 suffix all values with a string
+Line 1053 
 suffix all values with a string
  =cut
  sub suffix {
-         my $s = shift or die "suffix needs string as first argument";
+         my $s = shift;
+         return @_ unless defined( $s );
          return map { $_ . $s } grep { defined($_) } @_;
  }
-Line 1047 
 surround all values with a two strings
+Line 1067 
 surround all values with a two strings
  =cut
  sub surround {
-         my $p = shift or die "surround need prefix as first argument";
+         my $p = shift;
-         my $s = shift or die "surround needs suffix as second argument";
+         my $s = shift;
+         $p = '' unless defined( $p );
+         $s = '' unless defined( $s );
          return map { $p . $_ . $s } grep { defined($_) } @_;
  }
-Line 1223 
 Consult config values stored in C<config
+Line 1245 
 Consult config values stored in C<config
    $database_code = config();    # use _ from hash
    $database_name = config('name');
    $database_input_name = config('input name');
-   $tag = config('input normalize tag');
  Up to three levels are supported.

 Legend:



Removed from v.817
 


changed lines


 
Added in v.923
 Legend:



Removed from v.817
 


changed lines


 
Added in v.923
-Removed from v.817
+Added in v.923

	ViewVC Help
Powered by ViewVC 1.1.26