WebPAC/Normalize/Set.pm

package WebPAC::Normalize::Set;
use Exporter 'import';
@EXPORT = qw/
        set_rec set_lookup
        get_ds clean_ds
        tag search display
        rec1 rec2 rec
        regex prefix
        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.03

=cut

our $VERSION = '0.03';

=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 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;

sub tag {
        my $name = shift or die "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 die "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 die "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;
}

=head2 clean_ds

Clean data structure hash for next record

  clean_ds();

=cut

sub clean_ds {
        $out = undef;
}

=head2 set_lookup

Set current lookup hash

  set_lookup( $lookup );

=cut

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;
        return unless (defined($rec && $rec->{$f}));
        if (ref($rec->{$f}) eq 'ARRAY') {
                if (ref($rec->{$f}->[0]) eq 'HASH') {
                        return map { values %{$_} } @{ $rec->{$f} };
                } else {
                        return @{ $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;
        return unless (defined($rec && $rec->{$f}));
        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 {
        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 (@_) {
                eval "\$t =~ $r";
                push @out, $t;
        }
        return @out;
}

=head2 prefix

Prefix all values with a string

  @v = prefix( 'my_', @v );

=cut

sub prefix {
        my $p = shift or die "prefix needs string as first argument";
        return map { $p . $_ } @_;
}

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