/[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 461 by dpavlin, Fri May 12 14:54:25 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 regex first lookup join_with
8  /;  /;
# Line 19  WebPAC::Normalize::Set - describe normal Line 19  WebPAC::Normalize::Set - describe normal
19    
20  =head1 VERSION  =head1 VERSION
21    
22  Version 0.01  Version 0.02
23    
24  =cut  =cut
25    
26  our $VERSION = '0.01';  our $VERSION = '0.02';
27    
28  =head1 SYNOPSIS  =head1 SYNOPSIS
29    
# Line 46  sub set_rec { Line 46  sub set_rec {
46          $rec = shift or die "no record hash";          $rec = shift or die "no record hash";
47  }  }
48    
 =head2 set_lookup  
   
 Set current lookup hash  
   
   set_lookup( $lookup );  
   
 =cut  
   
49  =head2 tag  =head2 tag
50    
51  Define new tag for output  Define new tag for output
# Line 65  By default, output will go into I<search Line 57  By default, output will go into I<search
57  =cut  =cut
58    
59  my $out;  my $out;
 my $type = 'default';  
60    
61  sub tag {  sub tag {
62          my $name = shift or "tag needs name as first argument";          my $name = shift or "tag needs name as first argument";
# Line 117  sub get_ds { Line 108  sub get_ds {
108          return $out;          return $out;
109  }  }
110    
111    =head2 clean_ds
112    
113    Clean data structure hash for next record
114    
115      clean_ds();
116    
117    =cut
118    
119    sub clean_ds {
120            $out = undef;
121    }
122    
123    =head2 set_lookup
124    
125    Set current lookup hash
126    
127      set_lookup( $lookup );
128    
129    =cut
130    
131  my $lookup;  my $lookup;
132    
133  sub set_lookup {  sub set_lookup {
# Line 135  TODO: order of values is probably same a Line 146  TODO: order of values is probably same a
146    
147  sub rec1 {  sub rec1 {
148          my $f = shift;          my $f = shift;
149            return unless (defined($rec && $rec->{$f}));
150          if (ref($rec->{$f}) eq 'ARRAY') {          if (ref($rec->{$f}) eq 'ARRAY') {
151                  return map { values %{$_} } @{ $rec->{$f} };                  if (ref($rec->{$f}->[0]) eq 'HASH') {
152                            return map { values %{$_} } @{ $rec->{$f} };
153                    } else {
154                            return @{ $rec->{$f} };
155                    }
156          } elsif( defined($rec->{$f}) ) {          } elsif( defined($rec->{$f}) ) {
157                  return $rec->{$f};                  return $rec->{$f};
158          }          }
# Line 152  Return all values in specific field and Line 168  Return all values in specific field and
168    
169  sub rec2 {  sub rec2 {
170          my $f = shift;          my $f = shift;
171            return unless (defined($rec && $rec->{$f}));
172          my $sf = shift;          my $sf = shift;
173          return map { $_->{$sf} } grep { $_->{$sf} } @{ $rec->{$f} };          return map { $_->{$sf} } grep { $_->{$sf} } @{ $rec->{$f} };
174  }  }
# Line 166  syntaxtic sugar for Line 183  syntaxtic sugar for
183  =cut  =cut
184    
185  sub rec {  sub rec {
         warn "rec arguments: $#_\n";  
186          if ($#_ == 0) {          if ($#_ == 0) {
187                  return rec1(@_);                  return rec1(@_);
188          } elsif ($#_ == 1) {          } elsif ($#_ == 1) {
# Line 187  sub regex { Line 203  sub regex {
203          my @out;          my @out;
204          warn "r: $r\n",Dumper(\@_);          warn "r: $r\n",Dumper(\@_);
205          foreach my $t (@_) {          foreach my $t (@_) {
                 warn "t: $t\n";  
206                  eval "\$t =~ $r";                  eval "\$t =~ $r";
207                  push @out, $t;                  push @out, $t;
208          }          }
Legend:
Removed from v.460  
changed lines
  Added in v.461
  ViewVC Help
Powered by ViewVC 1.1.26