yaz-cleanup

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Getopt::Long;
   7 use Term::ReadLine;
   8
   9 my $term = new Term::ReadLine 'yaz-cleanup';
  10 my $OUT = $term->OUT || \*STDOUT;
  11
  12 my $count = 0;
  13 my $line = '';
  14
  15 my @record = ();
  16 my @context= ();
  17
  18 my %commands = ( '?' => \&help,
  19                  h   => \&help,
  20                  c   => \&print_context,
  21                  d   => \&dump_record,
  22                  q   => \&quit,
  23                );
  24
  25
  26 open MARC, '<', 'incoming.marc.xml';
  27 open NUMARC, '>', 'incoming.clean.marc.xml';
  28
  29 my $line1 = getline();
  30
  31 while (my $line2 = getline()) {
  32     # catch empty datafield elements
  33     if ($line1 =~ m/<datafield tag="..." ind1="." ind2=".">/) {
  34         if ($line2 =~ m|</datafield>|) {
  35             print "Empty datafield scrubbed at line $count\n";
  36             $line1 = getline();
  37             next;
  38         }
  39     }
  40
  41     # clean misplaced dollarsigns
  42     if ($line1 =~ m|<subfield code="\$">c?\d+\.\d{2}|) {
  43         $line1 =~ s|"\$">c?(\d+\.\d{2})|"c">\$$1|;
  44         print "Dollar sign in subfield code corrected at line $count\n";
  45     }
  46
  47     # clean up tags with spaces in them
  48     $line1 =~ s/tag="  /tag="00/g;
  49     $line1 =~ s/tag=" /tag="0/g;
  50     $line1 =~ s/tag="-/tag="0/g;
  51     $line1 =~ s/tag="(\d\d) /tag="0$1/g;
  52
  53     # naked ampersands
  54     edit("Looks like naked ampersand", $line1)
  55       if ($line1 =~ /&/ && $line1 !~ /&\w{1,7};/);
  56
  57     # subfields can't be non-alphanumeric
  58     die "Junk in subfield at line $count: $line1"
  59       if $line1 =~ /<subfield code="[^[:alnum:]]"/;
  60
  61     # everything looks ok
  62     print NUMARC $line1;
  63     $line1 = $line2;
  64 }
  65 print NUMARC $line1;
  66
  67 sub edit {
  68     my ($msg, $line_in) = @_;
  69     print $OUT "\n".$msg, " at line $count:\n";
  70     print $OUT "\t$line_in\n";
  71     while (1) {
  72         my $line = $term->readline('yaz-cleanup>');
  73         $commands{$line}->();
  74     }
  75 }
  76
  77 sub print_context {
  78     print $OUT "\n", join('   ','',@context[0..2]);
  79     print $OUT '==>', $context[3];
  80     print $OUT '   ', $context[4],"\n";
  81 }
  82
  83 sub getline {
  84     my $l = <MARC>;
  85     $count++;
  86     if (defined $l) {
  87         if ($l =~ /<record>/)
  88           { @record = ($l) }
  89         else
  90           { push @record, $l }
  91         push @context, $l;
  92         shift @context if (@context > 5);
  93     }
  94     return $l;
  95 }
  96
  97 sub help {
  98 print $OUT <<HELP;
  99
 100 Enter a replacement for this line, a blank line to dump this line, or a command.
 101 Commands: c  Show line context
 102           d  Dump this record (redirect to exceptions file)
 103           q  Quit
 104
 105 HELP
 106 }
 107
 108 sub quit { exit }