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