WebPAC/Normalize/Set.pm

package WebPAC::Normalize::Set;
use Exporter 'import';
@EXPORT = qw/
        set_rec set_lookup
        get_ds
        tag search display
        rec1 rec2 rec regex first lookup join_with
/;

use warnings;
use strict;

#use base qw/WebPAC::Common/;
use Data::Dumper;

=head1 NAME

WebPAC::Normalize::Set - describe normalisaton rules using sets

=head1 VERSION

Version 0.01

=cut

our $VERSION = '0.01';

=head1 SYNOPSIS

This module uses C<conf/normalize/*.pl> files to perform normalisation
from input records

=head1 FUNCTIONS

=head2 set_rec

Set current record hash

  set_rec( $rec );

=cut

my $rec;

sub set_rec {
        $rec = shift or die "no record hash";
}

=head2 set_lookup

Set current lookup hash

  set_lookup( $lookup );

=cut

=head2 tag

Define new tag for output

  tag('Title', rec('200','a') );

By default, output will go into I<search> and I<display>.

=cut

my $out;
my $type = 'default';

sub tag {
        my $name = shift or "tag needs name as first argument";
        return unless (@_);
        $out->{$name}->{tag} = $name;
        $out->{$name}->{search} = \@_;
        $out->{$name}->{display} = \@_;
}

=head2 display

Define tag just for I<display>

  @v = display('Title', rec('200','a') );

=cut

sub display {
        my $name = shift or "display needs name as first argument";
        return unless (@_);
        $out->{$name}->{tag} = $name;
        $out->{$name}->{display} = \@_;
}

=head2 search

Prepare values just for I<search>

  @v = search('Title', rec('200','a') );

=cut

sub search {
        my $name = shift or "search needs name as first argument";
        return unless (@_);
        $out->{$name}->{tag} = $name;
        $out->{$name}->{search} = \@_;
}

=head2 get_ds

Return hash formatted as data structure

  my $ds = get_ds();

=cut

sub get_ds {
        return $out;
}

my $lookup;

sub set_lookup {
        $lookup = shift or die "no lookup hash";
}

=head2 rec1

Return all values in some field

  @v = rec1('200')

TODO: order of values is probably same as in source data, need to investigate that

=cut

sub rec1 {
        my $f = shift;
        if (ref($rec->{$f}) eq 'ARRAY') {
                return map { values %{$_} } @{ $rec->{$f} };
        } elsif( defined($rec->{$f}) ) {
                return $rec->{$f};
        }
}

=head2 rec2

Return all values in specific field and subfield

  @v = rec2('200','a')

=cut

sub rec2 {
        my $f = shift;
        my $sf = shift;
        return map { $_->{$sf} } grep { $_->{$sf} } @{ $rec->{$f} };
}

=head2 rec

syntaxtic sugar for

  @v = rec('200')
  @v = rec('200','a')

=cut

sub rec {
        warn "rec arguments: $#_\n";
        if ($#_ == 0) {
                return rec1(@_);
        } elsif ($#_ == 1) {
                return rec2(@_);
        }
}

=head2 regex

Apply regex to some or all values

  @v = regex( 's/foo/bar/g', @v );

=cut

sub regex {
        my $r = shift;
        my @out;
        warn "r: $r\n",Dumper(\@_);
        foreach my $t (@_) {
                warn "t: $t\n";
                eval "\$t =~ $r";
                push @out, $t;
        }
        return @out;
}

=head2 first

Return first element

  $v = first( @v );

=cut

sub first {
        my $r = shift;
        return $r;
}

=head2 lookup

Consult lookup hashes for some value

  @v = lookup( $v );
  @v = lookup( @v );

=cut

sub lookup {
        my $k = shift;
        return unless ($lookup && defined($lookup->{$k}));
        if (ref($lookup->{$k}) eq 'ARRAY') {
                return @{ $lookup->{$k} };
        } else {
                return $lookup->{$k};
        }
}

=head2 join_with

Joins walues with some delimiter

  $v = join_with(", ", @v);

=cut

sub join_with {
        my $d = shift;
        return join($d, @_);
}

# END
1;
1	dpavlin	460	package WebPAC::Normalize::Set;
2			use Exporter 'import';
3			@EXPORT = qw/
4			set_rec set_lookup
5			get_ds
6			tag search display
7			rec1 rec2 rec regex first lookup join_with
8			/;
9
10			use warnings;
11			use strict;
12
13			#use base qw/WebPAC::Common/;
14			use Data::Dumper;
15
16			=head1 NAME
17
18			WebPAC::Normalize::Set - describe normalisaton rules using sets
19
20			=head1 VERSION
21
22			Version 0.01
23
24			=cut
25
26			our $VERSION = '0.01';
27
28			=head1 SYNOPSIS
29
30			This module uses C<conf/normalize/*.pl> files to perform normalisation
31			from input records
32
33			=head1 FUNCTIONS
34
35			=head2 set_rec
36
37			Set current record hash
38
39			set_rec( $rec );
40
41			=cut
42
43			my $rec;
44
45			sub set_rec {
46			$rec = shift or die "no record hash";
47			}
48
49			=head2 set_lookup
50
51			Set current lookup hash
52
53			set_lookup( $lookup );
54
55			=cut
56
57			=head2 tag
58
59			Define new tag for output
60
61			tag('Title', rec('200','a') );
62
63			By default, output will go into I<search> and I<display>.
64
65			=cut
66
67			my $out;
68			my $type = 'default';
69
70			sub tag {
71			my $name = shift or "tag needs name as first argument";
72			return unless (@_);
73			$out->{$name}->{tag} = $name;
74			$out->{$name}->{search} = \@_;
75			$out->{$name}->{display} = \@_;
76			}
77
78			=head2 display
79
80			Define tag just for I<display>
81
82			@v = display('Title', rec('200','a') );
83
84			=cut
85
86			sub display {
87			my $name = shift or "display needs name as first argument";
88			return unless (@_);
89			$out->{$name}->{tag} = $name;
90			$out->{$name}->{display} = \@_;
91			}
92
93			=head2 search
94
95			Prepare values just for I<search>
96
97			@v = search('Title', rec('200','a') );
98
99			=cut
100
101			sub search {
102			my $name = shift or "search needs name as first argument";
103			return unless (@_);
104			$out->{$name}->{tag} = $name;
105			$out->{$name}->{search} = \@_;
106			}
107
108			=head2 get_ds
109
110			Return hash formatted as data structure
111
112			my $ds = get_ds();
113
114			=cut
115
116			sub get_ds {
117			return $out;
118			}
119
120			my $lookup;
121
122			sub set_lookup {
123			$lookup = shift or die "no lookup hash";
124			}
125
126			=head2 rec1
127
128			Return all values in some field
129
130			@v = rec1('200')
131
132			TODO: order of values is probably same as in source data, need to investigate that
133
134			=cut
135
136			sub rec1 {
137			my $f = shift;
138			if (ref($rec->{$f}) eq 'ARRAY') {
139			return map { values %{$_} } @{ $rec->{$f} };
140			} elsif( defined($rec->{$f}) ) {
141			return $rec->{$f};
142			}
143			}
144
145			=head2 rec2
146
147			Return all values in specific field and subfield
148
149			@v = rec2('200','a')
150
151			=cut
152
153			sub rec2 {
154			my $f = shift;
155			my $sf = shift;
156			return map { $_->{$sf} } grep { $_->{$sf} } @{ $rec->{$f} };
157			}
158
159			=head2 rec
160
161			syntaxtic sugar for
162
163			@v = rec('200')
164			@v = rec('200','a')
165
166			=cut
167
168			sub rec {
169			warn "rec arguments: $#_\n";
170			if ($#_ == 0) {
171			return rec1(@_);
172			} elsif ($#_ == 1) {
173			return rec2(@_);
174			}
175			}
176
177			=head2 regex
178
179			Apply regex to some or all values
180
181			@v = regex( 's/foo/bar/g', @v );
182
183			=cut
184
185			sub regex {
186			my $r = shift;
187			my @out;
188			warn "r: $r\n",Dumper(\@_);
189			foreach my $t (@_) {
190			warn "t: $t\n";
191			eval "\$t =~ $r";
192			push @out, $t;
193			}
194			return @out;
195			}
196
197			=head2 first
198
199			Return first element
200
201			$v = first( @v );
202
203			=cut
204
205			sub first {
206			my $r = shift;
207			return $r;
208			}
209
210			=head2 lookup
211
212			Consult lookup hashes for some value
213
214			@v = lookup( $v );
215			@v = lookup( @v );
216
217			=cut
218
219			sub lookup {
220			my $k = shift;
221			return unless ($lookup && defined($lookup->{$k}));
222			if (ref($lookup->{$k}) eq 'ARRAY') {
223			return @{ $lookup->{$k} };
224			} else {
225			return $lookup->{$k};
226			}
227			}
228
229			=head2 join_with
230
231			Joins walues with some delimiter
232
233			$v = join_with(", ", @v);
234
235			=cut
236
237			sub join_with {
238			my $d = shift;
239			return join($d, @_);
240			}
241
242			# END
243			1;