git.rot13.org Git - webpac2/blob - t/3-normalize.t

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4
   5 use Test::More tests => 69;
   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         ok(! _set_lookup( undef ), "set_lookup(undef)");
 148
 149         _set_rec( $rec1 );
 150
 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 * 200a*2 * 200b * 200c * 200d * 200d*2 * 201x * 201y', 'join sort rec1 rec1' );
 154         diag "is_deeply checks\n";
 155         is_deeply( \[ rec1('200') ], \[ qw/200a 200b 200c 200d 200a*2 200d*2/ ] );
 156         is_deeply( \[ regex( 's/0/o/g', rec1('200') ) ],  \[ qw/2ooa 2oob 2ooc 2ood 2ooa*2 2ood*2/ ]);
 157         is_deeply( \[ grep { /\*/ } regex( 's/0/o/g', rec1('200') ) ], \[ qw/2ooa*2 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         _set_lookup( $lookup1 );
 169
 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         _set_lookup( $lookup2 );
 223
 224         is_deeply( \[ lookup( prefix( '00', rec('902') ) ) ], \[ 'lookup' ], 'lookup prefix' );
 225
 226         ok(! lookup('non-existent'), 'lookup non-existant' );
 227
 228         _set_rec( $rec2 );
 229
 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         ok(my $ds = _get_ds(), "get_ds");
 259         diag "ds = ", Dumper($ds) if ($debug);
 260
 261
 262         sub test_check_ds {
 263
 264                 my $t = shift;
 265
 266                 ok($ds = _get_ds(), 'get_ds');
 267                 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         _clean_ds();
 277         test_s(qq{ search('something', '42'); });
 278         test_s(qq{ search('empty', ''); });
 279         test_check_ds('search');
 280
 281         _clean_ds();
 282         test_s(qq{ display('something', '42'); });
 283         test_s(qq{ display('empty', ''); });
 284         test_check_ds('display');
 285
 286         _clean_ds();
 287         test_s(qq{ tag('something', '42'); });
 288         test_s(qq{ tag('empty', ''); });
 289         test_check_ds('search');
 290         test_check_ds('display');
 291
 292         _clean_ds();
 293         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         ok($ds = _get_ds(), "get_ds");
 299         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         _clean_ds();
 310         _set_rec( $rec );
 311         test_s( $rules );
 312         ok($ds = _get_ds(), "get_ds");
 313         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         _clean_ds();
 328         _set_rec({
 329                 '200' => [{
 330                         'a' => '200a',
 331                 },
 332                         '200-solo'
 333                 ]
 334         });
 335         test_s(qq{ search('mixed', rec('200') ) });
 336         ok($ds = _get_ds(), "get_ds");
 337         is_deeply( $ds, {
 338                 'mixed' => {
 339                         'search' => [ '200a', '200-solo' ],
 340                         'tag' => 'mixed'
 341                 }
 342         }, 'correct get_ds');
 343
 344         # MARC
 345         test_s(qq{ marc21('900','a', rec('200') ) });
 346         my @marc;
 347         ok(@marc = WebPAC::Normalize::_get_marc21_fields(), "_get_marc21_fields");
 348         diag Dumper(\@marc);
 349 }
 350