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