trunk/t/3-normalize.t

#!/usr/bin/perl -w

use strict;

use Test::More tests => 67;
use Test::Exception;
use Cwd qw/abs_path/;
use blib;
use File::Slurp;

use Data::Dumper;
my $debug = shift @ARGV;

BEGIN {
        use_ok( 'WebPAC::Normalize' );
}

ok(my $abs_path = abs_path($0), "abs_path");
$abs_path =~ s#/[^/]*$#/#;
diag "abs_path: $abs_path" if ($debug);

#throws_ok { new WebPAC::Normalize::XML( lookup_regex => 'foo' ) } qr/pair/, "lookup_regex without lookup";

my $rec1 = {
        '200' => [{
                'a' => '200a',
                'b' => '200b',
                },{
                'c' => '200c',
                'd' => '200d',
                },{
                'a' => '200a*2',
                'd' => '200d*2',
                }],
        '201' => [{
                'x' => '201x',
                'y' => '201y',
                }],
        '900' => [
                '900-no_subfield'
                ],
        '901' => [{
                'a' => '900a',
                }],
        '902' => [{
                'z' => '900',
                }],
};

my $rec2 = {
 '675' => [ {
              'a' => '159.9'
            } ],
 '210' => [ {
              'c' => 'New York University press',
              'a' => 'New York',
              'd' => 'cop. 1988'
            } ],
 '700' => [ {
              'a' => 'Haynal',
              'b' => 'André'
            } ],
 '801' => [ 'FFZG' ],
 '991' => [ '8302' ],
 '000' => [ 1 ],
 '702' => [ {
              'a' => 'Holder',
              'b' => 'Elizabeth'
            } ],
 '215' => [ {
              'c' => 'ilustr',
              'a' => 'xix, 202 str',
              'd' => '23cm'
            } ],
 '990' => [
            '2140',
            '88',
            'HAY'
          ],
 '200' => [ {
              'e' => 'from Freud and Ferenczi to Michael balint',
              'a' => 'Controversies in psychoanalytic method',
              'g' => 'translated by Elizabeth Holder on the basisi of a first draft by Archie Hooton ; with a preface by Daniel N. Stern',
              'f' => 'by André E. Haynal'
            } ],
 '610' => [ 'povijest psihoanalize' ],
 '994' => [ {
              'c' => '',
              'a' => 'PS',
              'b' => 'MG'
            } ],
 '320' => [ 'Kazalo' ],
 '101' => [ 'ENG' ],
 '686' => [ '2140' ],
 '300' => [ 'Prijevod djela: ' ],
};


my $lookup1 = {
        '00900' => [
                'lookup 1',
                'lookup 2',
        ],
};

my $lookup2 = {
        '00900' => 'lookup',
};


sub test {
        print Dumper( @_ ), ("-" x 78), "\n";
        ok( defined(@_) );
}

# how much of string evaled to display?
my $max_eval_output = 170;

sub dump_error {
        my ($msg,$code) = @_;

        my @l = split(/[\n\r]/, $code);
        my $out = "$msg\n";

        foreach my $i ( 0 .. $#l ) {
                $out .= sprintf("%2d: %s\n", $i, $l[$i]);
        }

        return $out;
}

sub test_s {
        my $t = shift || die;

        my $eval_t = $t;
        $eval_t =~ s/[\n\r\s]+/ /gs;
        $eval_t = substr($eval_t,0,$max_eval_output) . '...' if (length($eval_t) > $max_eval_output);

        eval "$t";
        ok(! $@, $@ ? dump_error($@, $t) : "eval: $eval_t");
}

