marc-cleanup

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Getopt::Long;
   7 use Term::ReadLine;
   8
   9 $| = 1;
  10
  11 my $term = new Term::ReadLine 'yaz-cleanup';
  12 my $OUT = $term->OUT || \*STDOUT;
  13
  14 my $count = 0;
  15 my $reccount = 0;
  16 my $oreccount = 0;
  17 my $line = '';
  18 my %trash = ();   # hash for tags to be dumped
  19
  20 # read in trash tags file if it exists
  21 populate_trash() if (-e '.trashtags');
  22
  23 my @record = ();  # current record storage
  24 my %recmeta = (); # metadata about current record
  25 my @context= ();  # last 5 lines of file
  26
  27 my $input = shift || 'incoming.marc.xml';
  28
  29 open MARC, '<', $input;
  30 open my $NUMARC, '>', 'incoming.clean.marc.xml';
  31 print $NUMARC '<?xml version="1.0" encoding="UTF-8"?>',"\n";
  32 print $NUMARC '<collection xmlns="http://www.loc.gov/MARC21/slim">',"\n";
  33
  34 open my $EXMARC, '>', 'incoming.exceptions.marc.xml';
  35 print $EXMARC '<?xml version="1.0" encoding="UTF-8"?>',"\n";
  36 print $EXMARC '<collection xmlns="http://www.loc.gov/MARC21/slim">',"\n";
  37 open MARC2, '<', $input;
  38 <MARC2>;
  39
  40 # this is the dispatch table which drives command selection in
  41 # edit(), below
  42 my %commands = ( c => \&print_context,
  43                  C => \&print_linecontext,
  44                  k => \&kill_line,
  45                  o => \&show_original,
  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 (my $line = getline()) {
  60     unless ($count % 2000) {
  61         print "\rWorking... ", $spinner[$sidx];
  62         $sidx = ($sidx == $#spinner) ? 0 : $sidx + 1;
  63     }
  64     update_linecontext();
  65
  66     next if ($line =~ m|</record>|);
  67
  68     # catch empty datafield elements
  69     if ($line =~ m|</datafield>|) {
  70         if ($record[-2] =~ m/<datafield tag="..." ind1="." ind2=".">/) {
  71             pop @record; pop @record;
  72             message("Empty datafield scrubbed");
  73             next;
  74         }
  75     }
  76
  77     # pad short leaders
  78     if ($line =~ m|<leader>(.+?)</leader>|) {
  79         my $leader = $1;
  80         if (length $leader < 24) {
  81             $leader .= ' ' x (20 - length($leader));
  82             $leader .= "4500";
  83             $line = "<leader>$leader</leader>\n";
  84             message("Short leader padded");
  85         }
  86     }
  87
  88     # clean misplaced dollarsigns
  89     if ($line =~ m|<subfield code="\$">c?\d+\.\d{2}|) {
  90         $line =~ s|"\$">c?(\d+\.\d{2})|"c">\$$1|;
  91         message("Dollar sign corrected");
  92     }
  93
  94     # clean up tags with spaces in them
  95     $line =~ s/tag="  /tag="00/g;
  96     $line =~ s/tag=" /tag="0/g;
  97     $line =~ s/tag="-/tag="0/g;
  98     $line =~ s/tag="(\d\d) /tag="0$1/g;
  99
 100     # stow tag data if we're looking at it
 101     if ($line =~ m/<datafield tag="(.{3})" ind1="(.)" ind2="(.)">/) {
 102         $recmeta{tag}  = $1;
 103         $recmeta{ind1} = $2;
 104         $recmeta{ind2} = $3;
 105     }
 106
 107     # and stow line back in record
 108     $record[-1] = $line;
 109
 110     # naked ampersands
 111     if ($line =~ /&/ && $line !~ /&\w+?;/)
 112       { edit("Naked ampersand", $line); next }
 113
 114     # tags must be numeric
 115     if ($line =~ /<datafield tag="(.+?)"/) {
 116         my $match = $1;
 117         if ($match =~ /\D/) {
 118             edit("Non-numerics in tag", $line);
 119             next;
 120         }
 121     }
 122
 123     # subfields can't be non-alphanumeric
 124     if ($line =~ /<subfield code="(.+?)"/) {
 125         my $match = $1;
 126         if ($match =~ /\P{IsAlnum}/) {
 127             edit("Junk in subfield code", $line);
 128             next;
 129         }
 130     }
 131
 132 }
 133 print $NUMARC "</collection>\n";
 134 print $EXMARC "</collection>\n";
 135 print $OUT "\nDone.               \n";
 136
 137 =head2 edit
 138
 139 Handles the Term::ReadLine loop
 140
 141 =cut
 142
 143 sub edit {
 144     my ($msg, $line_in) = @_;
 145     return if $trash{$recmeta{tag}};
 146     message($msg);
 147     print_context();
 148
 149     while (1) {
 150         my $line = $term->readline('marc-cleanup>');
 151         my @chunks = split /\s+/, $line;
 152
 153         if (length $chunks[0] == 1)
 154           { next unless (defined $commands{$chunks[0]}) }
 155
 156         if (defined $commands{$chunks[0]}) {
 157             my $term = $commands{$chunks[0]}->($line_in, @chunks[1..$#chunks]);
 158             last if $term;
 159         } else {
 160             if ($context[3] eq " [LINE KILLED]\n") {
 161                 push @record, "$line\n"
 162             } else {
 163                 $record[-1] = "$line\n";
 164             }
 165             $context[3] = "$line\n";
 166             print_linecontext();
 167         }
 168     }
 169 }
 170
 171 =head2 getline
 172
 173 Reads from the incoming MARC file; returns lines into the driver
 174 loop. Batches records for output, and maintains the context listing.
 175
 176 =cut
 177
 178 sub getline {
 179     my $l = <MARC>;
 180     $count++;
 181     if (defined $l) {
 182         if ($l =~ /<record>/) {
 183             @record = ($l);
 184             %recmeta = ();
 185             $reccount++;
 186         } elsif ($l =~ m|</record>|) {
 187             write_record($NUMARC) if $reccount;
 188         } else {
 189             push @record, $l;
 190         }
 191     }
 192     return $l;
 193 }
 194
 195 sub write_record {
 196     my ($FH) = @_;
 197     $oreccount++ if ($FH eq $NUMARC);
 198     print $FH '<!-- ', $recmeta{explanation}, " -->\n"
 199       if(defined $recmeta{explanation});
 200
 201     # LOOP OVER %trash TO EXCISE UNWANTED TAGS1
 202     if (keys %trash) {
 203         my @trimmed = ();
 204         my $istrash = 0;
 205         for my $line (@record) {
 206             if ($istrash) {
 207                 $istrash = 0 if $line =~ m|</datafield|;
 208                 next;
 209             }
 210             if ($line =~ m/<datafield tag="(.{3})"/) {
 211                 my $tag = $1;
 212                 if ($trash{$tag} or $tag =~ /\D/) {
 213                     $istrash = 1;
 214                     next
 215                 }
 216             }
 217             push @trimmed, $line;
 218         }
 219         @record = @trimmed;
 220     }
 221     print $FH @record;
 222     print $FH '</record>\n';
 223 }
 224
 225 sub update_linecontext {
 226     my $line2 = <MARC2>;
 227     push @context, $line2;
 228     shift @context if (@context > 5);
 229 }
 230
 231 sub message {
 232     my ($msg) = @_;
 233     print $OUT "\r$msg at record $reccount/",$oreccount + 1,"\n";
 234
 235 }
 236
 237 #-----------------------------------------------------------------------------------
 238 # command routines
 239 #-----------------------------------------------------------------------------------
 240
 241 sub substitute {
 242     my ($line_in, @chunks) = @_;
 243     my $ofrom = shift @chunks;
 244     if ($ofrom =~ /^'/ or !@chunks) {
 245         until ($ofrom =~ /'$/)
 246           { $ofrom .= join(' ','',shift @chunks) }
 247         $ofrom =~ s/^'//; $ofrom =~ s/'$//;
 248     }
 249     my $to = shift @chunks;
 250     if ($to =~ /^'/) {
 251         until ($to =~ /'$/ or !@chunks)
 252           { $to .= join(' ','',shift @chunks) }
 253         $to =~ s/^'//; $to =~ s/'$//;
 254     }
 255
 256     my $from = '';
 257     for my $char (split(//,$ofrom)) {
 258         $char = "\\" . $char if ($char =~ /\W/);
 259         $from = join('', $from, $char);
 260     }
 261     $record[-1] =~ s/$from/$to/;
 262     $context[3] = $record[-1];
 263     print_linecontext();
 264     return 0;
 265 }
 266
 267 sub merge_lines {
 268     my $last = pop @record;
 269     $last =~ s/^\s+//;
 270     $record[-1] =~ s/\n//;
 271     $record[-1] = join('', $record[-1], $last);
 272     my @temp = ("\n");
 273     push @temp, @context[0..1];
 274     $temp[3] = $record[-1];
 275     $temp[4] = $context[4];
 276     @context = @temp;
 277     print_linecontext();
 278     return 0;
 279 }
 280
 281 sub kill_line {
 282     pop @record;
 283     $context[3] = " [LINE KILLED]\n";
 284     print_linecontext();
 285     return 0;
 286 }
 287
 288 sub dump_record {
 289     my ($line_in, @explanation) = @_;
 290     $recmeta{explanation} = join(' ', 'Tag', $recmeta{tag}, @explanation);
 291     my $line = <MARC>; $count++;
 292     update_linecontext();
 293     until ($line =~ m|</record>|) {
 294         push @record, $line;
 295         $line = <MARC>; $count++;
 296         update_linecontext();
 297     }
 298     push @record, $line;
 299     write_record($EXMARC);
 300     return 1;
 301 }
 302
 303 sub commit_edit { return 1 }
 304
 305 sub print_context {
 306     print "\n Tag:",$recmeta{tag}, " Ind1:'",
 307       $recmeta{ind1},"' Ind2:'", $recmeta{ind2}, "'";
 308     print_linecontext();
 309     return 0;
 310 }
 311
 312 sub print_linecontext {
 313     print $OUT "\n", join('    |','',@context[0..2]);
 314     print $OUT '==> |', $context[3];
 315     print $OUT '    |', $context[4],"\n";
 316     return 0;
 317 }
 318
 319 sub show_original {
 320     my ($line_in) = @_;
 321     print $OUT "\n$line_in\n";
 322     return 0;
 323 }
 324
 325 sub help {
 326 print $OUT <<HELP;
 327
 328 Type a replacement for the indicated line, or enter a command.
 329
 330 Commands: c  Show record context ('C' for brief context)
 331           k  Kill indicated line (remove from record)
 332           m  Merge indicated line with previous line
 333           o  Show original line
 334           s  Substitute ARG1 for ARG2 in indicated line
 335           t  Commit changes and resume stream edit
 336           x  Write this record to the exception file instead of output
 337           q  Quit
 338
 339 HELP
 340 return 0;
 341 }
 342
 343 sub quit { exit }
 344
 345 #-----------------------------------------------------------------------------------
 346 # populate_trash
 347 #-----------------------------------------------------------------------------------
 348 # defined a domain-specific language for specifying MARC tags to be dropped from
 349 # records during processing. it is line oriented, and is specified as follows:
 350 #
 351 # each line may specify any number of tags to be included, either singly (\d{1,3})
 352 # or as a range (\d{1,3}\.\.\d{1,3}
 353 #
 354 # if a single number is given, it must be between '000' and '999', inclusive.
 355 #
 356 # ranges obey the previous rule, and also the first number of the range must be less
 357 # than the second number
 358 #
 359 # finally, any single range in a line may be followed by the keyword 'except'. every
 360 # number or range after 'except' is excluded from the range specified. all these
 361 # numbers must actually be within the range.
 362 #
 363 # specifying a tag twice is an error, to help prevent typos
 364
 365 sub populate_trash {
 366     open TRASH, '<', '.trashtags';
 367     while (<TRASH>) {
 368         my $lastwasrange = 0;
 369         my %lastrange = ( high => 0, low => 0);
 370         my $except = 0;
 371
 372         my @chunks = split /\s+/;
 373         while (my $chunk = shift @chunks) {
 374
 375             # single values
 376             if ($chunk =~ /^\d{1,3}$/) {
 377                 trash_add($chunk, $except);
 378                 $lastwasrange = 0;
 379                 next;
 380             }
 381
 382             # ranges
 383             if ($chunk =~ /^\d{1,3}\.\.\d{1,3}$/) {
 384                 my ($low, $high) = trash_add_range($chunk, $except, \%lastrange);
 385                 $lastwasrange = 1;
 386                 %lastrange = (low => $low, high => $high)
 387                   unless $except;
 388                 next;
 389             }
 390
 391             # 'except'
 392             if ($chunk eq 'except') {
 393                 die "Keyword 'except' can only follow a range (line $.)\n"
 394                   unless $lastwasrange;
 395                 die "Keyword 'except' may only occur once per line (line $.)\n"
 396                   if $except;
 397                 $except = 1;
 398                 next;
 399             }
 400
 401             die "Unknown chunk $chunk in .trashtags file (line $.)\n";
 402         }
 403     }
 404 }
 405
 406 sub trash_add_range {
 407     my ($chunk, $except, $range) = @_;
 408     my ($low,$high) = split /\.\./, $chunk;
 409     die "Ranges must be 'low..high' ($low is greater than $high on line $.)\n"
 410       if ($low > $high);
 411     if ($except) {
 412         die "Exception ranges must be within last addition range (line $.)\n"
 413           if ($low < $range->{low} or $high > $range->{high});
 414     }
 415     for my $tag ($low..$high) {
 416         trash_add($tag, $except)
 417     }
 418     return $low, $high;
 419 }
 420
 421 sub trash_add {
 422     my ($tag, $except) = @_;
 423     die "Trash values must be valid tags (000-999)\n"
 424       unless ($tag >= 0 and $tag <= 999);
 425     if ($except) {
 426         delete $trash{$tag};
 427     } else {
 428         die "Trash tag '$tag' specified twice (line $.)\n"
 429           if $trash{$tag};
 430         $trash{$tag} = 1;
 431     }
 432 }