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