{
        no strict 'subs';
        use WebPAC::Normalize;

        ok(! _set_lookup( undef ), "set_lookup(undef)");

        _set_rec( $rec1 );

        cmp_ok( join(",", rec2('200','a') ), 'eq', '200a,200a*2', 'join rec2' );
        cmp_ok( join(",", rec2('200','a'), rec2('200','b') ), 'eq', '200a,200a*2,200b', 'join rec2 rec2' );
        cmp_ok( join(" * ", sort(rec1('200'), rec1('201') )), 'eq', '200a * 200a*2 * 200b * 200c * 200d * 200d*2 * 201x * 201y', 'join sort rec1 rec1' );
        diag "is_deeply checks\n";
        is_deeply( \[ rec1('200') ], \[ qw/200a 200b 200c 200d 200a*2 200d*2/ ] );
        is_deeply( \[ regex( 's/0/o/g', rec1('200') ) ],  \[ qw/2ooa 2oob 2ooc 2ood 2ooa*2 2ood*2/ ]);
        is_deeply( \[ grep { /\*/ } regex( 's/0/o/g', rec1('200') ) ], \[ qw/2ooa*2 2ood*2/ ]);
        is_deeply( \[ rec('902') ], \[ '900' ] );

        cmp_ok( rec('902'), 'eq', rec('902','z'), 'rec sf' );

        # simple list manipulatons
        cmp_ok( join('', prefix('ab', 'cd') ), 'eq', 'abcd', 'prefix');
        cmp_ok( join('', suffix('xy', 'cd') ), 'eq', 'cdxy', 'suffix');
        cmp_ok( join('', surround('->', '<-', 'a','b','c') ), 'eq', '->a<-->b<-->c<-', 'surround');


        _set_lookup( $lookup1 );
        
        cmp_ok(
                join_with(" i ",
                        lookup( 
                                regex( 's/^/00/',
                                        rec2('902','z')
                                )
                        ) 
                ),
        'eq', 'lookup 1 i lookup 2', 'join lookup regex rec2');

        # check join_with operations

        sub test_join_with_2 {
                my ($a,$b,$e) = @_;

                cmp_ok(
                        join_with(" <1> ",
                                rec('201',$a),
                                rec('201',$b),
                        ), 
                'eq', $e, "join_with $a <1> $b = $e");
        }

        test_join_with_2('_','_','');
        test_join_with_2('x','_','201x');
        test_join_with_2('_','x','201x');
        test_join_with_2('x','y','201x <1> 201y');

        sub test_join_with_3 {
                my ($a,$b,$c,$e) = @_;

                cmp_ok(
                        join_with(" <1> ", rec('201',$a),
                                join_with(" <2> ", rec('201',$b),
                                        rec('201',$c),
                                )
                        ), 
                'eq', $e, "join_with $a <1> $b <2> $c = $e");
        };

        test_join_with_3('_','_','_','');
        test_join_with_3('x','_','_','201x');
        test_join_with_3('_','x','_','201x');
        test_join_with_3('_','_','x','201x');
        test_join_with_3('x','y','_','201x <1> 201y');
        test_join_with_3('x','_','y','201x <1> 201y');
        test_join_with_3('_','x','y','201x <2> 201y');
        test_join_with_3('x','_','y','201x <1> 201y');
        test_join_with_3('x','y','x','201x <1> 201y <2> 201x');

        # test lookups

        _set_lookup( $lookup2 );

        is_deeply( \[ lookup( prefix( '00', rec('902') ) ) ], \[ 'lookup' ], 'lookup prefix' );

        ok(! lookup('non-existent'), 'lookup non-existant' );

        _set_rec( $rec2 );

        test_s(qq{
                tag('Title',
                        rec('200','a')
                );
        });
        test_s(qq{
                tag('Who',
                        join_with(" ",
                                rec('702','a'),
                                rec('702','b')
                        )
                );
        });

        test_s(qq{
                display('Publisher',
                        rec('210','c')
                )
        });
        
        test_s(qq{
                search('Year',
                        regex( 's/[^\\d]+//',
                                rec('210','d')
                        )
                )
        });

        ok(my $ds = _get_ds(), "get_ds");
        diag "ds = ", Dumper($ds) if ($debug);


        sub test_check_ds {

                my $t = shift;

                ok($ds = _get_ds(), 'get_ds');
                diag Dumper( $ds ) if ($debug);

                ok( $ds && $ds->{something}, 'get_ds->something exists' );
                ok( $ds && $ds->{something}->{$t}, 'get_ds->something->'.$t.' exists') if ($t);
                ok( $ds && !$ds->{empty}, 'get_ds->empty doesn\'t' );

                return $ds;
        }

        _clean_ds();
        test_s(qq{ search('something', '42'); });
        test_s(qq{ search('empty', ''); });
        test_check_ds('search');

        _clean_ds();
        test_s(qq{ display('something', '42'); });
        test_s(qq{ display('empty', ''); });
        test_check_ds('display');

        _clean_ds();
        test_s(qq{ tag('something', '42'); });
        test_s(qq{ tag('empty', ''); });
        test_check_ds('search');
        test_check_ds('display');

        _clean_ds();
        my $n = read_file( "$abs_path/data/normalize.pl" );
        $n .= "\n1;\n";
        #diag "normalize code:\n$n\n";
        test_s( $n );

        ok($ds = _get_ds(), "get_ds");
        diag "ds = ", Dumper($ds) if ($debug);

        my $rec = {
                '200' => [{
                        'a' => '200a',
                        'b' => '200b',
                }],
        };
        my $rules = qq{ search('mixed', rec('200') ) };
        
        _clean_ds();
        _set_rec( $rec );
        test_s( $rules );
        ok($ds = _get_ds(), "get_ds");
        is_deeply( $ds, {
                'mixed' => {
                        'search' => [ '200a', '200b' ],
                        'tag' => 'mixed'
                }
        }, 'correct get_ds');

        ok(my $ds2 = WebPAC::Normalize::data_structure(
                row => $rec,
                rules => $rules,
        ), 'data_structure');
        is_deeply( $ds, $ds2, 'data_structure(s) same');

        # wird and non-valid structure which is supported anyway
        _clean_ds();
        _set_rec({
                '200' => [{
                        'a' => '200a',
                },
                        '200-solo'
                ]
        });
        test_s(qq{ search('mixed', rec('200') ) });
        ok($ds = _get_ds(), "get_ds");
        is_deeply( $ds, {
                'mixed' => {
                        'search' => [ '200a', '200-solo' ],
                        'tag' => 'mixed'
                }
        }, 'correct get_ds');

}

