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