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 print $OUT "Interactive MARC Stream Editor starting up\n";
  14
  15 my $count = 0;
  16 my $reccount = 0;
  17 my $line = '';
  18
  19 my @record = (); # current record storage
  20 my @context= (); # 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                  k => \&kill_line,
  34                  o => \&show_original,
  35                  t => \&commit_edit,
  36                  x => \&dump_record,
  37                  q => \&quit,
  38                  '?' => \&help,
  39                  h   => \&help,
  40                  help => \&help,
  41                );
  42
  43 my @spinner = qw(- / | \\);
  44 my $sidx = 0;
  45
  46 while (my $line = getline()) {
  47     unless ($count % 2000) {
  48         print "\rWorking... ", $spinner[$sidx];
  49         $sidx++;
  50         $sidx = 0 if ($sidx > $#spinner);
  51     }
  52     update_context();
  53
  54     # catch empty datafield elements
  55     if ($line =~ m|</datafield>|) {
  56         if ($record[-2] =~ m/<datafield tag="..." ind1="." ind2=".">/) {
  57             pop @record; pop @record;
  58             print $OUT "\rEmpty datafield scrubbed at line $count\n";
  59             next;
  60         }
  61     }
  62
  63     # clean misplaced dollarsigns
  64     if ($line =~ m|<subfield code="\$">c?\d+\.\d{2}|) {
  65         $line =~ s|"\$">c?(\d+\.\d{2})|"c">\$$1|;
  66         print $OUT "\rDollar sign in subfield code corrected at line $count\n";
  67     }
  68
  69     # clean up tags with spaces in them
  70     $line =~ s/tag="  /tag="00/g;
  71     $line =~ s/tag=" /tag="0/g;
  72     $line =~ s/tag="-/tag="0/g;
  73     $line =~ s/tag="(\d\d) /tag="0$1/g;
  74
  75     # naked ampersands
  76     if ($line =~ /&/ && $line !~ /&\w{1,7};/)
  77       { edit("Looks like naked ampersand", $line); next }
  78
  79     # subfields can't be non-alphanumeric
  80       if ($line =~ /<subfield code="[^[:alnum:]]"/)
  81         { edit("Junk in subfield", $line); next }
  82
  83 }
  84 print $NUMARC "</xml>\n";
  85 print $EXMARC "</xml>\n";
  86
  87 =head2 edit
  88
  89 Handles the Term::ReadLine loop
  90
  91 =cut
  92
  93 sub edit {
  94     my ($msg, $line_in) = @_;
  95     print $OUT "\r".$msg, " at line $count:\n";
  96     print_context();
  97     while (1) {
  98         my $line = $term->readline('yaz-cleanup>');
  99         if (defined $commands{$line}) {
 100             my $term = $commands{$line}->($line_in);
 101             last if $term;
 102         } else {
 103             if ($context[3] eq " [LINE KILLED\n]") {
 104                 push @record, "$line\n"
 105             } else {
 106                 $record[-1] = "$line\n";
 107             }
 108             $context[3] = "$line\n";
 109             print_context();
 110         }
 111     }
 112 }
 113
 114 =head2 getline
 115
 116 Reads from the incoming MARC file; returns lines into the driver
 117 loop. Batches records for output, and maintains the context listing.
 118
 119 =cut
 120
 121 sub getline {
 122     my $l = <MARC>;
 123     $count++;
 124     if (defined $l) {
 125         if ($l =~ /<record>/) {
 126             @record = ($l);
 127             $reccount++;
 128         } elsif ($l =~ m|</record>|) {
 129             write_record($NUMARC) if $reccount;
 130         } else {
 131             push @record, $l;
 132         }
 133     }
 134     return $l;
 135 }
 136
 137 sub write_record {
 138     my ($FH) = @_;
 139     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";
 140     print $FH @record;
 141     print $FH "</collection>\n";
 142 }
 143
 144 sub update_context {
 145     my $line2 = <MARC2>;
 146     push @context, $line2;
 147     shift @context if (@context > 5);
 148 }
 149
 150 #-----------------------------------------------------------------------------------
 151 # command routines
 152 #-----------------------------------------------------------------------------------
 153
 154 sub print_context {
 155     print $OUT "\n", join('    |','',@context[0..2]);
 156     print $OUT '==> |', $context[3];
 157     print $OUT '    |', $context[4],"\n";
 158     return 0;
 159 }
 160
 161 sub show_original {
 162     my ($line_in) = @_;
 163     print $OUT "\n$line_in\n";
 164     return 0;
 165 }
 166
 167 sub commit_edit { return 1 }
 168
 169 sub kill_line {
 170     pop @record;
 171     $context[3] = " [LINE KILLED]\n";
 172     print_context();
 173     return 0;
 174 }
 175
 176 sub dump_record {
 177     my $line = <MARC>;
 178     until ($line =~ m|</record>|) {
 179         push @record, $line;
 180         $line = <MARC>;
 181         update_context;
 182     }
 183     push @record, $line;
 184     write_record($EXMARC);
 185 }
 186
 187 sub help {
 188 print $OUT <<HELP;
 189
 190 Type a replacement for the indicated line, or enter a command.
 191
 192 Commands: c  Show line context
 193           k  Kill this line (remove from record)
 194           o  Show original line
 195           t  Commit changes and resume stream edit
 196           x  Write this record to the exception file instead of output
 197           q  Quit
 198
 199 HELP
 200 return 0;
 201 }
 202
 203 sub quit { exit }