/[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 490 by dpavlin, Sun May 14 12:35:20 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.04
25    
26  =cut  =cut
27    
28  our $VERSION = '0.01';  our $VERSION = '0.04';
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    
45    =head2 data_structure
46    
47    Return data structure
48    
49      my $ds = WebPAC::Normalize::Set(
50            lookup => $lookup->lookup_hash,
51            row => $row,
52            rules => $normalize_pl_config,
53      );
54    
55    This function will B<die> if normalizastion can't be evaled.
56    
57    =cut
58    
59    sub data_structure {
60            my $arg = {@_};
61    
62            die "need row argument" unless ($arg->{row});
63            die "need normalisation argument" unless ($arg->{rules});
64    
65            no strict 'subs';
66            set_lookup( $arg->{lookup} );
67            set_rec( $arg->{row} );
68            clean_ds();
69            eval "$arg->{rules}";
70            die "error evaling $arg->{rules}: $@\n" if ($@);
71            return get_ds();
72    }
73    
74  =head2 set_rec  =head2 set_rec
75    
76  Set current record hash  Set current record hash
# Line 46  sub set_rec { Line 85  sub set_rec {
85          $rec = shift or die "no record hash";          $rec = shift or die "no record hash";
86  }  }
87    
 =head2 set_lookup  
   
 Set current lookup hash  
   
   set_lookup( $lookup );  
   
 =cut  
   
88  =head2 tag  =head2 tag
89    
90  Define new tag for output  Define new tag for I<search> and I<display>.
91    
92    tag('Title', rec('200','a') );    tag('Title', rec('200','a') );
93    
 By default, output will go into I<search> and I<display>.  
94    
95  =cut  =cut
96    
97  my $out;  my $out;
 my $type = 'default';  
