marc_cleanup

   1 #!/usr/bin/perl
   2 require 5.10.0;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Getopt::Long;
   8 use Term::ReadLine;
   9 use Equinox::Migration::SimpleTagList;
  10
  11 binmode STDOUT, ":utf8";
  12 my $term = new Term::ReadLine 'yaz-cleanup';
  13 my $OUT = $term->OUT || \*STDOUT;
  14
  15 $| = 1;
  16
  17 # initialization and setup
  18 my $conf = {};
  19 initialize($conf);
  20
  21 # set up files, since everything appears to be in order
  22 my $marcfile = shift || 'incoming.marc.xml';
  23 open MARC, '<:utf8', $marcfile
  24   or die "Can't open input file $!\n";
  25 open my $NUMARC, '>:utf8', $conf->{output}
  26   or die "Can't open output file $!\n";
  27 open my $OLD2NEW, '>', 'old2new.map'
  28   if ($conf->{'renumber-from'} and $conf->{'original-subfield'});
  29 my $EXMARC = 'EX';
  30 print $NUMARC "<collection>\n";
  31
  32 $conf->{totalrecs} = `grep -c '<record' $marcfile`;
  33 chomp $conf->{totalrecs};
  34 $conf->{percent}   = 0;
  35
  36 my @record  = (); # current record storage
  37 my %recmeta = (); # metadata about current record
  38 my $ptr  = 0;  # record index pointer
  39
  40 # this is the dispatch table which drives command selection in
  41 # edit(), below
  42 my %commands = ( c => \&print_fullcontext,
  43                  n => \&next_line,
  44                  p => \&prev_line,
  45                  '<' => \&widen_window,
  46                  '>' => \&narrow_window,
  47                  d => \&display_lines,
  48                  o => \&insert_original,
  49                  k => \&kill_line,
  50                  y => \&yank_line,
  51                  f => \&flip_line,
  52                  m => \&merge_lines,
  53                  s => \&substitute,
  54                  t => \&commit_edit,
  55                  x => \&dump_record,
  56                  q => \&quit,
  57                  '?' => \&help,
  58                  h   => \&help,
  59                  help => \&help,
  60                );
  61
  62 my @spinner = qw(- \\ | /);
  63 my $sidx = 0;
  64
  65 while ( buildrecord() ) {
  66     unless ($conf->{ricount} % 50) {
  67         $conf->{percent} = int(($conf->{ricount} / $conf->{totalrecs}) * 100);
  68         print "\rWorking (",$conf->{percent},"%) ", $spinner[$sidx];
  69         $sidx = ($sidx == $#spinner) ? 0 : $sidx + 1;
  70     }
  71
  72     my $rc = do_automated_cleanups();
  73     next if $rc;
  74
  75     $ptr = 0;
  76     until ($ptr == $#record) {
  77         # get datafield/tag data if we have it
  78         my $rc = stow_record_data();
  79         return $rc if $rc;
  80
  81         # naked ampersands
  82         if ($record[$ptr] =~ /&/ && $record[$ptr] !~ /&\w+?;/)
  83           { edit("Naked ampersand"); $ptr= 0; next }
  84
  85         if ($record[$ptr] =~ /<datafield tag="(.+?)"/) {
  86             my $match = $1;
  87             # tags must be numeric
  88             if ($match =~ /\D/) {
  89                 edit("Non-numerics in tag") unless $conf->{autoscrub};
  90                 next;
  91             }
  92             # test for existing 901/903 unless we're autocleaning them
  93             unless ($conf->{'strip9'} or $conf->{'no-strip9'}) {
  94                 if ($match == 901 or $match == 903) {
  95                     edit("Incoming 901/903 found in data");
  96                     next;
  97                 }
  98             }
  99         }
 100
 101         # subfields can't be non-alphanumeric
 102         if ($record[$ptr] =~ /<subfield code="(.*?)"/) {
 103             if ($1 =~ /\P{IsAlnum}/ or $1 eq '') {
 104                 edit("Junk in subfield code/Null subfield code");
 105                 next;
 106             }
 107         }
 108         # subfields can't be non-alphanumeric
 109         if ($record[$ptr] =~ /<subfield code="(\w{2,})"/) {
 110             edit("Subfield code larger than 1 char");
 111             next;
 112         }
 113
 114         $ptr++;
 115     }
 116     write_record($NUMARC);
 117 }
 118 print $NUMARC "</collection>\n";
 119 print $OUT "\nDone.               \n";
 120
 121
 122 #-----------------------------------------------------------------------------------
 123 # cleanup routines
 124 #-----------------------------------------------------------------------------------
 125
 126 sub do_automated_cleanups {
 127     $ptr = 0;
 128     until ($ptr == $#record) {
 129         # catch empty datafield elements
 130         if ($record[$ptr] =~ m/<datafield tag="..."/) {
 131             if ($record[$ptr + 1] =~ m|</datafield>|) {
 132                 my @a = @record[0 .. $ptr - 1];
 133                 my @b = @record[$ptr + 2 .. $#record];
 134                 @record = (@a, @b);
 135                 message("Empty datafield scrubbed");
 136                 $ptr = 0;
 137                 next;
 138             }
 139         }
 140         # and quasi-empty subfields
 141         if ($record[$ptr] =~ m|<subfield code="(.*?)">(.*?)</sub|) {
 142             my $code = $1; my $content = $2;
 143             if ($code =~ /\W/ and ($content =~ /\s+/ or $content eq '')) {
 144                 my @a = @record[0 .. $ptr - 1];
 145                 my @b = @record[$ptr + 1 .. $#record];
 146                 @record = (@a, @b);
 147                 message("Empty subfield scrubbed");
 148                 $ptr = 0;
 149                 next;
 150             }
 151         }
 152         $ptr++;
 153     }
 154
 155     # single-line fixes
 156     for $ptr (0 .. $#record) {
 157         # pad short leaders
 158         if ($record[$ptr] =~ m|<leader>(.+?)</leader>|) {
 159             my $leader = $1;
 160             if (length $leader < 24) {
 161                 $leader .= ' ' x (20 - length($leader));
 162                 $leader .= "4500";
 163                 $record[$ptr] = "<leader>$leader</leader>\n";
 164                 message("Short leader padded");
 165             }
 166         }
 167         if ($record[$ptr] =~ m|<controlfield tag="008">(.+?)</control|) {
 168             #pad short 008
 169             my $content = $1;
 170             if (length $content < 40) {
 171                 $content .= ' ' x (40 - length($content));
 172                 $record[$ptr] = "<controlfield tag=\"008\">$content</controlfield>\n";
 173                 message("Short 008 padded");
 174             }
 175         }
 176
 177         # clean misplaced dollarsigns
 178         if ($record[$ptr] =~ m|<subfield code="\$">c?\d+\.\d{2}|) {
 179             $record[$ptr] =~ s|"\$">c?(\d+\.\d{2})|"c">\$$1|;
 180             message("Dollar sign corrected");
 181         }
 182
 183         # clean up tags with spaces in them
 184         $record[$ptr] =~ s/tag="  /tag="00/g;
 185         $record[$ptr] =~ s/tag=" /tag="0/g;
 186         $record[$ptr] =~ s/tag="-/tag="0/g;
 187         $record[$ptr] =~ s/tag="(\d\d) /tag="0$1/g;
 188
 189         # automatable subfield maladies
 190         $record[$ptr] =~ s/code=" ">c/code="c">/;
 191         $record[$ptr] =~ s/code=" ">\$/code="c">\$/;
 192     }
 193     return 0;
 194 }
 195
 196 sub stow_record_data {
 197     # get tag data if we're looking at it
 198     if ($record[$ptr] =~ m/<datafield tag="(?<TAG>.{3})"/) {
 199         $recmeta{tag} = $+{TAG};
 200         $record[$ptr] =~ m/ind1="(?<IND1>.)"/;
 201         $recmeta{ind1} = $+{IND1} || '';
 202         $record[$ptr] =~ m/ind2="(?<IND2>.)"/;
 203         $recmeta{ind2} = $+{IND2} || '';
 204
 205         unless (defined $recmeta{tag}) {
 206             message("Autokill record: no detectable tag");
 207             dump_record("No detectable tag") ;
 208             return 1;
 209         }
 210
 211         # and since we are looking at a tag, see if it's the original id
 212         if ($conf->{'original-subfield'} and $recmeta{tag} == $conf->{'original-tag'}) {
 213             my $line = $record[$ptr]; my $lptr = $ptr;
 214             my $osub = $conf->{'original-subfield'};
 215             $recmeta{oid} = 'NONE';
 216
 217             until ($line =~ m|</record>|) {
 218                 if ($line =~ /<subfield code="$osub">(.+?)</)
 219                   { $recmeta{oid} = $1 }
 220                 $lptr++;
 221                 $line = $record[$lptr];
 222             }
 223             unless (defined $recmeta{oid}) {
 224                 message("Autokill record: no oldid when old2new mapping requested");
 225                 dump_record("No old id found");
 226                 return 1;
 227             }
 228         }
 229     }
 230     return 0;
 231 }
 232
 233 #-----------------------------------------------------------------------------------
 234 # driver routines
 235 #-----------------------------------------------------------------------------------
 236
 237 =head2 edit
 238
 239 Handles the Term::ReadLine loop
 240
 241 =cut
 242
 243 sub edit {
 244     my ($msg) = @_;
 245
 246     return if $conf->{trash}->has( $recmeta{tag} );
 247     $conf->{editmsg} = $msg;
 248     print_fullcontext();
 249
 250     # stow original problem line
 251     $recmeta{origline} = $record[$ptr];
 252
 253     while (1) {
 254         my $line = $term->readline('marc-cleanup>');
 255         my @chunks = split /\s+/, $line;
 256
 257         # lines with single-character first chunks are commands.
 258         # make sure they exist.
 259         if (length $chunks[0] == 1) {
 260             unless (defined $commands{$chunks[0]}) {
 261                 print $OUT "No such command '", $chunks[0], "'\n";
 262                 next;
 263             }
 264         }
 265
 266         if (defined $commands{$chunks[0]}) {
 267             my $term = $commands{$chunks[0]}->(@chunks[1..$#chunks]);
 268             last if $term;
 269         } else {
 270             $recmeta{prevline} = $record[$ptr];
 271             $record[$ptr] = "$line\n";
 272             print_context();
 273         }
 274     }
 275     # set pointer to top on the way out
 276     $ptr = 0;
 277 }
 278
 279 =head2 buildrecord
 280
 281 Constructs record arrays from the incoming MARC file and returns them
 282 to the driver loop.
 283
 284 =cut
 285
 286 sub buildrecord {
 287     my $l = '';
 288     $l = <MARC> while (defined $l and $l !~ /<record>/);
 289     return $l unless defined $l;
 290     @record = ();
 291     %recmeta = ();
 292     $conf->{ricount}++;
 293
 294     until ($l =~ m|</record>|)
 295       { push @record, $l; $l = <MARC>; }
 296     push @record, $l;
 297     return 1;
 298 }
 299
 300 sub write_record {
 301     my ($FH) = @_;
 302     my $trash = $conf->{trash};
 303
 304     if ($FH eq 'EX') {
 305         $EXMARC = undef;
 306         open $EXMARC, '>:utf8', $conf->{exception}
 307           or die "Can't open exception file $!\n";
 308         $FH = $EXMARC;
 309     }
 310
 311     $conf->{rocount}++ if ($FH eq $NUMARC);
 312     print $FH '<!-- ', $recmeta{explanation}, " -->\n"
 313       if(defined $recmeta{explanation});
 314
 315     # excise unwanted tags
 316     if (defined $trash or $conf->{autoscrub}) {
 317         my @trimmed = ();
 318         my $istrash = 0;
 319         for my $line (@record) {
 320             if ($istrash) {
 321                 $istrash = 0 if $line =~ m|</datafield|;
 322                 next;
 323             }
 324             if ($line =~ m/<datafield tag="(.{3})"/) {
 325                 my $tag = $1;
 326                 if ($trash->has($tag) or ($conf->{autoscrub} and $tag =~ /\D/)) {
 327                     $istrash = 1;
 328                     next
 329                 }
 330             }
 331             push @trimmed, $line;
 332         }
 333         @record = @trimmed;
 334     }
 335
 336     # add 903(?) with new record id
 337     my $renumber = '';
 338     if ($conf->{'renumber-from'}) {
 339         $recmeta{nid} = $conf->{'renumber-from'};
 340         $renumber = join('', ' <datafield tag="', $conf->{'renumber-tag'},
 341                          '" ind1=" " ind2=" "> <subfield code="',
 342                          $conf->{'renumber-subfield'},
 343                          '">', $recmeta{nid}, "</subfield></datafield>\n");
 344         my @tmp = @record[0 .. $#record - 1];
 345         my $last = $record[$#record];
 346         @record = (@tmp, $renumber, $last);
 347         $conf->{'renumber-from'}++;
 348     }
 349
 350     # scrub newlines (unless told not to or writing exception record)
 351     unless ($conf->{nocollapse} or $FH eq $EXMARC)
 352       { s/\n// for (@record) }
 353
 354     # write to old->new map file if needed
 355     if ($conf->{'renumber-from'} and $conf->{'original-subfield'}) {
 356         print $OLD2NEW $recmeta{oid}, "\t", $recmeta{nid}, "\n"
 357     }
 358
 359     # actually write the record
 360     print $FH @record,"\n";
 361
 362     # if we were dumping to exception file, nuke the record and set ptr
 363     # to terminate processing loop
 364     @record = ('a');
 365     $ptr = 0;
 366 }
 367
 368 sub print_fullcontext {
 369     print $OUT "\r", ' ' x 72, "\n";
 370     print $OUT $conf->{editmsg},"\n";
 371     print $OUT "\r    Tag:",$recmeta{tag}, " Ind1:'",
 372       $recmeta{ind1},"' Ind2:'", $recmeta{ind2}, "'";
 373     print $OUT " @ ", $conf->{ricount}, "/", $conf->{rocount} + 1;
 374     print_context();
 375     return 0;
 376 }
 377
 378 sub print_context {
 379     my $upper = int($conf->{window} / 2) + 1;
 380     my $lower = int($conf->{window} / 2) - 1;
 381     my $start = ($ptr - $upper < 0) ? 0 : $ptr - $upper;
 382     my $stop  = ($ptr + $lower > $#record) ? $#record : $ptr + $lower;
 383     print $OUT "\n";
 384     print $OUT '    |', $record[$_] for ($start .. $ptr - 1);
 385     print $OUT '==> |', $record[$ptr];
 386     print $OUT '    |', $record[$_] for ($ptr + 1 .. $stop);
 387     print $OUT "\n";
 388     return 0;
 389 }
 390
 391 sub message {
 392     my ($msg) = @_;
 393     print $OUT "\r$msg at ",$conf->{ricount},"/",$conf->{rocount} + 1,"\n";
 394 }
 395
 396 #-----------------------------------------------------------------------------------
 397 # command routines
 398 #-----------------------------------------------------------------------------------
 399
 400 sub substitute {
 401     my (@chunks) = @_;
 402
 403     my $ofrom = shift @chunks;
 404     if ($ofrom =~ /^'/) {
 405         until ($ofrom =~ /'$/ or !@chunks)
 406           { $ofrom .= join(' ','',shift @chunks) }
 407         $ofrom =~ s/^'//; $ofrom =~ s/'$//;
 408     }
 409     my $to = shift @chunks;
 410     if ($to =~ /^'/) {
 411         until ($to =~ /'$/ or !@chunks)
 412           { $to .= join(' ','',shift @chunks) }
 413         $to =~ s/^'//; $to =~ s/'$//;
 414     }
 415
 416     my $from = '';
 417     for my $char (split(//,$ofrom)) {
 418         $char = "\\" . $char if ($char =~ /\W/);
 419         $from = join('', $from, $char);
 420     }
 421
 422     $recmeta{prevline} = $record[$ptr];
 423     $record[$ptr] =~ s/$from/$to/;
 424     print_context();
 425     return 0;
 426 }
 427
 428 sub merge_lines {
 429     $recmeta{prevline} = $record[$ptr];
 430     # remove <subfield stuff; extract (probably wrong) subfield code
 431     $record[$ptr] =~ s/^\s*<subfield code="(.*?)">//;
 432     # and move to front of line
 433     $record[$ptr] = join(' ', $1 , $record[$ptr]);
 434     # tear off trailing subfield tag from preceeding line
 435     $record[$ptr - 1] =~ s|</subfield>\n||;
 436     # join current line onto preceeding line
 437     $record[$ptr - 1] = join('', $record[$ptr - 1], $record[$ptr]);
 438     # erase current line
 439     my @a = @record[0 .. $ptr - 1];
 440     my @b = @record[$ptr + 1 .. $#record];
 441     @record = (@a, @b);
 442     # move record pointer to previous line
 443     prev_line();
 444     print_context();
 445     return 0;
 446 }
 447
 448 sub flip_line {
 449     unless ($recmeta{prevline})
 450       { print $OUT "No previously edited line to flip\n"; return }
 451     my $temp = $record[$ptr];
 452     $record[$ptr] = $recmeta{prevline};
 453     $recmeta{prevline} = $temp;
 454     print_context();
 455     return 0;
 456 }
 457
 458 sub kill_line {
 459     $recmeta{killline} = $record[$ptr];
 460     my @a = @record[0 .. $ptr - 1];
 461     my @b = @record[$ptr + 1 .. $#record];
 462     @record = (@a, @b);
 463     print_context();
 464     return 0;
 465 }
 466
 467 sub yank_line {
 468     unless ($recmeta{killline})
 469       { print $OUT "No killed line to yank\n"; return }
 470     my @a = @record[0 .. $ptr - 1];
 471     my @b = @record[$ptr .. $#record];
 472     @record = (@a, $conf->{killline}, @b);
 473     print_context();
 474     return 0;
 475 }
 476
 477 sub insert_original {
 478     $record[$ptr] = $recmeta{origline};
 479     print_context();
 480     return 0;
 481 }
 482
 483 sub display_lines {
 484     print $OUT "\nOrig. edit line  :", $recmeta{origline};
 485     print $OUT "Current flip line:", $recmeta{prevline} if $recmeta{prevline};
 486     print $OUT "Last killed line :", $recmeta{killline} if $recmeta{killline};
 487     print $OUT "\n";
 488     return 0;
 489 }
 490
 491 sub dump_record {
 492     my (@explanation) = @_;
 493     print $OUT @explanation;
 494     $recmeta{explanation} = join(' ', 'Tag', $recmeta{tag}, @explanation);
 495     write_record($EXMARC);
 496     return 1;
 497 }
 498
 499 sub next_line {
 500     $ptr++ unless ($ptr == $#record);;
 501     print_context();
 502     return 0;
 503 }
 504
 505 sub prev_line {
 506     $ptr-- unless ($ptr == 0);
 507     print_context();
 508     return 0;
 509 }
 510
 511 sub commit_edit { return 1 }
 512
 513 sub widen_window {
 514     if ($conf->{window} == 15)
 515       { print $OUT "Window can't be bigger than 15 lines\n"; return }
 516     $conf->{window} += 2;
 517     print_context;
 518 }
 519
 520 sub narrow_window {
 521     if ($conf->{window} == 5)
 522       { print $OUT "Window can't be smaller than 5 lines\n"; return }
 523     $conf->{window} -= 2;
 524     print_context;
 525 }
 526
 527 sub help {
 528 print $OUT <<HELP;
 529 Type a replacement for the indicated line, or enter a command.
 530
 531 DISPLAY COMMANDS             | LINE AUTO-EDIT COMMANDS
 532 <  Expand context window     | k  Kill current line
 533 >  Contract context window   | y  Yank last killed line
 534 p  Move pointer to prev line | m  Merge current line into preceding line
 535 n  Move pointer to next line | o  Insert original line
 536 c  Print line context        | f  Flip current line and last edited line
 537 d  Print current saved lines |
 538 -----------------------------+-------------------------------------------
 539 s  Subtitute; replace ARG1 in current line with ARG2. If either ARG
 540    contains spaces, it must be single-quoted
 541 t  Commit changes and resume automated operations
 542 x  Dump record to exception file
 543 q  Quit
 544
 545 HELP
 546 return 0;
 547 }
 548
 549 sub quit { exit }
 550
 551 #-----------------------------------------------------------------------
 552
 553 =head2 initialize
 554
 555 Performs boring script initialization. Handles argument parsing,
 556 mostly.
 557
 558 =cut
 559
 560 sub initialize {
 561     my ($c) = @_;
 562     my @missing = ();
 563
 564     # set mode on existing filehandles
 565     binmode(STDIN, ':utf8');
 566
 567     my $rc = GetOptions( $c,
 568                          'autoscrub|a',
 569                          'exception|x=s',
 570                          'output|o=s',
 571                          'prefix|p=s',
 572                          'nocollapse|n',
 573                          'renumber-from|rf=i',
 574                          'renumber-tag|rt=i',
 575                          'renumber-subfield|rs=s',
 576                          'original-tag|ot=i',
 577                          'original-subfield|os=s',
 578                          'script',
 579                          'strip9',
 580                          'no-strip9',
 581                          'trashfile|t=s',
 582                          'trashhelp',
 583                          'help|h',
 584                        );
 585     show_help() unless $rc;
 586     show_help() if ($c->{help});
 587     show_trashhelp() if ($c->{trashhelp});
 588
 589     # defaults
 590     my $pfx = $c->{prefix} // "bibs";
 591     $c->{output} = join('.',$c->{prefix},'clean','marc','xml');
 592     $c->{exception} = join('.',$c->{prefix},'exception','marc','xml');
 593     $c->{'renumber-tag'} = 903 unless defined $c->{'renumber-tag'};
 594     $c->{'renumber-subfield'} = 'a' unless defined $c->{'renumber-subfield'};
 595     $c->{window} = 5;
 596
 597     if ($c->{trashfile}) {
 598         $c->{trash} = Equinox::Migration::SimpleTagList->new($conf->{trashfile})
 599     } else {
 600         $c->{trash} = Equinox::Migration::SimpleTagList->new;
 601     }
 602     # remove original id sequence tag from trash hash if we know it
 603     $c->{trash}->remove_tag($c->{'original-tag'})
 604       if ( $c->{'original-tag'} and $c->{trash}->has($c->{'original-tag'}) );
 605
 606     # autotrash 901, 903 if strip-nines
 607     if ($c->{'strip9'}) {
 608         $c->{trash}->add_tag(901);
 609         $c->{trash}->add_tag(903);
 610     }
 611
 612     my @keys = keys %{$c};
 613     show_help() unless (@ARGV and @keys);
 614 }
 615
 616 sub show_help {
 617     print <<HELP;
 618 Usage is: marc-cleanup [OPTIONS] <filelist>
 619 Options
 620   --output     -o  Cleaned MARCXML output filename
 621   --exception  -x  Exception (dumped records) MARCXML filename
 622        or
 623   --prefix=<PREFIX>>   -p  Shared prefix for output/exception files. Will produce
 624                            PREFIX.clean.marc.xml and PREFIX.exception.marc.xml
 625
 626   --renumber-from     -rf  Begin renumbering id sequence with this number
 627   --renumber-tag      -rt  Tag to use in renumbering (default: 903)
 628   --renumber-subfield -rs  Subfield code to use in renumbering (default: a)
 629   --original-tag      -ot  Original id tag; will be kept in output even if
 630                            it appears in the trash file
 631   --original-subfield -os  Original id subfield code. If this is specified
 632                            and renumbering is in effect, an old-to-new mapping
 633                            file (old2new.map) will be generated.
 634
 635   --autoscrub  -a  Automatically remove non-numeric tags in data
 636   --nocollapse -n  Don't compress records to one line on output
 637   --strip9         Automatically remove any existing 901/903 tags in data
 638   --no-strip9      Don't complain about 901/903 tags in data
 639   --trashfile  -t  File containing trash tag data (see --trashhelp)
 640
 641
 642   --script         Store human-initiated ops in scriptfile (.mcscript)
 643                    Not yet implemented
 644 HELP
 645 exit;
 646 }
 647
 648 sub show_trashhelp {
 649     print <<HELP;
 650 See
 651
 652 http://intra.lan.hq.esilibrary.com/dokuwiki/doku.php?id=migration:tag_files
 653
 654 for tag file syntax information.
 655 HELP
 656 exit;
 657 }