1	dpavlin	536	#!/usr/bin/perl -w
2
3			use strict;
4
5			use Test::More tests => 67;
6			use Test::Exception;
7			use Cwd qw/abs_path/;
8			use blib;
9			use File::Slurp;
10
11			use Data::Dumper;
12			my $debug = shift @ARGV;
13
14			BEGIN {
15			use_ok( 'WebPAC::Normalize' );
16			}
17
18			ok(my $abs_path = abs_path($0), "abs_path");
19			$abs_path =~ s#/[^/]*$#/#;
20			diag "abs_path: $abs_path" if ($debug);
21
22			#throws_ok { new WebPAC::Normalize::XML( lookup_regex => 'foo' ) } qr/pair/, "lookup_regex without lookup";
23
24			my $rec1 = {
25			'200' => [{
26			'a' => '200a',
27			'b' => '200b',
28			},{
29			'c' => '200c',
30			'd' => '200d',
31			},{
32			'a' => '200a*2',
33			'd' => '200d*2',
34			}],
35			'201' => [{
36			'x' => '201x',
37			'y' => '201y',
38			}],
39			'900' => [
40			'900-no_subfield'
41			],
42			'901' => [{
43			'a' => '900a',
44			}],
45			'902' => [{
46			'z' => '900',
47			}],
48			};
49
50			my $rec2 = {
51			'675' => [ {
52			'a' => '159.9'
53			} ],
54			'210' => [ {
55			'c' => 'New York University press',
56			'a' => 'New York',
57			'd' => 'cop. 1988'
58			} ],
59			'700' => [ {
60			'a' => 'Haynal',
61			'b' => 'André'
62			} ],
63			'801' => [ 'FFZG' ],
64			'991' => [ '8302' ],
65			'000' => [ 1 ],
66			'702' => [ {
67			'a' => 'Holder',
68			'b' => 'Elizabeth'
69			} ],
70			'215' => [ {
71			'c' => 'ilustr',
72			'a' => 'xix, 202 str',
73			'd' => '23cm'
74			} ],
75			'990' => [
76			'2140',
77			'88',
78			'HAY'
79			],
80			'200' => [ {
81			'e' => 'from Freud and Ferenczi to Michael balint',
82			'a' => 'Controversies in psychoanalytic method',
83			'g' => 'translated by Elizabeth Holder on the basisi of a first draft by Archie Hooton ; with a preface by Daniel N. Stern',
84			'f' => 'by André E. Haynal'
85			} ],
86			'610' => [ 'povijest psihoanalize' ],
87			'994' => [ {
88			'c' => '',
89			'a' => 'PS',
90			'b' => 'MG'
91			} ],
92			'320' => [ 'Kazalo' ],
93			'101' => [ 'ENG' ],
94			'686' => [ '2140' ],
95			'300' => [ 'Prijevod djela: ' ],
96			};
97
98
99			my $lookup1 = {
100			'00900' => [
101			'lookup 1',
102			'lookup 2',
103			],
104			};
105
106			my $lookup2 = {
107			'00900' => 'lookup',
108			};
109
110
111			sub test {
112			print Dumper( @_ ), ("-" x 78), "\n";
113			ok( defined(@_) );
114			}
115
116			# how much of string evaled to display?
117			my $max_eval_output = 170;
118
119			sub dump_error {
120			my ($msg,$code) = @_;
121
122			my @l = split(/[\n\r]/, $code);
123			my $out = "$msg\n";
124
125			foreach my $i ( 0 .. $#l ) {
126			$out .= sprintf("%2d: %s\n", $i, $l[$i]);
127			}
128
129			return $out;
130			}
131
132			sub test_s {
133			my $t = shift \|\| die;
134
135			my $eval_t = $t;
136			$eval_t =~ s/[\n\r\s]+/ /gs;
137			$eval_t = substr($eval_t,0,$max_eval_output) . '...' if (length($eval_t) > $max_eval_output);
138
139			eval "$t";
140			ok(! $@, $@ ? dump_error($@, $t) : "eval: $eval_t");
141			}
142
143			{
144			no strict 'subs';
145			use WebPAC::Normalize;
146
147	dpavlin	538	ok(! _set_lookup( undef ), "set_lookup(undef)");
148	dpavlin	536
149	dpavlin	538	_set_rec( $rec1 );
150	dpavlin	536
151			cmp_ok( join(",", rec2('200','a') ), 'eq', '200a,200a*2', 'join rec2' );
152			cmp_ok( join(",", rec2('200','a'), rec2('200','b') ), 'eq', '200a,200a*2,200b', 'join rec2 rec2' );
153			cmp_ok( join(" * ", sort(rec1('200'), rec1('201') )), 'eq', '200a * 200a2 200b * 200c * 200d * 200d2 201x * 201y', 'join sort rec1 rec1' );
154			diag "is_deeply checks\n";
155			is_deeply( \[ rec1('200') ], \[ qw/200a 200b 200c 200d 200a2 200d2/ ] );
156			is_deeply( \[ regex( 's/0/o/g', rec1('200') ) ], \[ qw/2ooa 2oob 2ooc 2ood 2ooa2 2ood2/ ]);
157			is_deeply( \[ grep { /\/ } regex( 's/0/o/g', rec1('200') ) ], \[ qw/2ooa2 2ood*2/ ]);
158			is_deeply( \[ rec('902') ], \[ '900' ] );
159
160			cmp_ok( rec('902'), 'eq', rec('902','z'), 'rec sf' );
161
162			# simple list manipulatons
163			cmp_ok( join('', prefix('ab', 'cd') ), 'eq', 'abcd', 'prefix');
164			cmp_ok( join('', suffix('xy', 'cd') ), 'eq', 'cdxy', 'suffix');
165			cmp_ok( join('', surround('->', '<-', 'a','b','c') ), 'eq', '->a<-->b<-->c<-', 'surround');
166
167
168	dpavlin	538	_set_lookup( $lookup1 );
169	dpavlin	536
170			cmp_ok(
171			join_with(" i ",
172			lookup(
173			regex( 's/^/00/',
174			rec2('902','z')
175			)
176			)
177			),
178			'eq', 'lookup 1 i lookup 2', 'join lookup regex rec2');
179
180			# check join_with operations
181
182			sub test_join_with_2 {
183			my ($a,$b,$e) = @_;
184
185			cmp_ok(
186			join_with(" <1> ",
187			rec('201',$a),
188			rec('201',$b),
189			),
190			'eq', $e, "join_with $a <1> $b = $e");
191			}
192
193			test_join_with_2('_','_','');
194			test_join_with_2('x','_','201x');
195			test_join_with_2('_','x','201x');
196			test_join_with_2('x','y','201x <1> 201y');
197
198			sub test_join_with_3 {
199			my ($a,$b,$c,$e) = @_;
200
201			cmp_ok(
202			join_with(" <1> ", rec('201',$a),
203			join_with(" <2> ", rec('201',$b),
204			rec('201',$c),
205			)
206			),
207			'eq', $e, "join_with $a <1> $b <2> $c = $e");
208			};
209
210			test_join_with_3('_','_','_','');
211			test_join_with_3('x','_','_','201x');
212			test_join_with_3('_','x','_','201x');
213			test_join_with_3('_','_','x','201x');
214			test_join_with_3('x','y','_','201x <1> 201y');
215			test_join_with_3('x','_','y','201x <1> 201y');
216			test_join_with_3('_','x','y','201x <2> 201y');
217			test_join_with_3('x','_','y','201x <1> 201y');
218			test_join_with_3('x','y','x','201x <1> 201y <2> 201x');
219
220			# test lookups
221
222	dpavlin	538	_set_lookup( $lookup2 );
223	dpavlin	536
224			is_deeply( \[ lookup( prefix( '00', rec('902') ) ) ], \[ 'lookup' ], 'lookup prefix' );
225
226			ok(! lookup('non-existent'), 'lookup non-existant' );
227
228	dpavlin	538	_set_rec( $rec2 );
229	dpavlin	536
230			test_s(qq{
231			tag('Title',
232			rec('200','a')
233			);
234			});
235			test_s(qq{
236			tag('Who',
237			join_with(" ",
238			rec('702','a'),
239			rec('702','b')
240			)
241			);
242			});
243
244			test_s(qq{
245			display('Publisher',
246			rec('210','c')
247			)
248			});
249
250			test_s(qq{
251			search('Year',
252			regex( 's/[^\\d]+//',
253			rec('210','d')
254			)
255			)
256			});
257
258	dpavlin	538	ok(my $ds = _get_ds(), "get_ds");
259	dpavlin	536	diag "ds = ", Dumper($ds) if ($debug);
260
261
262			sub test_check_ds {
263
264			my $t = shift;
265
266	dpavlin	538	ok($ds = _get_ds(), 'get_ds');
267	dpavlin	536	diag Dumper( $ds ) if ($debug);
268
269			ok( $ds && $ds->{something}, 'get_ds->something exists' );
270			ok( $ds && $ds->{something}->{$t}, 'get_ds->something->'.$t.' exists') if ($t);
271			ok( $ds && !$ds->{empty}, 'get_ds->empty doesn\'t' );
272
273			return $ds;
274			}
275
276	dpavlin	538	_clean_ds();
277	dpavlin	536	test_s(qq{ search('something', '42'); });
278			test_s(qq{ search('empty', ''); });
279			test_check_ds('search');
280
281	dpavlin	538	_clean_ds();
282	dpavlin	536	test_s(qq{ display('something', '42'); });
283			test_s(qq{ display('empty', ''); });
284			test_check_ds('display');
285
286	dpavlin	538	_clean_ds();
287	dpavlin	536	test_s(qq{ tag('something', '42'); });
288			test_s(qq{ tag('empty', ''); });
289			test_check_ds('search');
290			test_check_ds('display');
291
292	dpavlin	538	_clean_ds();
293	dpavlin	536	my $n = read_file( "$abs_path/data/normalize.pl" );
294			$n .= "\n1;\n";
295			#diag "normalize code:\n$n\n";
296			test_s( $n );
297
298	dpavlin	538	ok($ds = _get_ds(), "get_ds");
299	dpavlin	536	diag "ds = ", Dumper($ds) if ($debug);
300
301			my $rec = {
302			'200' => [{
303			'a' => '200a',
304			'b' => '200b',
305			}],
306			};
307			my $rules = qq{ search('mixed', rec('200') ) };
308
309	dpavlin	538	_clean_ds();
310			_set_rec( $rec );
311	dpavlin	536	test_s( $rules );
312	dpavlin	538	ok($ds = _get_ds(), "get_ds");
313	dpavlin	536	is_deeply( $ds, {
314			'mixed' => {
315			'search' => [ '200a', '200b' ],
316			'tag' => 'mixed'
317			}
318			}, 'correct get_ds');
319
320			ok(my $ds2 = WebPAC::Normalize::data_structure(
321			row => $rec,
322			rules => $rules,
323			), 'data_structure');
324			is_deeply( $ds, $ds2, 'data_structure(s) same');
325
326			# wird and non-valid structure which is supported anyway
327	dpavlin	538	_clean_ds();
328			_set_rec({
329	dpavlin	536	'200' => [{
330			'a' => '200a',
331			},
332			'200-solo'
333			]
334			});
335			test_s(qq{ search('mixed', rec('200') ) });
336	dpavlin	538	ok($ds = _get_ds(), "get_ds");
337	dpavlin	536	is_deeply( $ds, {
338			'mixed' => {
339			'search' => [ '200a', '200-solo' ],
340			'tag' => 'mixed'
341			}
342			}, 'correct get_ds');
343
344			}
345