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