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