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