/[webpac2]/trunk/lib/WebPAC/Normalize/Set.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/Set.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 460 by dpavlin, Fri May 12 14:07:08 2006 UTC revision 467 by dpavlin, Sat May 13 09:48:06 2006 UTC
# Line 2  package WebPAC::Normalize::Set; Line 2  package WebPAC::Normalize::Set;
2  use Exporter 'import';  use Exporter 'import';
3  @EXPORT = qw/  @EXPORT = qw/
4          set_rec set_lookup          set_rec set_lookup
5          get_ds          get_ds clean_ds
6          tag search display          tag search display
7          rec1 rec2 rec regex first lookup join_with          rec1 rec2 rec
8            regex prefix
9            first lookup join_with
10  /;  /;
11    
12  use warnings;  use warnings;
# Line 19  WebPAC::Normalize::Set - describe normal Line 21  WebPAC::Normalize::Set - describe normal
21    
22  =head1 VERSION  =head1 VERSION
23    
24  Version 0.01  Version 0.03
25    
26  =cut  =cut
27    
28  our $VERSION = '0.01';  our $VERSION = '0.03';
29    
30  =head1 SYNOPSIS  =head1 SYNOPSIS
31    
32  This module uses C<conf/normalize/*.pl> files to perform normalisation  This module uses C<conf/normalize/*.pl> files to perform normalisation
33  from input records  from input records using perl functions which are specialized for set
34    processing.
35    
36    Sets are implemented as arrays, and normalisation file is valid perl, which
37    means that you check it's validity before running WebPAC using
38    C<perl -c normalize.pl>.
39    
40    Normalisation can generate multiple output normalized data. For now, supported output
41    types (on the left side of definition) are: C<tag>, C<display> and C<search>.
42    
43  =head1 FUNCTIONS  =head1 FUNCTIONS
44    
# Line 46  sub set_rec { Line 56  sub set_rec {
56          $rec = shift or die "no record hash";          $rec = shift or die "no record hash";
57  }  }
58    
 =head2 set_lookup  
   
 Set current lookup hash  
   
   set_lookup( $lookup );  
   
 =cut  
   
59  =head2 tag  =head2 tag
60    
61  Define new tag for output  Define new tag for I<search> and I<display>.
62    
63    tag('Title', rec('200','a') );    tag('Title', rec('200','a') );
64    
 By default, output will go into I<search> and I<display>.  
65    
66  =cut  =cut
67    
68  my $out;  my $out;
 my $type = 'default';  
69    
70  sub tag {  sub tag {
71          my $name = shift or "tag needs name as first argument";          my $name = shift or die "tag needs name as first argument";
72          return unless (@_);          return unless (@_);
73          $out->{$name}->{tag} = $name;          $out->{$name}->{tag} = $name;
74          $out->{$name}->{search} = \@_;          $out->{$name}->{search} = \@_;
# Line 84  Define tag just for I<display> Line 84  Define tag just for I<display>
84  =cut  =cut
85    
86  sub display {  sub display {
87          my $name = shift or "display needs name as first argument";          my $name = shift or die "display needs name as first argument";
88          return unless (@_);          return unless (@_);
89          $out->{$name}->{tag} = $name;          $out->{$name}->{tag} = $name;
90          $out->{$name}->{display} = \@_;          $out->{$name}->{display} = \@_;
# Line 99  Prepare values just for I<search> Line 99  Prepare values just for I<search>
99  =cut  =cut
100    
101  sub search {  sub search {
102          my $name = shift or "search needs name as first argument";          my $name = shift or die "search needs name as first argument";
103          return unless (@_);          return unless (@_);
104          $out->{$name}->{tag} = $name;          $out->{$name}->{tag} = $name;
105          $out->{$name}->{search} = \@_;          $out->{$name}->{search} = \@_;
# Line 117  sub get_ds { Line 117  sub get_ds {
117          return $out;          return $out;
118  }  }
119    
120    =head2 clean_ds
121    
122    Clean data structure hash for next record
123    
124      clean_ds();
125    
126    =cut
127    
128    sub clean_ds {
129            $out = undef;
130    }
131    
132    =head2 set_lookup
133    
134    Set current lookup hash
135    
136      set_lookup( $lookup );
137    
138    =cut
139    
140  my $lookup;  my $lookup;
141    
142  sub set_lookup {  sub set_lookup {
# Line 135  TODO: order of values is probably same a Line 155  TODO: order of values is probably same a
155    
156  sub rec1 {  sub rec1 {
157          my $f = shift;          my $f = shift;
158            return unless (defined($rec && $rec->{$f}));
159          if (ref($rec->{$f}) eq 'ARRAY') {          if (ref($rec->{$f}) eq 'ARRAY') {
160                  return map { values %{$_} } @{ $rec->{$f} };                  if (ref($rec->{$f}->[0]) eq 'HASH') {
161                            return map { values %{$_} } @{ $rec->{$f} };
162                    } else {
163                            return @{ $rec->{$f} };
164                    }
165          } elsif( defined($rec->{$f}) ) {          } elsif( defined($rec->{$f}) ) {
166                  return $rec->{$f};                  return $rec->{$f};
167          }          }
# Line 152  Return all values in specific field and Line 177  Return all values in specific field and
177    
178  sub rec2 {  sub rec2 {
179          my $f = shift;          my $f = shift;
180            return unless (defined($rec && $rec->{$f}));
181          my $sf = shift;          my $sf = shift;
182          return map { $_->{$sf} } grep { $_->{$sf} } @{ $rec->{$f} };          return map { $_->{$sf} } grep { $_->{$sf} } @{ $rec->{$f} };
183  }  }
# Line 166  syntaxtic sugar for Line 192  syntaxtic sugar for
192  =cut  =cut
193    
194  sub rec {  sub rec {
         warn "rec arguments: $#_\n";  
195          if ($#_ == 0) {          if ($#_ == 0) {
196                  return rec1(@_);                  return rec1(@_);
197          } elsif ($#_ == 1) {          } elsif ($#_ == 1) {
# Line 185  Apply regex to some or all values Line 210  Apply regex to some or all values
210  sub regex {  sub regex {
211          my $r = shift;          my $r = shift;
212          my @out;          my @out;
213          warn "r: $r\n",Dumper(\@_);          #warn "r: $r\n",Dumper(\@_);
214          foreach my $t (@_) {          foreach my $t (@_) {
                 warn "t: $t\n";  
215                  eval "\$t =~ $r";                  eval "\$t =~ $r";
216                  push @out, $t;                  push @out, $t;
217          }          }
218          return @out;          return @out;
219  }  }
220    
221    =head2 prefix
222    
223    Prefix all values with a string
224    
225      @v = prefix( 'my_', @v );
226    
227    =cut
228    
229    sub prefix {
230            my $p = shift or die "prefix needs string as first argument";
231            return map { $p . $_ } grep { defined($_) } @_;
232    }
233    
234  =head2 first  =head2 first
235    
236  Return first element  Return first element
# Line 217  Consult lookup hashes for some value Line 254  Consult lookup hashes for some value
254  =cut  =cut
255    
256  sub lookup {  sub lookup {
257          my $k = shift;          my $k = shift or return;
258          return unless ($lookup && defined($lookup->{$k}));          return unless (defined($lookup->{$k}));
259          if (ref($lookup->{$k}) eq 'ARRAY') {          if (ref($lookup->{$k}) eq 'ARRAY') {
260                  return @{ $lookup->{$k} };                  return @{ $lookup->{$k} };
261          } else {          } else {
Legend:
Removed from v.460  
changed lines
  Added in v.467
  ViewVC Help
Powered by ViewVC 1.1.26