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
  19 my @record = (); # current record storage
  20 my %reccontext = ();
  21 my @linecontext= (); # last 5 lines of file
  22
  23 my $input = shift || 'incoming.marc.xml';
  24
  25 open MARC, '<', $input;
  26 open my $NUMARC, '>', 'incoming.clean.marc.xml';
  27 print $NUMARC '<?xml version="1.0" encoding="UTF-8"?>',"\n";
  28 print $NUMARC '<collection xmlns="http://www.loc.gov/MARC21/slim">',"\n";
  29
  30 open my $EXMARC, '>', 'incoming.exceptions.marc.xml';
  31 print $EXMARC '<?xml version="1.0" encoding="UTF-8"?>',"\n";
  32 print $EXMARC '<collection xmlns="http://www.loc.gov/MARC21/slim">',"\n";
  33 open MARC2, '<', $input;
  34 <MARC2>;
  35
  36 # this is the dispatch table which drives command selection in
  37 # edit(), below
  38 my %commands = ( c => \&print_context,
  39                  C => \&print_linecontext,
  40                  k => \&kill_line,
  41                  o => \&show_original,
  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 (my $line = getline()) {
  56     unless ($count % 2000) {
  57         print "\rWorking... ", $spinner[$sidx];
  58         $sidx = ($sidx == $#spinner) ? 0 : $sidx + 1;
  59     }
  60     update_linecontext();
  61
  62     # catch empty datafield elements
  63     if ($line =~ m|</datafield>|) {
  64         if ($record[-2] =~ m/<datafield tag="..." ind1="." ind2=".">/) {
  65             pop @record; pop @record;
  66             message("Empty datafield scrubbed");
  67             next;
  68         }
  69     }
  70
  71     # pad short leaders
  72     if ($line =~ m|<leader>(.+?)</leader>|) {
  73         my $leader = $1;
  74         if (length $leader < 24) {
  75             $leader .= ' ' x (20 - length($leader));
  76             $leader .= "4500";
  77             $line = "<leader>$leader</leader>\n";
  78             message("Short leader padded");
  79         }
  80     }
  81
  82     # clean misplaced dollarsigns
  83     if ($line =~ m|<subfield code="\$">c?\d+\.\d{2}|) {
  84         $line =~ s|"\$">c?(\d+\.\d{2})|"c">\$$1|;
  85         message("Dollar sign corrected");
  86     }
  87
  88     # clean up tags with spaces in them
  89     $line =~ s/tag="  /tag="00/g;
  90     $line =~ s/tag=" /tag="0/g;
  91     $line =~ s/tag="-/tag="0/g;
  92     $line =~ s/tag="(\d\d) /tag="0$1/g;
  93
  94     # stow tag data if we're looking at it
  95     if ($line =~ m/<datafield tag="(.{3})" ind1="(.)" ind2="(.)">/) {
  96         $reccontext{tag}  = $1;
  97         $reccontext{ind1} = $2;
  98         $reccontext{ind2} = $3;
  99     }
 100
 101     # and stow line back in record
 102     $record[-1] = $line;
 103
 104     # naked ampersands
 105     if ($line =~ /&/ && $line !~ /&\w+?;/)
 106       { edit("Naked ampersand", $line); next }
 107
 108     # tags must be numeric
 109     if ($line =~ /<datafield tag="(.+?)"/) {
 110         my $match = $1;
 111         if ($match =~ /\D/) {
 112             edit("Non-numerics in tag", $line);
 113             next;
 114         }
 115     }
 116
 117     # subfields can't be non-alphanumeric
 118     if ($line =~ /<subfield code="(.+?)"/) {
 119         my $match = $1;
 120         if ($match =~ /\P{IsAlnum}/) {
 121             edit("Junk in subfield code", $line);
 122             next;
 123         }
 124     }
 125
 126 }
 127 print $NUMARC "</collection>\n";
 128 print $EXMARC "</collection>\n";
 129 print $OUT "\nDone.               \n";
 130
 131 =head2 edit
 132
 133 Handles the Term::ReadLine loop
 134
 135 =cut
 136
 137 sub edit {
 138     my ($msg, $line_in) = @_;
 139     message($msg);
 140     print_context();
 141
 142     while (1) {
 143         my $line = $term->readline('marc-cleanup>');
 144         my @chunks = split /\s+/, $line;
 145
 146         if (length $chunks[0] == 1)
 147           { next unless (defined $commands{$chunks[0]}) }
 148
 149         if (defined $commands{$chunks[0]}) {
 150             my $term = $commands{$chunks[0]}->($line_in, @chunks[1..$#chunks]);
 151             last if $term;
 152         } else {
 153             if ($linecontext[3] eq " [LINE KILLED]\n") {
 154                 push @record, "$line\n"
 155             } else {
 156                 $record[-1] = "$line\n";
 157             }
 158             $linecontext[3] = "$line\n";
 159             print_linecontext();
 160         }
 161     }
 162 }
 163
 164 =head2 getline
 165
 166 Reads from the incoming MARC file; returns lines into the driver
 167 loop. Batches records for output, and maintains the linecontext listing.
 168
 169 =cut
 170
 171 sub getline {
 172     my $l = <MARC>;
 173     $count++;
 174     if (defined $l) {
 175         if ($l =~ /<record>/) {
 176             @record = ($l);
 177             %reccontext = ();
 178             $reccount++;
 179         } elsif ($l =~ m|</record>|) {
 180             push @record, $l;
 181             write_record($NUMARC) if $reccount;
 182         } else {
 183             push @record, $l;
 184         }
 185     }
 186     return $l;
 187 }
 188
 189 sub write_record {
 190     my ($FH) = @_;
 191     $oreccount++ if ($FH eq $NUMARC);
 192     print $FH '<!-- ', $reccontext{explanation}, " -->\n"
 193       if(defined $reccontext{explanation});
 194     print $FH @record;
 195 }
 196
 197 sub update_linecontext {
 198     my $line2 = <MARC2>;
 199     push @linecontext, $line2;
 200     shift @linecontext if (@linecontext > 5);
 201 }
 202
 203 sub message {
 204     my ($msg) = @_;
 205     print $OUT "\r$msg at record $reccount/",$oreccount + 1,"\n";
 206
 207 }
 208
 209 #-----------------------------------------------------------------------------------
 210 # command routines
 211 #-----------------------------------------------------------------------------------
 212
 213 sub substitute {
 214     my ($line_in, @chunks) = @_;
 215     my $ofrom = shift @chunks;
 216     if ($ofrom =~ /^'/ or !@chunks) {
 217         until ($ofrom =~ /'$/)
 218           { $ofrom .= join(' ','',shift @chunks) }
 219         $ofrom =~ s/^'//; $ofrom =~ s/'$//;
 220     }
 221     my $to = shift @chunks;
 222     if ($to =~ /^'/) {
 223         until ($to =~ /'$/ or !@chunks)
 224           { $to .= join(' ','',shift @chunks) }
 225         $to =~ s/^'//; $to =~ s/'$//;
 226     }
 227
 228     my $from = '';
 229     for my $char (split(//,$ofrom)) {
 230         $char = "\\" . $char if ($char =~ /\W/);
 231         $from = join('', $from, $char);
 232     }
 233     $record[-1] =~ s/$from/$to/;
 234     $linecontext[3] = $record[-1];
 235     print_linecontext();
 236     return 0;
 237 }
 238
 239 sub merge_lines {
 240     my $last = pop @record;
 241     $last =~ s/^\s+//;
 242     $record[-1] =~ s/\n//;
 243     $record[-1] = join('', $record[-1], $last);
 244     my @temp = ("\n");
 245     push @temp, @linecontext[0..1];
 246     $temp[3] = $record[-1];
 247     $temp[4] = $linecontext[4];
 248     @linecontext = @temp;
 249     print_linecontext();
 250     return 0;
 251 }
 252
 253 sub kill_line {
 254     pop @record;
 255     $linecontext[3] = " [LINE KILLED]\n";
 256     print_linecontext();
 257     return 0;
 258 }
 259
 260 sub dump_record {
 261     my ($line_in, @explanation) = @_;
 262     $reccontext{explanation} = join(' ', @explanation);
 263     my $line = <MARC>; $count++;
 264     update_linecontext();
 265     until ($line =~ m|</record>|) {
 266         push @record, $line;
 267         $line = <MARC>; $count++;
 268         update_linecontext();
 269     }
 270     push @record, $line;
 271     write_record($EXMARC);
 272     return 1;
 273 }
 274
 275 sub commit_edit { return 1 }
 276
 277 sub print_context {
 278     print "\n Tag:",$reccontext{tag}, " Ind1:'",
 279       $reccontext{ind1},"' Ind2:'", $reccontext{ind2}, "'";
 280     print_linecontext();
 281     return 0;
 282 }
 283
 284 sub print_linecontext {
 285     print $OUT "\n", join('    |','',@linecontext[0..2]);
 286     print $OUT '==> |', $linecontext[3];
 287     print $OUT '    |', $linecontext[4],"\n";
 288     return 0;
 289 }
 290
 291 sub show_original {
 292     my ($line_in) = @_;
 293     print $OUT "\n$line_in\n";
 294     return 0;
 295 }
 296
 297 sub help {
 298 print $OUT <<HELP;
 299
 300 Type a replacement for the indicated line, or enter a command.
 301
 302 Commands: c  Show record context ('C' for brief context)
 303           k  Kill indicated line (remove from record)
 304           m  Merge indicated line with previous line
 305           o  Show original line
 306           s  Substitute ARG1 for ARG2 in indicated line
 307           t  Commit changes and resume stream edit
 308           x  Write this record to the exception file instead of output
 309           q  Quit
 310
 311 HELP
 312 return 0;
 313 }
 314
 315 sub quit { exit }