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