trunk/t/3-normalize-set.t

#!/usr/bin/perl -w

use strict;

use Test::More tests => 43;
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::Set' );
}

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::Set;

        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' );

        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');

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

1	dpavlin	460	#!/usr/bin/perl -w
2
3			use strict;
4
5	dpavlin	476	use Test::More tests => 43;
6	dpavlin	460	use Test::Exception;
7			use Cwd qw/abs_path/;
8			use blib;
9			use File::Slurp;
10
11			use Data::Dumper;
12	dpavlin	472	my $debug = shift @ARGV;
13	dpavlin	460
14			BEGIN {
15			use_ok( 'WebPAC::Normalize::Set' );
16			}
17
18			ok(my $abs_path = abs_path($0), "abs_path");
19	dpavlin	468	$abs_path =~ s#/[^/]*$#/#;
20	dpavlin	464	diag "abs_path: $abs_path" if ($debug);
21	dpavlin	460
22			#throws_ok { new WebPAC::Normalize::XML( lookup_regex => 'foo' ) } qr/pair/, "lookup_regex without lookup";
23
24	dpavlin	464	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	dpavlin	460	'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	dpavlin	464	my $lookup1 = {
100	dpavlin	460	'00900' => [
101	dpavlin	464	'lookup 1',
102			'lookup 2',
103	dpavlin	460	],
104			};
105
106	dpavlin	464	my $lookup2 = {
107			'00900' => 'lookup',
108			};
109	dpavlin	460
110	dpavlin	464
111	dpavlin	460	sub test {
112			print Dumper( @_ ), ("-" x 78), "\n";
113			ok( defined(@_) );
114			}
115
116	dpavlin	471	# 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	dpavlin	460	sub test_s {
133			my $t = shift \|\| die;
134	dpavlin	471
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	dpavlin	460	}
142
143			{
144			no strict 'subs';
145			use WebPAC::Normalize::Set;
146
147	dpavlin	476	ok(! set_lookup( undef ), "set_lookup(undef)");
148
149	dpavlin	464	set_rec( $rec1 );
150	dpavlin	460
151	dpavlin	471	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	dpavlin	464	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	dpavlin	471	cmp_ok( rec('902'), 'eq', rec('902','z'), 'rec sf' );
161
162	dpavlin	464	set_lookup( $lookup1 );
163
164			cmp_ok(
165	dpavlin	460	join_with(" i ",
166			lookup(
167			regex( 's/^/00/',
168	dpavlin	464	rec2('902','z')
169	dpavlin	460	)
170			)
171	dpavlin	464	),
172	dpavlin	471	'eq', 'lookup 1 i lookup 2', 'join lookup regex rec2');
173	dpavlin	460
174	dpavlin	464	set_lookup( $lookup2 );
175
176	dpavlin	471	is_deeply( \[ lookup( prefix( '00', rec('902') ) ) ], \[ 'lookup' ], 'lookup prefix' );
177	dpavlin	464
178	dpavlin	471	ok(! lookup('non-existent'), 'lookup non-existant' );
179	dpavlin	464
180			set_rec( $rec2 );
181
182	dpavlin	460	test_s(qq{
183			tag('Title',
184			rec('200','a')
185			);
186			});
187			test_s(qq{
188			tag('Who',
189			join_with(" ",
190			rec('702','a'),
191			rec('702','b')
192			)
193			);
194			});
195
196			test_s(qq{
197			display('Publisher',
198			rec('210','c')
199			)
200			});
201
202			test_s(qq{
203			search('Year',
204			regex( 's/[^\\d]+//',
205			rec('210','d')
206			)
207			)
208			});
209
210			ok(my $ds = get_ds(), "get_ds");
211	dpavlin	464	diag "ds = ", Dumper($ds) if ($debug);
212	dpavlin	460
213	dpavlin	472
214			sub test_check_ds {
215
216			my $t = shift;
217
218			ok($ds = get_ds(), 'get_ds');
219			diag Dumper( $ds ) if ($debug);
220
221			ok( $ds && $ds->{something}, 'get_ds->something exists' );
222			ok( $ds && $ds->{something}->{$t}, 'get_ds->something->'.$t.' exists') if ($t);
223			ok( $ds && !$ds->{empty}, 'get_ds->empty doesn\'t' );
224
225			return $ds;
226			}
227
228	dpavlin	461	clean_ds();
229	dpavlin	471	test_s(qq{ search('something', '42'); });
230			test_s(qq{ search('empty', ''); });
231	dpavlin	472	test_check_ds('search');
232	dpavlin	471
233	dpavlin	472	clean_ds();
234			test_s(qq{ display('something', '42'); });
235			test_s(qq{ display('empty', ''); });
236			test_check_ds('display');
237	dpavlin	471
238	dpavlin	472	clean_ds();
239			test_s(qq{ tag('something', '42'); });
240			test_s(qq{ tag('empty', ''); });
241			test_check_ds('search');
242			test_check_ds('display');
243	dpavlin	471
244			clean_ds();
245	dpavlin	468	my $n = read_file( "$abs_path/data/normalize.pl" );
246	dpavlin	461	$n .= "\n1;\n";
247	dpavlin	460	#diag "normalize code:\n$n\n";
248	dpavlin	461	test_s( $n );
249
250			ok($ds = get_ds(), "get_ds");
251	dpavlin	464	diag "ds = ", Dumper($ds) if ($debug);
252	dpavlin	460	}
253