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