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