marc-cleanup

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