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