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 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.02

=cut

our $VERSION = '0.02';

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

=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 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			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	dpavlin	461	Version 0.02
23	dpavlin	460
24			=cut
25
26	dpavlin	461	our $VERSION = '0.02';
27	dpavlin	460
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 tag
50
51			Define new tag for output
52
53			tag('Title', rec('200','a') );
54
55			By default, output will go into I<search> and I<display>.
56
57			=cut
58
59			my $out;
60
61			sub tag {
62			my $name = shift or "tag needs name as first argument";
63			return unless (@_);
64			$out->{$name}->{tag} = $name;
65			$out->{$name}->{search} = \@_;
66			$out->{$name}->{display} = \@_;
67			}
68
69			=head2 display
70
71			Define tag just for I<display>
72
73			@v = display('Title', rec('200','a') );
74
75			=cut
76
77			sub display {
78			my $name = shift or "display needs name as first argument";
79			return unless (@_);
80			$out->{$name}->{tag} = $name;
81			$out->{$name}->{display} = \@_;
82			}
83
84			=head2 search
85
86			Prepare values just for I<search>
87
88			@v = search('Title', rec('200','a') );
89
90			=cut
91
92			sub search {
93			my $name = shift or "search needs name as first argument";
94			return unless (@_);
95			$out->{$name}->{tag} = $name;
96			$out->{$name}->{search} = \@_;
97			}
98
99			=head2 get_ds
100
101			Return hash formatted as data structure
102
103			my $ds = get_ds();
104
105			=cut
106
107			sub get_ds {
108			return $out;
109			}
110
111	dpavlin	461	=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	dpavlin	460	my $lookup;
132
133			sub set_lookup {
134			$lookup = shift or die "no lookup hash";
135			}
136
137			=head2 rec1
138
139			Return all values in some field
140
141			@v = rec1('200')
142
143			TODO: order of values is probably same as in source data, need to investigate that
144
145			=cut
146
147			sub rec1 {
148			my $f = shift;
149	dpavlin	461	return unless (defined($rec && $rec->{$f}));
150	dpavlin	460	if (ref($rec->{$f}) eq 'ARRAY') {
151	dpavlin	461	if (ref($rec->{$f}->[0]) eq 'HASH') {
152			return map { values %{$_} } @{ $rec->{$f} };
153			} else {
154			return @{ $rec->{$f} };
155			}
156	dpavlin	460	} elsif( defined($rec->{$f}) ) {
157			return $rec->{$f};
158			}
159			}
160
161			=head2 rec2
162
163			Return all values in specific field and subfield
164
165			@v = rec2('200','a')
166
167			=cut
168
169			sub rec2 {
170			my $f = shift;
171	dpavlin	461	return unless (defined($rec && $rec->{$f}));
172	dpavlin	460	my $sf = shift;
173			return map { $_->{$sf} } grep { $_->{$sf} } @{ $rec->{$f} };
174			}
175
176			=head2 rec
177
178			syntaxtic sugar for
179
180			@v = rec('200')
181			@v = rec('200','a')
182
183			=cut
184
185			sub rec {
186			if ($#_ == 0) {
187			return rec1(@_);
188			} elsif ($#_ == 1) {
189			return rec2(@_);
190			}
191			}
192
193			=head2 regex
194
195			Apply regex to some or all values
196
197			@v = regex( 's/foo/bar/g', @v );
198
199			=cut
200
201			sub regex {
202			my $r = shift;
203			my @out;
204			warn "r: $r\n",Dumper(\@_);
205			foreach my $t (@_) {
206			eval "\$t =~ $r";
207			push @out, $t;
208			}
209			return @out;
210			}
211
212			=head2 first
213
214			Return first element
215
216			$v = first( @v );
217
218			=cut
219
220			sub first {
221			my $r = shift;
222			return $r;
223			}
224
225			=head2 lookup
226
227			Consult lookup hashes for some value
228
229			@v = lookup( $v );
230			@v = lookup( @v );
231
232			=cut
233
234			sub lookup {
235			my $k = shift;
236			return unless ($lookup && defined($lookup->{$k}));
237			if (ref($lookup->{$k}) eq 'ARRAY') {
238			return @{ $lookup->{$k} };
239			} else {
240			return $lookup->{$k};
241			}
242			}
243
244			=head2 join_with
245
246			Joins walues with some delimiter
247
248			$v = join_with(", ", @v);
249
250			=cut
251
252			sub join_with {
253			my $d = shift;
254			return join($d, @_);
255			}
256
257			# END
258			1;