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 using perl functions which are specialized for set
processing.

Sets are implemented as arrays, and normalisation file is valid perl, which
means that you check it's validity before running WebPAC using
C<perl -c normalize.pl>.

Normalisation can generate multiple output normalized data. For now, supported output
types (on the left side of definition) are: C<tag>, C<display> and C<search>.

=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 I<search> and I<display>.

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


=cut

my $out;

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

=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";
        my @o = grep { defined($_) && $_ ne '' } @_;
        return unless (@o);
        $out->{$name}->{tag} = $name;
        $out->{$name}->{display} = \@o;
}

=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";
        my @o = grep { defined($_) && $_ ne '' } @_;
        return unless (@o);
        $out->{$name}->{tag} = $name;
        $out->{$name}->{search} = \@o;
}

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

=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 . $_ } grep { defined($_) } @_;
}

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