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