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