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 xmlns=\"http://www.loc.gov/MARC21/slim\">\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         }
  94
  95         # subfields can't be non-alphanumeric
  96         if ($record[$ptr] =~ /<subfield code="(.*?)"/) {
  97             if ($1 =~ /\P{IsAlnum}/ or $1 eq '') {
  98                 edit("Junk in subfield code/Null subfield code");
  99                 next;
 100             }
 101         }
 102         # subfields can't be non-alphanumeric
 103         if ($record[$ptr] =~ /<subfield code="(\w{2,})"/) {
 104             edit("Subfield code larger than 1 char");
 105             next;
 106         }
 107
 108         $ptr++;
 109     }
 110     write_record($NUMARC);
 111 }
 112 print $NUMARC "</collection>\n";
 113 print $OUT "\nDone. ",$conf->{ricount}," in / ",$conf->{rocount}," out          \n";
 114
 115
 116 #-----------------------------------------------------------------------------------
 117 # cleanup routines
 118 #-----------------------------------------------------------------------------------
 119
 120 sub do_automated_cleanups {
 121     $ptr = 0;
 122     until ($ptr == $#record) {
 123
 124         # catch empty datafield elements
 125         if ($record[$ptr] =~ m/<datafield tag="..."/) {
 126             if ($record[$ptr + 1] =~ m|</datafield>|) {
 127                 my @a = @record[0 .. $ptr - 1];
 128                 my @b = @record[$ptr + 2 .. $#record];
 129                 @record = (@a, @b);
 130                 @a = undef; @b = undef;
 131                 message("Empty datafield scrubbed");
 132                 $ptr = 0;
 133                 next;
 134             }
 135         }
 136         # and quasi-empty subfields
 137         if ($record[$ptr] =~ m|<subfield code="(.*?)">(.*?)</sub|) {
 138             my $code = $1; my $content = $2;
 139             if ($code =~ /\W/ and ($content =~ /\s+/ or $content eq '')) {
 140                 my @a = @record[0 .. $ptr - 1];
 141                 my @b = @record[$ptr + 1 .. $#record];
 142                 @record = (@a, @b);
 143                 @a = undef; @b = undef;
 144                 message("Empty subfield scrubbed");
 145                 $ptr = 0;
 146                 next;
 147             }
 148         }
 149         $ptr++;
 150     }
 151
 152     # single-line fixes
 153     for $ptr (0 .. $#record) {
 154         # pad short leaders
 155         if ($record[$ptr] =~ m|<leader>(.+?)</leader>|) {
 156             my $leader = $1;
 157             if (length $leader < 24) {
 158                 $leader .= ' ' x (20 - length($leader));
 159                 $leader .= "4500";
 160                 $record[$ptr] = "<leader>$leader</leader>\n";
 161                 message("Short leader padded");
 162             }
 163         }
 164         if ($record[$ptr] =~ m|<controlfield tag="008">(.+?)</control|) {
 165             #pad short 008
 166             my $content = $1;
 167             if (length $content < 40) {
 168                 $content .= ' ' x (40 - length($content));
 169                 $record[$ptr] = "<controlfield tag=\"008\">$content</controlfield>\n";
 170                 message("Short 008 padded");
 171             }
 172         }
 173
 174         # clean misplaced dollarsigns
 175         if ($record[$ptr] =~ m|<subfield code="\$">c?\d+\.\d{2}|) {
 176             $record[$ptr] =~ s|"\$">c?(\d+\.\d{2})|"c">\$$1|;
 177             message("Dollar sign corrected");
 178         }
 179
 180         # automatable subfield maladies
 181         $record[$ptr] =~ s/code=" ">c/code="c">/;
 182         $record[$ptr] =~ s/code=" ">\$/code="c">\$/;
 183     }
 184     return 0;
 185 }
 186
 187 sub stow_record_data {
 188     # get tag data if we're looking at it
 189     if ($record[$ptr] =~ m/<datafield tag="(?<TAG>.{3})"/) {
 190         $recmeta{tag} = $+{TAG};
 191         $record[$ptr] =~ m/ind1="(?<IND1>.)"/;
 192         $recmeta{ind1} = $+{IND1} || '';
 193         $record[$ptr] =~ m/ind2="(?<IND2>.)"/;
 194         $recmeta{ind2} = $+{IND2} || '';
 195
 196         unless (defined $recmeta{tag}) {
 197             message("Autokill record: no detectable tag");
 198             dump_record("No detectable tag") ;
 199             return 1;
 200         }
 201
 202         # and since we are looking at a tag, see if it's the original id
 203         if ($conf->{'original-subfield'} and $recmeta{tag} == $conf->{'original-tag'}) {
 204             my $line = $record[$ptr]; my $lptr = $ptr;
 205             my $osub = $conf->{'original-subfield'};
 206             $recmeta{oid} = 'NONE';
 207
 208             # skim to end of this tag
 209             until ($line =~ m|</datafield>|) {
 210                 if ($line =~ /<subfield code="$osub">(.+?)</)
 211                   { $recmeta{oid} = $1 }
 212                 $lptr++;
 213                 $line = $record[$lptr];
 214             }
 215             unless (defined $recmeta{oid}) {
 216                 message("Autokill record: no oldid when old2new mapping requested");
 217                 dump_record("No old id found");
 218                 return 1;
 219             }
 220         }
 221     }
 222     return 0;
 223 }
 224
 225 #-----------------------------------------------------------------------------------
 226 # driver routines
 227 #-----------------------------------------------------------------------------------
 228
 229 =head2 edit
 230
 231 Handles the Term::ReadLine loop
 232
 233 =cut
 234
 235 sub edit {
 236     my ($msg) = @_;
 237
 238     return if $conf->{trash}->has( $recmeta{tag} );
 239     $conf->{editmsg} = $msg;
 240     print_fullcontext();
 241
 242     # stow original problem line
 243     $recmeta{origline} = $record[$ptr];
 244
 245     while (1) {
 246         my $line = $term->readline('marc-cleanup>');
 247         my @chunks = split /\s+/, $line;
 248
 249         # lines with single-character first chunks are commands.
 250         # make sure they exist.
 251         if (length $chunks[0] == 1) {
 252             unless (defined $commands{$chunks[0]}) {
 253                 print $OUT "No such command '", $chunks[0], "'\n";
 254                 next;
 255             }
 256         }
 257
 258         if (defined $commands{$chunks[0]}) {
 259             my $term = $commands{$chunks[0]}->(@chunks[1..$#chunks]);
 260             last if $term;
 261         } else {
 262             $recmeta{prevline} = $record[$ptr];
 263             $record[$ptr] = "$line\n";
 264             print_context();
 265         }
 266     }
 267     # set pointer to top on the way out
 268     $ptr = 0;
 269 }
 270
 271 =head2 buildrecord
 272
 273 Constructs record arrays from the incoming MARC file and returns them
 274 to the driver loop.
 275
 276 =cut
 277
 278 sub buildrecord {
 279     my $l = '';
 280     my $istrash = 0;
 281     my $trash = $conf->{trash};
 282
 283     $l = <MARC> while (defined $l and $l !~ /<record>/);
 284     return $l unless defined $l;
 285     $conf->{ricount}++;
 286
 287     for (keys %recmeta) { $recmeta{$_} = undef }
 288     for (0 .. @record)  { delete $record[$_] }
 289
 290     my $i = 0;
 291     until ($l =~ m|</record>|) {
 292         # clean up tags with spaces in them
 293         $l =~ s/tag="  /tag="00/g;
 294         $l =~ s/tag=" /tag="0/g;
 295         $l =~ s/tag="-/tag="0/g;
 296         $l =~ s/tag="(\d\d) /tag="0$1/g;
 297
 298         # excise unwanted tags
 299         if ($istrash) {
 300             $istrash = 0 if ($l =~ m|</datafield|);
 301             $l = <MARC>;
 302             next;
 303         }
 304         if ($l =~ m/<datafield tag="(.{3})"/) {
 305             if ($trash->has($1) or ($conf->{autoscrub} and $1 =~ /\D/))
 306               { $istrash = 1; next }
 307         }
 308
 309         $record[$i] = $l;
 310         $l = <MARC>;
 311         $i++;
 312     }
 313     $record[$i] = $l;
 314     return 1;
 315 }
 316
 317 sub write_record {
 318     my ($FH) = @_;
 319
 320     if ($FH eq 'EX') {
 321         $EXMARC = undef;
 322         open $EXMARC, '>:utf8', $conf->{exception}
 323           or die "Can't open exception file $!\n";
 324         $FH = $EXMARC;
 325     }
 326
 327     $conf->{rocount}++ if ($FH eq $NUMARC);
 328     print $FH '<!-- ', $recmeta{explanation}, " -->\n"
 329       if(defined $recmeta{explanation});
 330
 331     # add 903(?) with new record id
 332     my $renumber = '';
 333     if ($conf->{'renumber-from'}) {
 334         $recmeta{nid} = $conf->{'renumber-from'};
 335         $renumber = join('', ' <datafield tag="', $conf->{'renumber-tag'},
 336                          '" ind1=" " ind2=" "> <subfield code="',
 337                          $conf->{'renumber-subfield'},
 338                          '">', $recmeta{nid}, "</subfield></datafield>\n");
 339         my @tmp = @record[0 .. @record - 2];
 340         my $last = $record[-1];
 341         @record = undef;
 342         @record = (@tmp, $renumber, $last);
 343         @tmp = undef; $last = undef;
 344         $conf->{'renumber-from'}++;
 345     }
 346
 347     # scrub newlines (unless told not to or writing exception record)
 348     unless ($conf->{nocollapse} or $FH eq $EXMARC)
 349       { s/\n// for (@record) }
 350
 351     # write to old->new map file if needed
 352     if ($conf->{'renumber-from'} and $conf->{'original-subfield'}) {
 353         print $OLD2NEW $recmeta{oid}, "\t", $recmeta{nid}, "\n"
 354     }
 355
 356     # actually write the record
 357     print $FH @record,"\n";
 358
 359     # if we were dumping to exception file, nuke the record and set ptr
 360     # to terminate processing loop
 361     @record = ('a');
 362     $ptr = 0;
 363 }
 364
 365 sub print_fullcontext {
 366     print $OUT "\r", ' ' x 72, "\n";
 367     print $OUT $conf->{editmsg},"\n";
 368     print $OUT "\r    Tag:",$recmeta{tag}, " Ind1:'",
 369       $recmeta{ind1},"' Ind2:'", $recmeta{ind2}, "'";
 370     print $OUT " @ ", $conf->{ricount}, "/", $conf->{rocount} + 1;
 371     print_context();
 372     return 0;
 373 }
 374
 375 sub print_context {
 376     my $upper = int($conf->{window} / 2) + 1;
 377     my $lower = int($conf->{window} / 2) - 1;
 378     my $start = ($ptr - $upper < 0) ? 0 : $ptr - $upper;
 379     my $stop  = ($ptr + $lower > $#record) ? $#record : $ptr + $lower;
 380     print $OUT "\n";
 381     print $OUT '    |', $record[$_] for ($start .. $ptr - 1);
 382     print $OUT '==> |', $record[$ptr];
 383     print $OUT '    |', $record[$_] for ($ptr + 1 .. $stop);
 384     print $OUT "\n";
 385     return 0;
 386 }
 387
 388 sub message {
 389     my ($msg) = @_;
 390     print $OUT "\r$msg at ",$conf->{ricount},"/",$conf->{rocount} + 1,"\n";
 391 }
 392
 393 #-----------------------------------------------------------------------------------
 394 # command routines
 395 #-----------------------------------------------------------------------------------
 396
 397 sub substitute {
 398     my (@chunks) = @_;
 399
 400     my $ofrom = shift @chunks;
 401     if ($ofrom =~ /^'/) {
 402         until ($ofrom =~ /'$/ or !@chunks)
 403           { $ofrom .= join(' ','',shift @chunks) }
 404         $ofrom =~ s/^'//; $ofrom =~ s/'$//;
 405     }
 406     my $to = shift @chunks;
 407     if ($to =~ /^'/) {
 408         until ($to =~ /'$/ or !@chunks)
 409           { $to .= join(' ','',shift @chunks) }
 410         $to =~ s/^'//; $to =~ s/'$//;
 411     }
 412
 413     my $from = '';
 414     for my $char (split(//,$ofrom)) {
 415         $char = "\\" . $char if ($char =~ /\W/);
 416         $from = join('', $from, $char);
 417     }
 418
 419     $recmeta{prevline} = $record[$ptr];
 420     $record[$ptr] =~ s/$from/$to/;
 421     $ofrom = undef; $to = undef; $from = undef;
 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     $temp = undef;
 453     print_context();
 454     return 0;
 455 }
 456
 457 sub kill_line {
 458     $recmeta{killline} = $record[$ptr];
 459     my @a = @record[0 .. $ptr - 1];
 460     my @b = @record[$ptr + 1 .. $#record];
 461     @record = (@a, @b);
 462     @a = undef; @b = undef;
 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     @a = undef; @b = undef;
 474     print_context();
 475     return 0;
 476 }
 477
 478 sub insert_original {
 479     $record[$ptr] = $recmeta{origline};
 480     print_context();
 481     return 0;
 482 }
 483
 484 sub display_lines {
 485     print $OUT "\nOrig. edit line  :", $recmeta{origline};
 486     print $OUT "Current flip line:", $recmeta{prevline} if $recmeta{prevline};
 487     print $OUT "Last killed line :", $recmeta{killline} if $recmeta{killline};
 488     print $OUT "\n";
 489     return 0;
 490 }
 491
 492 sub dump_record {
 493     my (@explanation) = @_;
 494     print $OUT @explanation;
 495     $recmeta{explanation} = join(' ', 'Tag', $recmeta{tag}, @explanation);
 496     @explanation = undef;
 497     write_record($EXMARC);
 498     return 1;
 499 }
 500
 501 sub next_line {
 502     $ptr++ unless ($ptr == $#record);;
 503     print_context();
 504     return 0;
 505 }
 506
 507 sub prev_line {
 508     $ptr-- unless ($ptr == 0);
 509     print_context();
 510     return 0;
 511 }
 512
 513 sub commit_edit { return 1 }
 514
 515 sub widen_window {
 516     if ($conf->{window} == 15)
 517       { print $OUT "Window can't be bigger than 15 lines\n"; return }
 518     $conf->{window} += 2;
 519     print_context;
 520 }
 521
 522 sub narrow_window {
 523     if ($conf->{window} == 5)
 524       { print $OUT "Window can't be smaller than 5 lines\n"; return }
 525     $conf->{window} -= 2;
 526     print_context;
 527 }
 528
 529 sub help {
 530 print $OUT <<HELP;
 531 Type a replacement for the indicated line, or enter a command.
 532
 533 DISPLAY COMMANDS             | LINE AUTO-EDIT COMMANDS
 534 <  Expand context window     | k  Kill current line
 535 >  Contract context window   | y  Yank last killed line
 536 p  Move pointer to prev line | m  Merge current line into preceding line
 537 n  Move pointer to next line | o  Insert original line
 538 c  Print line context        | f  Flip current line and last edited line
 539 d  Print current saved lines |
 540 -----------------------------+-------------------------------------------
 541 s  Subtitute; replace ARG1 in current line with ARG2. If either ARG
 542    contains spaces, it must be single-quoted
 543 t  Commit changes and resume automated operations
 544 x  Dump record to exception file
 545 q  Quit
 546
 547 HELP
 548 return 0;
 549 }
 550
 551 sub quit { exit }
 552
 553 #-----------------------------------------------------------------------
 554
 555 =head2 initialize
 556
 557 Performs boring script initialization. Handles argument parsing,
 558 mostly.
 559
 560 =cut
 561
 562 sub initialize {
 563     my ($c) = @_;
 564     my @missing = ();
 565
 566     # set mode on existing filehandles
 567     binmode(STDIN, ':utf8');
 568
 569     my $rc = GetOptions( $c,
 570                          'autoscrub|a',
 571                          'exception|x=s',
 572                          'output|o=s',
 573                          'prefix|p=s',
 574                          'nocollapse|n',
 575                          'renumber-from|rf=i',
 576                          'renumber-tag|rt=i',
 577                          'renumber-subfield|rs=s',
 578                          'original-tag|ot=i',
 579                          'original-subfield|os=s',
 580                          'script',
 581                          'no-strip9',
 582                          'trashfile|t=s',
 583                          'trashhelp',
 584                          'help|h',
 585                        );
 586     show_help() unless $rc and @ARGV;
 587     show_help() if ($c->{help});
 588     show_trashhelp() if ($c->{trashhelp});
 589
 590     # defaults
 591     my $pfx = $c->{prefix} // "bibs";
 592     $c->{output} = join('.',$c->{prefix},'clean','marc','xml');
 593     $c->{exception} = join('.',$c->{prefix},'exception','marc','xml');
 594     $c->{'renumber-tag'} = 903 unless defined $c->{'renumber-tag'};
 595     $c->{'renumber-subfield'} = 'a' unless defined $c->{'renumber-subfield'};
 596     $c->{window} = 5;
 597
 598     if ($c->{trashfile}) {
 599         $c->{trash} = Equinox::Migration::SimpleTagList->new(file => $conf->{trashfile})
 600     } else {
 601         $c->{trash} = Equinox::Migration::SimpleTagList->new;
 602     }
 603     # autotrash 901, 903 unless no strip-nines
 604     unless ($c->{'no-strip9'}) {
 605         $c->{trash}->add_tag(901);
 606         $c->{trash}->add_tag(903);
 607     }
 608     # remove original id sequence tag from trash hash if we know it
 609     $c->{trash}->remove_tag($c->{'original-tag'})
 610       if ( $c->{'original-tag'} and $c->{trash}->has($c->{'original-tag'}) );
 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   --no-strip9      Don't autoremove 901/903 tags in data
 638   --trashfile  -t  File containing trash tag data (see --trashhelp)
 639
 640
 641   --script         Store human-initiated ops in scriptfile (.mcscript)
 642                    Not yet implemented
 643 HELP
 644 exit;
 645 }
 646
 647 sub show_trashhelp {
 648     print <<HELP;
 649 See
 650
 651 http://intra.lan.hq.esilibrary.com/dokuwiki/doku.php?id=migration:tag_files
 652
 653 for tag file syntax information.
 654 HELP
 655 exit;
 656 }