98    
99  sub tag {  sub tag {
100          my $name = shift or "tag needs name as first argument";          my $name = shift or die "tag needs name as first argument";
101          return unless (@_);          my @o = grep { defined($_) && $_ ne '' } @_;
102            return unless (@o);
103          $out->{$name}->{tag} = $name;          $out->{$name}->{tag} = $name;
104          $out->{$name}->{search} = \@_;          $out->{$name}->{search} = \@o;
105          $out->{$name}->{display} = \@_;          $out->{$name}->{display} = \@o;
106  }  }
107    
108  =head2 display  =head2 display
# Line 84  Define tag just for I<display> Line 114  Define tag just for I<display>
114  =cut  =cut
115    
116  sub display {  sub display {
117          my $name = shift or "display needs name as first argument";          my $name = shift or die "display needs name as first argument";
118          return unless (@_);          my @o = grep { defined($_) && $_ ne '' } @_;
119            return unless (@o);
120          $out->{$name}->{tag} = $name;          $out->{$name}->{tag} = $name;
121          $out->{$name}->{display} = \@_;          $out->{$name}->{display} = \@o;
122  }  }
123    
124  =head2 search  =head2 search
# Line 99  Prepare values just for I<search> Line 130  Prepare values just for I<search>
130  =cut  =cut
131    
132  sub search {  sub search {
133          my $name = shift or "search needs name as first argument";          my $name = shift or die "search needs name as first argument";
134          return unless (@_);          my @o = grep { defined($_) && $_ ne '' } @_;
135            return unless (@o);
136          $out->{$name}->{tag} = $name;          $out->{$name}->{tag} = $name;
137          $out->{$name}->{search} = \@_;          $out->{$name}->{search} = \@o;
138  }  }
139    
140  =head2 get_ds  =head2 get_ds
# Line 117  sub get_ds { Line 149  sub get_ds {
149          return $out;          return $out;
150  }  }
151    
152    =head2 clean_ds
153    
154    Clean data structure hash for next record
155    
156      clean_ds();
157    
158    =cut
159    
160    sub clean_ds {
161            $out = undef;
162    }
163    
164    =head2 set_lookup
165    
166    Set current lookup hash
167    
168      set_lookup( $lookup );
169    
170    =cut
171    
172  my $lookup;  my $lookup;
173    
174  sub set_lookup {  sub set_lookup {
175          $lookup = shift or die "no lookup hash";          $lookup = shift;
176  }  }
177    
178  =head2 rec1  =head2 rec1
# Line 135  TODO: order of values is probably same a Line 187  TODO: order of values is probably same a
187    
188  sub rec1 {  sub rec1 {
189          my $f = shift;          my $f = shift;
190            return unless (defined($rec) && defined($rec->{$f}));
191          if (ref($rec->{$f}) eq 'ARRAY') {          if (ref($rec->{$f}) eq 'ARRAY') {
192                  return map { values %{$_} } @{ $rec->{$f} };                  return map {
193                            if (ref($_) eq 'HASH') {
194                                    values %{$_};
195                            } else {
196                                    $_;
197                            }
198                    } @{ $rec->{$f} };
199          } elsif( defined($rec->{$f}) ) {          } elsif( defined($rec->{$f}) ) {
200                  return $rec->{$f};                  return $rec->{$f};
201          }          }
# Line 152  Return all values in specific field and Line 211  Return all values in specific field and
211    
212  sub rec2 {  sub rec2 {
213          my $f = shift;          my $f = shift;
214            return unless (defined($rec && $rec->{$f}));
215          my $sf = shift;          my $sf = shift;
216          return map { $_->{$sf} } grep { $_->{$sf} } @{ $rec->{$f} };          return map { $_->{$sf} } grep { ref($_) eq 'HASH' && $_->{$sf} } @{ $rec->{$f} };
217  }  }
218    
219  =head2 rec  =head2 rec
# Line 166  syntaxtic sugar for Line 226  syntaxtic sugar for
226  =cut  =cut
227    
228  sub rec {  sub rec {
         warn "rec arguments: $#_\n";  
229          if ($#_ == 0) {          if ($#_ == 0) {
230                  return rec1(@_);                  return rec1(@_);
231          } elsif ($#_ == 1) {          } elsif ($#_ == 1) {
# Line 185  Apply regex to some or all values Line 244  Apply regex to some or all values
244  sub regex {  sub regex {
245          my $r = shift;          my $r = shift;
246          my @out;          my @out;
247          warn "r: $r\n",Dumper(\@_);          #warn "r: $r\n",Dumper(\@_);
248          foreach my $t (@_) {          foreach my $t (@_) {
                 warn "t: $t\n";  
249                  eval "\$t =~ $r";                  eval "\$t =~ $r";
250                  push @out, $t;                  push @out, $t;
251          }          }
252          return @out;          return @out;
253  }  }
254    
255    =head2 prefix
256    
257    Prefix all values with a string
258    
259      @v = prefix( 'my_', @v );
260    
261    =cut
262    
263    sub prefix {
264            my $p = shift or die "prefix needs string as first argument";
265            return map { $p . $_ } grep { defined($_) } @_;
266    }
267    
268  =head2 first  =head2 first
269    
270  Return first element  Return first element
# Line 217  Consult lookup hashes for some value Line 288  Consult lookup hashes for some value
288  =cut  =cut
289    
290  sub lookup {  sub lookup {
291          my $k = shift;          my $k = shift or return;
292          return unless ($lookup && defined($lookup->{$k}));          return unless (defined($lookup->{$k}));
293          if (ref($lookup->{$k}) eq 'ARRAY') {          if (ref($lookup->{$k}) eq 'ARRAY') {
294                  return @{ $lookup->{$k} };                  return @{ $lookup->{$k} };
295          } else {          } else {
# Line 236  Joins walues with some delimiter Line 307  Joins walues with some delimiter
307    
308  sub join_with {  sub join_with {
309          my $d = shift;          my $d = shift;
310          return join($d, @_);          return join($d, grep { defined($_) && $_ ne '' } @_);
311  }  }
312    
313  # END  # END
Legend:
Removed from v.460  
changed lines
  Added in v.490
  ViewVC Help
Powered by ViewVC 1.1.26