1 |
package WebPAC::Normalize; |
package WebPAC::Normalize; |
2 |
use Exporter 'import'; |
use Exporter 'import'; |
3 |
@EXPORT = qw/ |
@EXPORT = qw/ |
4 |
set_rec set_lookup |
_set_rec _set_lookup |
5 |
get_ds clean_ds |
_get_ds _clean_ds |
6 |
|
|
7 |
tag search display |
tag search display |
8 |
rec1 rec2 rec |
rec1 rec2 rec |
9 |
regex prefix suffix surround |
regex prefix suffix surround |
22 |
|
|
23 |
=head1 VERSION |
=head1 VERSION |
24 |
|
|
25 |
Version 0.04 |
Version 0.05 |
26 |
|
|
27 |
=cut |
=cut |
28 |
|
|
29 |
our $VERSION = '0.04'; |
our $VERSION = '0.05'; |
30 |
|
|
31 |
=head1 SYNOPSIS |
=head1 SYNOPSIS |
32 |
|
|
43 |
|
|
44 |
=head1 FUNCTIONS |
=head1 FUNCTIONS |
45 |
|
|
46 |
|
Functions which start with C<_> are private and used by WebPAC internally. |
47 |
|
All other functions are available for use within normalisation rules. |
48 |
|
|
49 |
=head2 data_structure |
=head2 data_structure |
50 |
|
|
51 |
Return data structure |
Return data structure |
52 |
|
|
53 |
my $ds = WebPAC::Normalize( |
my $ds = WebPAC::Normalize::data_structure( |
54 |
lookup => $lookup->lookup_hash, |
lookup => $lookup->lookup_hash, |
55 |
row => $row, |
row => $row, |
56 |
rules => $normalize_pl_config, |
rules => $normalize_pl_config, |
58 |
|
|
59 |
This function will B<die> if normalizastion can't be evaled. |
This function will B<die> if normalizastion can't be evaled. |
60 |
|
|
61 |
|
Since this function isn't exported you have to call it with |
62 |
|
C<WebPAC::Normalize::data_structure>. |
63 |
|
|
64 |
=cut |
=cut |
65 |
|
|
66 |
sub data_structure { |
sub data_structure { |
70 |
die "need normalisation argument" unless ($arg->{rules}); |
die "need normalisation argument" unless ($arg->{rules}); |
71 |
|
|
72 |
no strict 'subs'; |
no strict 'subs'; |
73 |
set_lookup( $arg->{lookup} ); |
_set_lookup( $arg->{lookup} ); |
74 |
set_rec( $arg->{row} ); |
_set_rec( $arg->{row} ); |
75 |
clean_ds(); |
_clean_ds(); |
76 |
eval "$arg->{rules}"; |
eval "$arg->{rules}"; |
77 |
die "error evaling $arg->{rules}: $@\n" if ($@); |
die "error evaling $arg->{rules}: $@\n" if ($@); |
78 |
return get_ds(); |
return _get_ds(); |
79 |
} |
} |
80 |
|
|
81 |
=head2 set_rec |
=head2 _set_rec |
82 |
|
|
83 |
Set current record hash |
Set current record hash |
84 |
|
|
85 |
set_rec( $rec ); |
_set_rec( $rec ); |
86 |
|
|
87 |
=cut |
=cut |
88 |
|
|
89 |
my $rec; |
my $rec; |
90 |
|
|
91 |
sub set_rec { |
sub _set_rec { |
92 |
$rec = shift or die "no record hash"; |
$rec = shift or die "no record hash"; |
93 |
} |
} |
94 |
|
|
95 |
|
=head2 _get_ds |
96 |
|
|
97 |
|
Return hash formatted as data structure |
98 |
|
|
99 |
|
my $ds = _get_ds(); |
100 |
|
|
101 |
|
=cut |
102 |
|
|
103 |
|
my $out; |
104 |
|
|
105 |
|
sub _get_ds { |
106 |
|
return $out; |
107 |
|
} |
108 |
|
|
109 |
|
=head2 _clean_ds |
110 |
|
|
111 |
|
Clean data structure hash for next record |
112 |
|
|
113 |
|
_clean_ds(); |
114 |
|
|
115 |
|
=cut |
116 |
|
|
117 |
|
sub _clean_ds { |
118 |
|
$out = undef; |
119 |
|
} |
120 |
|
|
121 |
|
=head2 _set_lookup |
122 |
|
|
123 |
|
Set current lookup hash |
124 |
|
|
125 |
|
_set_lookup( $lookup ); |
126 |
|
|
127 |
|
=cut |
128 |
|
|
129 |
|
my $lookup; |
130 |
|
|
131 |
|
sub _set_lookup { |
132 |
|
$lookup = shift; |
133 |
|
} |
134 |
|
|
135 |
=head2 tag |
=head2 tag |
136 |
|
|
137 |
Define new tag for I<search> and I<display>. |
Define new tag for I<search> and I<display>. |
141 |
|
|
142 |
=cut |
=cut |
143 |
|
|
|
my $out; |
|
|
|
|
144 |
sub tag { |
sub tag { |
145 |
my $name = shift or die "tag needs name as first argument"; |
my $name = shift or die "tag needs name as first argument"; |
146 |
my @o = grep { defined($_) && $_ ne '' } @_; |
my @o = grep { defined($_) && $_ ne '' } @_; |
182 |
$out->{$name}->{search} = \@o; |
$out->{$name}->{search} = \@o; |
183 |
} |
} |
184 |
|
|
|
=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; |
|
|
} |
|
|
|
|
185 |
=head2 rec1 |
=head2 rec1 |
186 |
|
|
187 |
Return all values in some field |
Return all values in some field |