git.rot13.org Git - webpac2/blob - lib/WebPAC/Normalize.pm

   1 package WebPAC::Normalize;
   2 use Exporter 'import';
   3 @EXPORT = qw/
   4         _set_rec _set_lookup
   5         _set_load_row
   6         _get_ds _clean_ds
   7         _debug
   8         _pack_subfields_hash
   9
  10         tag search display
  11         marc marc_indicators marc_repeatable_subfield
  12         marc_compose marc_leader
  13         marc_duplicate marc_remove
  14         marc_original_order
  15
  16         rec1 rec2 rec
  17         regex prefix suffix surround
  18         first lookup join_with
  19         save_into_lookup
  20
  21         split_rec_on
  22
  23         get set
  24 /;
  25
  26 use warnings;
  27 use strict;
  28
  29 #use base qw/WebPAC::Common/;
  30 use Data::Dump qw/dump/;
  31 use Storable qw/dclone/;
  32 use Carp qw/confess/;
  33
  34 # debugging warn(s)
  35 my $debug = 0;
  36
  37
  38 =head1 NAME
  39
  40 WebPAC::Normalize - describe normalisaton rules using sets
  41
  42 =head1 VERSION
  43
  44 Version 0.24
  45
  46 =cut
  47
  48 our $VERSION = '0.24';
  49
  50 =head1 SYNOPSIS
  51
  52 This module uses C<conf/normalize/*.pl> files to perform normalisation
  53 from input records using perl functions which are specialized for set
  54 processing.
  55
  56 Sets are implemented as arrays, and normalisation file is valid perl, which
  57 means that you check it's validity before running WebPAC using
  58 C<perl -c normalize.pl>.
  59
  60 Normalisation can generate multiple output normalized data. For now, supported output
  61 types (on the left side of definition) are: C<tag>, C<display>, C<search> and
  62 C<marc>.
  63
  64 =head1 FUNCTIONS
  65
  66 Functions which start with C<_> are private and used by WebPAC internally.
  67 All other functions are available for use within normalisation rules.
  68
  69 =head2 data_structure
  70
  71 Return data structure
  72
  73   my $ds = WebPAC::Normalize::data_structure(
  74         lookup => $lookup_hash,
  75         row => $row,
  76         rules => $normalize_pl_config,
  77         marc_encoding => 'utf-8',
  78         config => $config,
  79         load_row_coderef => sub {
  80                 my ($database,$input,$mfn) = shift;
  81                 $store->load_row( database => $database, input => $input, id => $mfn );
  82         },
  83   );
  84
  85 Options C<row>, C<rules> and C<log> are mandatory while all
  86 other are optional.
  87
  88 C<load_row_coderef> is closure only used when executing lookups, so they will
  89 die if it's not defined.
  90
  91 This function will B<die> if normalizastion can't be evaled.
  92
  93 Since this function isn't exported you have to call it with
  94 C<WebPAC::Normalize::data_structure>.
  95
  96 =cut
  97
  98 my $load_row_coderef;
  99
 100 sub data_structure {
 101         my $arg = {@_};
 102
 103         die "need row argument" unless ($arg->{row});
 104         die "need normalisation argument" unless ($arg->{rules});
 105
 106         no strict 'subs';
 107         _set_lookup( $arg->{lookup} ) if defined($arg->{lookup});
 108         _set_rec( $arg->{row} );
 109         _set_config( $arg->{config} ) if defined($arg->{config});
 110         _clean_ds( %{ $arg } );
 111         $load_row_coderef = $arg->{load_row_coderef};
 112
 113         eval "$arg->{rules}";
 114         die "error evaling $arg->{rules}: $@\n" if ($@);
 115
 116         return _get_ds();
 117 }
 118
 119 =head2 _set_rec
 120
 121 Set current record hash
 122
 123   _set_rec( $rec );
 124
 125 =cut
 126
 127 my $rec;
 128
 129 sub _set_rec {
 130         $rec = shift or die "no record hash";
 131 }
 132
 133 =head2 _set_config
 134
 135 Set current config hash
 136
 137   _set_config( $config );
 138
 139 Magic keys are:
 140
 141 =over 4
 142
 143 =item _
 144
 145 Code of current database
 146
 147 =item _mfn
 148
 149 Current MFN
 150
 151 =back
 152
 153 =cut
 154
 155 my $config;
 156
 157 sub _set_config {
 158         $config = shift;
 159 }
 160
 161 =head2 _get_ds
 162
 163 Return hash formatted as data structure
 164
 165   my $ds = _get_ds();
 166
 167 =cut
 168
 169 my ($out, $marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators, $leader);
 170 my ($marc_record_offset, $marc_fetch_offset) = (0, 0);
 171
 172 sub _get_ds {
 173         return $out;
 174 }
 175
 176 =head2 _clean_ds
 177
 178 Clean data structure hash for next record
 179
 180   _clean_ds();
 181
 182 =cut
 183
 184 sub _clean_ds {
 185         my $a = {@_};
 186         ($out,$marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators, $leader) = ();
 187         ($marc_record_offset, $marc_fetch_offset) = (0,0);
 188         $marc_encoding = $a->{marc_encoding};
 189 }
 190
 191 =head2 _set_lookup
 192
 193 Set current lookup hash
 194
 195   _set_lookup( $lookup );
 196
 197 =cut
 198
 199 my $lookup;
 200
 201 sub _set_lookup {
 202         $lookup = shift;
 203 }
 204
 205 =head2 _get_lookup
 206
 207 Get current lookup hash
 208
 209   my $lookup = _get_lookup();
 210
 211 =cut
 212
 213 sub _get_lookup {
 214         return $lookup;
 215 }
 216
 217 =head2 _set_load_row
 218
 219 Setup code reference which will return L<data_structure> from
 220 L<WebPAC::Store>
 221
 222   _set_load_row(sub {
 223                 my ($database,$input,$mfn) = @_;
 224                 $store->load_row( database => $database, input => $input, id => $mfn );
 225   });
 226
 227 =cut
 228
 229 sub _set_load_row {
 230         my $coderef = shift;
 231         confess "argument isn't CODE" unless ref($coderef) eq 'CODE';
 232
 233         $load_row_coderef = $coderef;
 234 }
 235
 236 =head2 _get_marc_fields
 237
 238 Get all fields defined by calls to C<marc>
 239
 240         $marc->add_fields( WebPAC::Normalize:_get_marc_fields() );
 241
 242 We are using I<magic> which detect repeatable fields only from
 243 sequence of field/subfield data generated by normalization.
 244
 245 Repeatable field is created when there is second occurence of same subfield or
 246 if any of indicators are different.
 247
 248 This is sane for most cases. Something like:
 249
 250   900a-1 900b-1 900c-1
 251   900a-2 900b-2
 252   900a-3
 253
 254 will be created from any combination of:
 255
 256   900a-1 900a-2 900a-3 900b-1 900b-2 900c-1
 257
 258 and following rules:
 259
 260   marc('900','a', rec('200','a') );
 261   marc('900','b', rec('200','b') );
 262   marc('900','c', rec('200','c') );
 263
 264 which might not be what you have in mind. If you need repeatable subfield,
 265 define it using C<marc_repeatable_subfield> like this:
 266
 267   marc_repeatable_subfield('900','a');
 268   marc('900','a', rec('200','a') );
 269   marc('900','b', rec('200','b') );
 270   marc('900','c', rec('200','c') );
 271
 272 will create:
 273
 274   900a-1 900a-2 900a-3 900b-1 900c-1
 275   900b-2
 276
 277 There is also support for returning next or specific using:
 278
 279   while (my $mf = WebPAC::Normalize:_get_marc_fields( fetch_next => 1 ) ) {
 280         # do something with $mf
 281   }
 282
 283 will always return fields from next MARC record or
 284
 285   my $mf = WebPAC::Normalize::_get_marc_fields( offset => 42 );
 286
 287 will return 42th copy record (if it exists).
 288
 289 =cut
 290
 291 sub _get_marc_fields {
 292
 293         my $arg = {@_};
 294         warn "### _get_marc_fields arg: ", dump($arg), $/ if ($debug > 2);
 295         my $offset = $marc_fetch_offset;
 296         if ($arg->{offset}) {
 297                 $offset = $arg->{offset};
 298         } elsif($arg->{fetch_next}) {
 299                 $marc_fetch_offset++;
 300         }
 301
 302         return if (! $marc_record || ref($marc_record) ne 'ARRAY');
 303
 304         warn "### full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 2);
 305
 306         my $marc_rec = $marc_record->[ $offset ];
 307
 308         warn "## _get_marc_fields (at offset: $offset) -- marc_record = ", dump( @$marc_rec ), $/ if ($debug > 1);
 309
 310         return if (! $marc_rec || ref($marc_rec) ne 'ARRAY' || $#{ $marc_rec } < 0);
 311
 312         # first, sort all existing fields
 313         # XXX might not be needed, but modern perl might randomize elements in hash
 314         my @sorted_marc_record = sort {
 315                 $a->[0] . ( $a->[3] || '' ) cmp $b->[0] . ( $b->[3] || '')
 316         } @{ $marc_rec };
 317
 318         @sorted_marc_record = @{ $marc_rec };   ### FIXME disable sorting
 319
 320         # output marc fields
 321         my @m;
 322
 323         # count unique field-subfields (used for offset when walking to next subfield)
 324         my $u;
 325         map { $u->{ $_->[0] . ( $_->[3] || '')  }++ } @sorted_marc_record;
 326
 327         if ($debug) {
 328                 warn "## marc_repeatable_subfield = ", dump( $marc_repeatable_subfield ), $/ if ( $marc_repeatable_subfield );
 329                 warn "## marc_record[$offset] = ", dump( $marc_rec ), $/;
 330                 warn "## sorted_marc_record = ", dump( \@sorted_marc_record ), $/;
 331                 warn "## subfield count = ", dump( $u ), $/;
 332         }
 333
 334         my $len = $#sorted_marc_record;
 335         my $visited;
 336         my $i = 0;
 337         my $field;
 338
 339         foreach ( 0 .. $len ) {
 340
 341                 # find next element which isn't visited
 342                 while ($visited->{$i}) {
 343                         $i = ($i + 1) % ($len + 1);
 344                 }
 345
 346                 # mark it visited
 347                 $visited->{$i}++;
 348
 349                 my $row = dclone( $sorted_marc_record[$i] );
 350
 351                 # field and subfield which is key for
 352                 # marc_repeatable_subfield and u
 353                 my $fsf = $row->[0] . ( $row->[3] || '' );
 354
 355                 if ($debug > 1) {
 356
 357                         print "### field so far [", $#$field, "] : ", dump( $field ), " ", $field ? 'T' : 'F', $/;
 358                         print "### this [$i]: ", dump( $row ),$/;
 359                         print "### sf: ", $row->[3], " vs ", $field->[3],
 360                                 $marc_repeatable_subfield->{ $row->[0] . $row->[3] } ? ' (repeatable)' : '', $/,
 361                                 if ($#$field >= 0);
 362
 363                 }
 364
 365                 # if field exists
 366                 if ( $#$field >= 0 ) {
 367                         if (
 368                                 $row->[0] ne $field->[0] ||             # field
 369                                 $row->[1] ne $field->[1] ||             # i1
 370                                 $row->[2] ne $field->[2]                # i2
 371                         ) {
 372                                 push @m, $field;
 373                                 warn "## saved/1 ", dump( $field ),$/ if ($debug);
 374                                 $field = $row;
 375
 376                         } elsif (
 377                                 ( $row->[3] lt $field->[-2] )           # subfield which is not next (e.g. a after c)
 378                                 ||
 379                                 ( $row->[3] eq $field->[-2] &&          # same subfield, but not repeatable
 380                                         ! $marc_repeatable_subfield->{ $fsf }
 381                                 )
 382                         ) {
 383                                 push @m, $field;
 384                                 warn "## saved/2 ", dump( $field ),$/ if ($debug);
 385                                 $field = $row;
 386
 387                         } else {
 388                                 # append new subfields to existing field
 389                                 push @$field, ( $row->[3], $row->[4] );
 390                         }
 391                 } else {
 392                         # insert first field
 393                         $field = $row;
 394                 }
 395
 396                 if (! $marc_repeatable_subfield->{ $fsf }) {
 397                         # make step to next subfield
 398                         $i = ($i + $u->{ $fsf } ) % ($len + 1);
 399                 }
 400         }
 401
 402         if ($#$field >= 0) {
 403                 push @m, $field;
 404                 warn "## saved/3 ", dump( $field ),$/ if ($debug);
 405         }
 406
 407         return \@m;
 408 }
 409
 410 =head2 _debug
 411
 412 Change level of debug warnings
 413
 414   _debug( 2 );
 415
 416 =cut
 417
 418 sub _debug {
 419         my $l = shift;
 420         return $debug unless defined($l);
 421         warn "debug level $l",$/ if ($l > 0);
 422         $debug = $l;
 423 }
 424
 425 =head1 Functions to create C<data_structure>
 426
 427 Those functions generally have to first in your normalization file.
 428
 429 =head2 tag
 430
 431 Define new tag for I<search> and I<display>.
 432
 433   tag('Title', rec('200','a') );
 434
 435
 436 =cut
 437
 438 sub tag {
 439         my $name = shift or die "tag needs name as first argument";
 440         my @o = grep { defined($_) && $_ ne '' } @_;
 441         return unless (@o);
 442         $out->{$name}->{tag} = $name;
 443         $out->{$name}->{search} = \@o;
 444         $out->{$name}->{display} = \@o;
 445 }
 446
 447 =head2 display
 448
 449 Define tag just for I<display>
 450
 451   @v = display('Title', rec('200','a') );
 452
 453 =cut
 454
 455 sub display {
 456         my $name = shift or die "display needs name as first argument";
 457         my @o = grep { defined($_) && $_ ne '' } @_;
 458         return unless (@o);
 459         $out->{$name}->{tag} = $name;
 460         $out->{$name}->{display} = \@o;
 461 }
 462
 463 =head2 search
 464
 465 Prepare values just for I<search>
 466
 467   @v = search('Title', rec('200','a') );
 468
 469 =cut
 470
 471 sub search {
 472         my $name = shift or die "search needs name as first argument";
 473         my @o = grep { defined($_) && $_ ne '' } @_;
 474         return unless (@o);
 475         $out->{$name}->{tag} = $name;
 476         $out->{$name}->{search} = \@o;
 477 }
 478
 479 =head2 marc_leader
 480
 481 Setup fields within MARC leader or get leader
 482
 483   marc_leader('05','c');
 484   my $leader = marc_leader();
 485
 486 =cut
 487
 488 sub marc_leader {
 489         my ($offset,$value) = @_;
 490
 491         if ($offset) {
 492                 $leader->{ $offset } = $value;
 493         } else {
 494                 return $leader;
 495         }
 496 }
 497
 498 =head2 marc
 499
 500 Save value for MARC field
 501
 502   marc('900','a', rec('200','a') );
 503   marc('001', rec('000') );
 504
 505 =cut
 506
 507 sub marc {
 508         my $f = shift or die "marc needs field";
 509         die "marc field must be numer" unless ($f =~ /^\d+$/);
 510
 511         my $sf;
 512         if ($f >= 10) {
 513                 $sf = shift or die "marc needs subfield";
 514         }
 515
 516         foreach (@_) {
 517                 my $v = $_;             # make var read-write for Encode
 518                 next unless (defined($v) && $v !~ /^\s*$/);
 519                 my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');
 520                 if (defined $sf) {
 521                         push @{ $marc_record->[ $marc_record_offset ] }, [ $f, $i1, $i2, $sf => $v ];
 522                 } else {
 523                         push @{ $marc_record->[ $marc_record_offset ] }, [ $f, $v ];
 524                 }
 525         }
 526 }
 527
 528 =head2 marc_repeatable_subfield
 529
 530 Save values for MARC repetable subfield
 531
 532   marc_repeatable_subfield('910', 'z', rec('909') );
 533
 534 =cut
 535
 536 sub marc_repeatable_subfield {
 537         my ($f,$sf) = @_;
 538         die "marc_repeatable_subfield need field and subfield!\n" unless ($f && $sf);
 539         $marc_repeatable_subfield->{ $f . $sf }++;
 540         marc(@_);
 541 }
 542
 543 =head2 marc_indicators
 544
 545 Set both indicators for MARC field
 546
 547   marc_indicators('900', ' ', 1);
 548
 549 Any indicator value other than C<0-9> will be treated as undefined.
 550
 551 =cut
 552
 553 sub marc_indicators {
 554         my $f = shift || die "marc_indicators need field!\n";
 555         my ($i1,$i2) = @_;
 556         die "marc_indicators($f, ...) need i1!\n" unless(defined($i1));
 557         die "marc_indicators($f, $i1, ...) need i2!\n" unless(defined($i2));
 558
 559         $i1 = ' ' if ($i1 !~ /^\d$/);
 560         $i2 = ' ' if ($i2 !~ /^\d$/);
 561         @{ $marc_indicators->{$f} } = ($i1,$i2);
 562 }
 563
 564 =head2 marc_compose
 565
 566 Save values for each MARC subfield explicitly
 567
 568   marc_compose('900',
 569         'a', rec('200','a')
 570         'b', rec('201','a')
 571         'a', rec('200','b')
 572         'c', rec('200','c')
 573   );
 574
 575 If you specify C<+> for subfield, value will be appended
 576 to previous defined subfield.
 577
 578 =cut
 579
 580 sub marc_compose {
 581         my $f = shift or die "marc_compose needs field";
 582         die "marc_compose field must be numer" unless ($f =~ /^\d+$/);
 583
 584         my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');
 585         my $m = [ $f, $i1, $i2 ];
 586
 587         warn "### marc_compose input subfields = ", dump(@_),$/ if ($debug > 2);
 588
 589         if ($#_ % 2 != 1) {
 590                 die "ERROR: marc_compose",dump($f,@_)," not valid (must be even).\nDo you need to add first() or join() around some argument?\n";
 591         }
 592
 593         while (@_) {
 594                 my $sf = shift;
 595                 my $v = shift;
 596
 597                 next unless (defined($v) && $v !~ /^\s*$/);
 598                 warn "## ++ marc_compose($f,$sf,$v) ", dump( $m ),$/ if ($debug > 1);
 599                 if ($sf ne '+') {
 600                         push @$m, ( $sf, $v );
 601                 } else {
 602                         $m->[ $#$m ] .= $v;
 603                 }
 604         }
 605
 606         warn "## marc_compose current marc = ", dump( $m ),$/ if ($debug > 1);
 607
 608         push @{ $marc_record->[ $marc_record_offset ] }, $m if ($#{$m} > 2);
 609 }
 610
 611 =head2 marc_duplicate
 612
 613 Generate copy of current MARC record and continue working on copy
 614
 615   marc_duplicate();
 616
 617 Copies can be accessed using C<< _get_marc_fields( fetch_next => 1 ) >> or
 618 C<< _get_marc_fields( offset => 42 ) >>.
 619
 620 =cut
 621
 622 sub marc_duplicate {
 623          my $m = $marc_record->[ -1 ];
 624          die "can't duplicate record which isn't defined" unless ($m);
 625          push @{ $marc_record }, dclone( $m );
 626          warn "## marc_duplicate = ", dump(@$marc_record), $/ if ($debug > 1);
 627          $marc_record_offset = $#{ $marc_record };
 628          warn "## marc_record_offset = $marc_record_offset", $/ if ($debug > 1);
 629 }
 630
 631 =head2 marc_remove
 632
 633 Remove some field or subfield from MARC record.
 634
 635   marc_remove('200');
 636   marc_remove('200','a');
 637
 638 This will erase field C<200> or C<200^a> from current MARC record.
 639
 640 This is useful after calling C<marc_duplicate> or on it's own (but, you
 641 should probably just remove that subfield definition if you are not
 642 using C<marc_duplicate>).
 643
 644 FIXME: support fields < 10.
 645
 646 =cut
 647
 648 sub marc_remove {
 649         my ($f, $sf) = @_;
 650
 651         die "marc_remove needs record number" unless defined($f);
 652
 653         my $marc = $marc_record->[ $marc_record_offset ];
 654
 655         warn "### marc_remove before = ", dump( $marc ), $/ if ($debug > 2);
 656
 657         my $i = 0;
 658         foreach ( 0 .. $#{ $marc } ) {
 659                 last unless (defined $marc->[$i]);
 660                 warn "#### working on ",dump( @{ $marc->[$i] }), $/ if ($debug > 3);
 661                 if ($marc->[$i]->[0] eq $f) {
 662                         if (! defined $sf) {
 663                                 # remove whole field
 664                                 splice @$marc, $i, 1;
 665                                 warn "#### slice \@\$marc, $i, 1 = ",dump( @{ $marc }), $/ if ($debug > 3);
 666                                 $i--;
 667                         } else {
 668                                 foreach my $j ( 0 .. (( $#{ $marc->[$i] } - 3 ) / 2) ) {
 669                                         my $o = ($j * 2) + 3;
 670                                         if ($marc->[$i]->[$o] eq $sf) {
 671                                                 # remove subfield
 672                                                 splice @{$marc->[$i]}, $o, 2;
 673                                                 warn "#### slice \@{\$marc->[$i]}, $o, 2 = ", dump( @{ $marc }), $/ if ($debug > 3);
 674                                                 # is record now empty?
 675                                                 if ($#{ $marc->[$i] } == 2) {
 676                                                         splice @$marc, $i, 1;
 677                                                         warn "#### slice \@\$marc, $i, 1 = ", dump( @{ $marc }), $/ if ($debug > 3);
 678                                                         $i--;
 679                                                 };
 680                                         }
 681                                 }
 682                         }
 683                 }
 684                 $i++;
 685         }
 686
 687         warn "### marc_remove($f", $sf ? ",$sf" : "", ") after = ", dump( $marc ), $/ if ($debug > 2);
 688
 689         $marc_record->[ $marc_record_offset ] = $marc;
 690
 691         warn "## full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 1);
 692 }
 693
 694 =head2 marc_original_order
 695
 696 Copy all subfields preserving original order to marc field.
 697
 698   marc_original_order( marc_field_number, original_input_field_number );
 699
 700 Please note that field numbers are consistent with other commands (marc
 701 field number first), but somewhat counter-intuitive (destination and then
 702 source).
 703
 704 You might want to use this command if you are just renaming subfields or
 705 using pre-processing modify_record in C<config.yml> and don't need any
 706 post-processing or want to preserve order of original subfields.
 707
 708
 709 =cut
 710
 711 sub marc_original_order {
 712
 713         my ($to, $from) = @_;
 714         die "marc_original_order needs from and to fields\n" unless ($from && $to);
 715
 716         return unless defined($rec->{$from});
 717
 718         my $r = $rec->{$from};
 719         die "record field $from isn't array\n" unless (ref($r) eq 'ARRAY');
 720
 721         my ($i1,$i2) = defined($marc_indicators->{$to}) ? @{ $marc_indicators->{$to} } : (' ',' ');
 722         warn "## marc_original_order($to,$from) source = ", dump( $r ),$/ if ($debug > 1);
 723
 724         foreach my $d (@$r) {
 725
 726                 if (! defined($d->{subfields}) && ref($d->{subfields}) ne 'ARRAY') {
 727                         warn "# marc_original_order($to,$from): field $from doesn't have subfields specification\n";
 728                         next;
 729                 }
 730
 731                 my @sfs = @{ $d->{subfields} };
 732
 733                 die "field $from doesn't have even number of subfields specifications\n" unless($#sfs % 2 == 1);
 734
 735                 warn "#--> d: ",dump($d), "\n#--> sfs: ",dump(@sfs),$/ if ($debug > 2);
 736
 737                 my $m = [ $to, $i1, $i2 ];
 738
 739                 while (my $sf = shift @sfs) {
 740
 741                         warn "#--> sf: ",dump($sf), $/ if ($debug > 2);
 742                         my $offset = shift @sfs;
 743                         die "corrupted sufields specification for field $from\n" unless defined($offset);
 744
 745                         my $v;
 746                         if (ref($d->{$sf}) eq 'ARRAY') {
 747                                 $v = $d->{$sf}->[$offset] if (defined($d->{$sf}->[$offset]));
 748                         } elsif ($offset == 0) {
 749                                 $v = $d->{$sf};
 750                         } else {
 751                                 die "field $from subfield '$sf' need occurence $offset which doesn't exist", dump($d->{$sf});
 752                         }
 753                         push @$m, ( $sf, $v ) if (defined($v));
 754                 }
 755
 756                 if ($#{$m} > 2) {
 757                         push @{ $marc_record->[ $marc_record_offset ] }, $m;
 758                 }
 759         }
 760
 761         warn "## marc_record = ", dump( $marc_record ),$/ if ($debug > 1);
 762 }
 763
 764
 765 =head1 Functions to extract data from input
 766
 767 This function should be used inside functions to create C<data_structure> described
 768 above.
 769
 770 =head2 _pack_subfields_hash
 771
 772  @subfields = _pack_subfields_hash( $h );
 773  $subfields = _pack_subfields_hash( $h, 1 );
 774
 775 Return each subfield value in array or pack them all together and return scalar
 776 with subfields (denoted by C<^>) and values.
 777
 778 =cut
 779
 780 sub _pack_subfields_hash {
 781
 782         warn "## _pack_subfields_hash( ",dump(@_), " )\n" if ($debug > 1);
 783
 784         my ($h,$include_subfields) = @_;
 785
 786         if ( defined($h->{subfields}) ) {
 787                 my $sfs = delete $h->{subfields} || die "no subfields?";
 788                 my @out;
 789                 while (@$sfs) {
 790                         my $sf = shift @$sfs;
 791                         push @out, '^' . $sf if ($include_subfields);
 792                         my $o = shift @$sfs;
 793                         if ($o == 0 && ref( $h->{$sf} ) ne 'ARRAY' ) {
 794                                 # single element subfields are not arrays
 795 #warn "====> $sf $o / $#$sfs ", dump( $sfs, $h->{$sf} ), "\n";
 796
 797                                 push @out, $h->{$sf};
 798                         } else {
 799 #warn "====> $sf $o / $#$sfs ", dump( $sfs, $h->{$sf} ), "\n";
 800                                 push @out, $h->{$sf}->[$o];
 801                         }
 802                 }
 803                 if ($include_subfields) {
 804                         return join('', @out);
 805                 } else {
 806                         return @out;
 807                 }
 808         } else {
 809                 if ($include_subfields) {
 810                         my $out = '';
 811                         foreach my $sf (sort keys %$h) {
 812                                 if (ref($h->{$sf}) eq 'ARRAY') {
 813                                         $out .= '^' . $sf . join('^' . $sf, @{ $h->{$sf} });
 814                                 } else {
 815                                         $out .= '^' . $sf . $h->{$sf};
 816                                 }
 817                         }
 818                         return $out;
 819                 } else {
 820                         # FIXME this should probably be in alphabetical order instead of hash order
 821                         values %{$h};
 822                 }
 823         }
 824 }
 825
 826 =head2 rec1
 827
 828 Return all values in some field
 829
 830   @v = rec1('200')
 831
 832 TODO: order of values is probably same as in source data, need to investigate that
 833
 834 =cut
 835
 836 sub rec1 {
 837         my $f = shift;
 838         warn "rec1($f) = ", dump( $rec->{$f} ), $/ if ($debug > 1);
 839         return unless (defined($rec) && defined($rec->{$f}));
 840         warn "rec1($f) = ", dump( $rec->{$f} ), $/ if ($debug > 1);
 841         if (ref($rec->{$f}) eq 'ARRAY') {
 842                 my @out;
 843                 foreach my $h ( @{ $rec->{$f} } ) {
 844                         if (ref($h) eq 'HASH') {
 845                                 push @out, ( _pack_subfields_hash( $h ) );
 846                         } else {
 847                                 push @out, $h;
 848                         }
 849                 }
 850                 return @out;
 851         } elsif( defined($rec->{$f}) ) {
 852                 return $rec->{$f};
 853         }
 854 }
 855
 856 =head2 rec2
 857
 858 Return all values in specific field and subfield
 859
 860   @v = rec2('200','a')
 861
 862 =cut
 863
 864 sub rec2 {
 865         my $f = shift;
 866         return unless (defined($rec && $rec->{$f}));
 867         my $sf = shift;
 868         warn "rec2($f,$sf) = ", dump( $rec->{$f} ), $/ if ($debug > 1);
 869         return map {
 870                 if (ref($_->{$sf}) eq 'ARRAY') {
 871                         @{ $_->{$sf} };
 872                 } else {
 873                         $_->{$sf};
 874                 }
 875         } grep { ref($_) eq 'HASH' && $_->{$sf} } @{ $rec->{$f} };
 876 }
 877
 878 =head2 rec
 879
 880 syntaxtic sugar for
 881
 882   @v = rec('200')
 883   @v = rec('200','a')
 884
 885 If rec() returns just single value, it will
 886 return scalar, not array.
 887
 888 =cut
 889
 890 sub rec {
 891         my @out;
 892         if ($#_ == 0) {
 893                 @out = rec1(@_);
 894         } elsif ($#_ == 1) {
 895                 @out = rec2(@_);
 896         }
 897         if ($#out == 0 && ! wantarray) {
 898                 return $out[0];
 899         } elsif (@out) {
 900                 return @out;
 901         } else {
 902                 return '';
 903         }
 904 }
 905
 906 =head2 regex
 907
 908 Apply regex to some or all values
 909
 910   @v = regex( 's/foo/bar/g', @v );
 911
 912 =cut
 913
 914 sub regex {
 915         my $r = shift;
 916         my @out;
 917         #warn "r: $r\n", dump(\@_);
 918         foreach my $t (@_) {
 919                 next unless ($t);
 920                 eval "\$t =~ $r";
 921                 push @out, $t if ($t && $t ne '');
 922         }
 923         return @out;
 924 }
 925
 926 =head2 prefix
 927
 928 Prefix all values with a string
 929
 930   @v = prefix( 'my_', @v );
 931
 932 =cut
 933
 934 sub prefix {
 935         my $p = shift or return;
 936         return map { $p . $_ } grep { defined($_) } @_;
 937 }
 938
 939 =head2 suffix
 940
 941 suffix all values with a string
 942
 943   @v = suffix( '_my', @v );
 944
 945 =cut
 946
 947 sub suffix {
 948         my $s = shift or die "suffix needs string as first argument";
 949         return map { $_ . $s } grep { defined($_) } @_;
 950 }
 951
 952 =head2 surround
 953
 954 surround all values with a two strings
 955
 956   @v = surround( 'prefix_', '_suffix', @v );
 957
 958 =cut
 959
 960 sub surround {
 961         my $p = shift or die "surround need prefix as first argument";
 962         my $s = shift or die "surround needs suffix as second argument";
 963         return map { $p . $_ . $s } grep { defined($_) } @_;
 964 }
 965
 966 =head2 first
 967
 968 Return first element
 969
 970   $v = first( @v );
 971
 972 =cut
 973
 974 sub first {
 975         my $r = shift;
 976         return $r;
 977 }
 978
 979 =head2 lookup
 980
 981 Consult lookup hashes for some value
 982
 983   @v = lookup(
 984         sub {
 985                 'ffkk/peri/mfn'.rec('000')
 986         },
 987         'ffkk','peri','200-a-200-e',
 988         sub {
 989                 first(rec(200,'a')).' '.first(rec('200','e'))
 990         }
 991   );
 992
 993 Code like above will be B<automatically generated> using L<WebPAC::Parse> from
 994 normal lookup definition in C<conf/lookup/something.pl> which looks like:
 995
 996   lookup(
 997         # which results to return from record recorded in lookup
 998         sub { 'ffkk/peri/mfn' . rec('000') },
 999         # from which database and input
1000         'ffkk','peri',
1001         # such that following values match
1002         sub { first(rec(200,'a')) . ' ' . first(rec('200','e')) },
1003         # if this part is missing, we will try to match same fields
1004         # from lookup record and current one, or you can override
1005         # which records to use from current record using
1006         sub { rec('900','x') . ' ' . rec('900','y') },
1007   )
1008
1009 You can think about this lookup as SQL (if that helps):
1010
1011   select
1012         sub { what }
1013   from
1014         database, input
1015   where
1016     sub { filter from lookuped record }
1017   having
1018     sub { optional filter on current record }
1019
1020 Easy as pie, right?
1021
1022 =cut
1023
1024 sub lookup {
1025         my ($what, $database, $input, $key, $having) = @_;
1026
1027         confess "lookup needs 5 arguments: what, database, input, key, having\n" unless ($#_ == 4);
1028
1029         warn "## lookup ($database, $input, $key)", $/ if ($debug > 1);
1030         return unless (defined($lookup->{$database}->{$input}->{$key}));
1031
1032         confess "lookup really need load_row_coderef added to data_structure\n" unless ($load_row_coderef);
1033
1034         my $mfns;
1035         my @having = $having->();
1036
1037         warn "## having = ", dump( @having ) if ($debug > 2);
1038
1039         foreach my $h ( @having ) {
1040                 if (defined($lookup->{$database}->{$input}->{$key}->{$h})) {
1041                         warn "lookup for $database/$input/$key/$h return ",dump($lookup->{$database}->{$input}->{$key}->{$h}),"\n" if ($debug);
1042                         $mfns->{$_}++ foreach keys %{ $lookup->{$database}->{$input}->{$key}->{$h} };
1043                 }
1044         }
1045
1046         return unless ($mfns);
1047
1048         my @mfns = sort keys %$mfns;
1049
1050         warn "# lookup loading $database/$input/$key mfn ", join(",",@mfns)," having ",dump(@having),"\n" if ($debug);
1051
1052         my $old_rec = $rec;
1053         my @out;
1054
1055         foreach my $mfn (@mfns) {
1056                 $rec = $load_row_coderef->( $database, $input, $mfn );
1057
1058                 warn "got $database/$input/$mfn = ", dump($rec), $/ if ($debug);
1059
1060                 my @vals = $what->();
1061
1062                 push @out, ( @vals );
1063
1064                 warn "lookup for mfn $mfn returned ", dump(@vals), $/ if ($debug);
1065         }
1066
1067 #       if (ref($lookup->{$k}) eq 'ARRAY') {
1068 #               return @{ $lookup->{$k} };
1069 #       } else {
1070 #               return $lookup->{$k};
1071 #       }
1072
1073         $rec = $old_rec;
1074
1075         warn "## lookup returns = ", dump(@out), $/ if ($debug);
1076
1077         if ($#out == 0) {
1078                 return $out[0];
1079         } else {
1080                 return @out;
1081         }
1082 }
1083
1084 =head2 save_into_lookup
1085
1086 Save value into lookup. It associates current database, input
1087 and specific keys with one or more values which will be
1088 associated over MFN.
1089
1090 MFN will be extracted from first occurence current of field 000
1091 in current record, or if it doesn't exist from L<_set_config> C<_mfn>.
1092
1093   my $nr = save_into_lookup($database,$input,$key,sub {
1094         # code which produce one or more values
1095   });
1096
1097 It returns number of items saved.
1098
1099 This function shouldn't be called directly, it's called from code created by
1100 L<WebPAC::Parser>.
1101
1102 =cut
1103
1104 sub save_into_lookup {
1105         my ($database,$input,$key,$coderef) = @_;
1106         die "save_into_lookup needs database" unless defined($database);
1107         die "save_into_lookup needs input" unless defined($input);
1108         die "save_into_lookup needs key" unless defined($key);
1109         die "save_into_lookup needs CODE" unless ( defined($coderef) && ref($coderef) eq 'CODE' );
1110
1111         warn "## save_into_lookup rec = ", dump($rec), " config = ", dump($config), $/ if ($debug > 2);
1112
1113         my $mfn =
1114                 defined($rec->{'000'}->[0])     ?       $rec->{'000'}->[0]      :
1115                 defined($config->{_mfn})        ?       $config->{_mfn}         :
1116                                                                                 die "mfn not defined or zero";
1117
1118         my $nr = 0;
1119
1120         foreach my $v ( $coderef->() ) {
1121                 $lookup->{$database}->{$input}->{$key}->{$v}->{$mfn}++;
1122                 warn "# saved lookup $database/$input/$key [$v] $mfn\n" if ($debug > 1);
1123                 $nr++;
1124         }
1125
1126         return $nr;
1127 }
1128
1129 =head2 config
1130
1131 Consult config values stored in C<config.yml>
1132
1133   # return database code (key under databases in yaml)
1134   $database_code = config();    # use _ from hash
1135   $database_name = config('name');
1136   $database_input_name = config('input name');
1137   $tag = config('input normalize tag');
1138
1139 Up to three levels are supported.
1140
1141 =cut
1142
1143 sub config {
1144         return unless ($config);
1145
1146         my $p = shift;
1147
1148         $p ||= '';
1149
1150         my $v;
1151
1152         warn "### getting config($p)\n" if ($debug > 1);
1153
1154         my @p = split(/\s+/,$p);
1155         if ($#p < 0) {
1156                 $v = $config->{ '_' };  # special, database code
1157         } else {
1158
1159                 my $c = dclone( $config );
1160
1161                 foreach my $k (@p) {
1162                         warn "### k: $k c = ",dump($c),$/ if ($debug > 1);
1163                         if (ref($c) eq 'ARRAY') {
1164                                 $c = shift @$c;
1165                                 warn "config($p) taking first occurence of '$k', probably not what you wanted!\n";
1166                                 last;
1167                         }
1168
1169                         if (! defined($c->{$k}) ) {
1170                                 $c = undef;
1171                                 last;
1172                         } else {
1173                                 $c = $c->{$k};
1174                         }
1175                 }
1176                 $v = $c if ($c);
1177
1178         }
1179
1180         warn "## config( '$p' ) = ",dump( $v ),$/ if ($v && $debug);
1181         warn "config( '$p' ) is empty\n" if (! $v);
1182
1183         return $v;
1184 }
1185
1186 =head2 id
1187
1188 Returns unique id of this record
1189
1190   $id = id();
1191
1192 Returns C<42/2> for 2nd occurence of MFN 42.
1193
1194 =cut
1195
1196 sub id {
1197         my $mfn = $config->{_mfn} || die "no _mfn in config data";
1198         return $mfn . $#{$marc_record} ? $#{$marc_record} + 1 : '';
1199 }
1200
1201 =head2 join_with
1202
1203 Joins walues with some delimiter
1204
1205   $v = join_with(", ", @v);
1206
1207 =cut
1208
1209 sub join_with {
1210         my $d = shift;
1211         warn "### join_with('$d',",dump(@_),")\n" if ($debug > 2);
1212         my $v = join($d, grep { defined($_) && $_ ne '' } @_);
1213         return '' unless defined($v);
1214         return $v;
1215 }
1216
1217 =head2 split_rec_on
1218
1219 Split record subfield on some regex and take one of parts out
1220
1221   $a_before_semi_column =
1222         split_rec_on('200','a', /\s*;\s*/, $part);
1223
1224 C<$part> is optional number of element. First element is
1225 B<1>, not 0!
1226
1227 If there is no C<$part> parameter or C<$part> is 0, this function will
1228 return all values produced by splitting.
1229
1230 =cut
1231
1232 sub split_rec_on {
1233         die "split_rec_on need (fld,sf,regex[,part]" if ($#_ < 2);
1234
1235         my ($fld, $sf, $regex, $part) = @_;
1236         warn "### regex ", ref($regex), $regex, $/ if ($debug > 2);
1237
1238         my @r = rec( $fld, $sf );
1239         my $v = shift @r;
1240         warn "### first rec($fld,$sf) = ",dump($v),$/ if ($debug > 2);
1241
1242         return '' if ( ! defined($v) || $v =~ /^\s*$/);
1243
1244         my @s = split( $regex, $v );
1245         warn "## split_rec_on($fld,$sf,$regex,$part) = ",dump(@s),$/ if ($debug > 1);
1246         if ($part && $part > 0) {
1247                 return $s[ $part - 1 ];
1248         } else {
1249                 return @s;
1250         }
1251 }
1252
1253 my $hash;
1254
1255 =head2 set
1256
1257   set( key => 'value' );
1258
1259 =cut
1260
1261 sub set {
1262         my ($k,$v) = @_;
1263         warn "## set ( $k => ", dump($v), " )", $/;
1264         $hash->{$k} = $v;
1265 };
1266
1267 =head2 get
1268
1269   get( 'key' );
1270
1271 =cut
1272
1273 sub get {
1274         my $k = shift || return;
1275         my $v = $hash->{$k};
1276         warn "## get $k = ", dump( $v ), $/;
1277         return $v;
1278 }
1279
1280
1281 # END
1282 1;