use strict;
use warnings;
-my $skip = shift || 0;
-my $count = 0;
+use Getopt::Long;
+use Term::ReadLine;
+
$| = 1;
-open MARC, '<', 'incoming.marc.xml';
-open NUMARC, '>', 'incoming.clean.marc.xml';
+my $term = new Term::ReadLine 'yaz-cleanup';
+my $OUT = $term->OUT || \*STDOUT;
-if ($skip) {
- until ($count == ($skip - 1)) {
- my $t = <MARC>;
- print NUMARC $t;
- $count++;
- printf("\rSpinning on to record %s (%2.2f%%)", $skip, ($count / $skip *100))
- unless ($count % 1000);
- }
- print "\nScrubbing resumes...\n" if $skip;
-}
+my $count = 0;
+my $reccount = 0;
+my $line = '';
-my $line1 = <MARC>;
+my @record = (); # current record storage
+my %reccontext = ();
+my @linecontext= (); # last 5 lines of file
+
+my $input = shift || 'incoming.marc.xml';
+
+open MARC, '<', $input;
+open my $NUMARC, '>', 'incoming.clean.marc.xml';
+print $NUMARC '<?xml version="1.0" encoding="UTF-8"?>',"\n";
+open my $EXMARC, '>', 'incoming.exceptions.marc.xml';
+print $EXMARC '<?xml version="1.0" encoding="UTF-8"?>',"\n";
+open MARC2, '<', $input;
+<MARC2>;
+
+# this is the dispatch table which drives command selection in
+# edit(), below
+my %commands = ( c => \&print_context,
+ C => \&print_linecontext,
+ k => \&kill_line,
+ o => \&show_original,
+ m => \&merge_lines,
+ t => \&commit_edit,
+ x => \&dump_record,
+ q => \&quit,
+ '?' => \&help,
+ h => \&help,
+ help => \&help,
+ );
+
+my @spinner = qw(- / | \\);
+my $sidx = 0;
+
+while (my $line = getline()) {
+ unless ($count % 2000) {
+ print "\rWorking... ", $spinner[$sidx];
+ $sidx = $sidx > $#spinner ? 0 : $sidx++;
+ }
+ update_linecontext();
-while (my $line2 = <MARC>) {
- $count++;
# catch empty datafield elements
- if ($line1 =~ m/<datafield tag="..." ind1="." ind2=".">/) {
- if ($line2 =~ m|</datafield>|) {
- print "Empty datafield scrubbed at line $count\n";
- $line1 = <MARC>;
- $count++;
+ if ($line =~ m|</datafield>|) {
+ if ($record[-2] =~ m/<datafield tag="..." ind1="." ind2=".">/) {
+ pop @record; pop @record;
+ print $OUT "\rEmpty datafield scrubbed at line $count\n";
next;
}
}
# clean misplaced dollarsigns
- if ($line1 =~ m|<subfield code="\$">c?\d+\.\d{2}|) {
- $line1 =~ s|"\$">c?(\d+\.\d{2})|"c">\$$1|;
- print "Dollar sign in subfield code corrected at line $count\n";
+ if ($line =~ m|<subfield code="\$">c?\d+\.\d{2}|) {
+ $line =~ s|"\$">c?(\d+\.\d{2})|"c">\$$1|;
+ print $OUT "\rDollar sign in subfield code corrected at line $count\n";
}
# clean up tags with spaces in them
- $line1 =~ s/tag=" /tag="00/g;
- $line1 =~ s/tag=" /tag="0/g;
- $line1 =~ s/tag="-/tag="0/g;
- $line1 =~ s/tag="(\d\d) /tag="0$1/g;
+ $line =~ s/tag=" /tag="00/g;
+ $line =~ s/tag=" /tag="0/g;
+ $line =~ s/tag="-/tag="0/g;
+ $line =~ s/tag="(\d\d) /tag="0$1/g;
+
+ # stow tag data if we're looking at it
+ if ($line =~ m/<datafield tag="(\d{3})" ind1="(.)" ind2="(.)">/) {
+ $reccontext{tag} = $1;
+ $reccontext{ind1} = $2;
+ $reccontext{ind2} = $3;
+ }
# naked ampersands
- die "Looks like naked ampersand at line $count: $line1"
- if ($line1 =~ /&/ && $line1 !~ /&\w{1,7};/);
+ if ($line =~ /&/ && $line !~ /&\w+?;/)
+ { edit("Looks like naked ampersand", $line); next }
# subfields can't be non-alphanumeric
- die "Junk in subfield at line $count: $line1"
- if $line1 =~ /<subfield code="[^[:alnum:]]"/;
+ if ($line =~ /<subfield code="(.+?)"/) {
+ my $match = $1;
+ if ($match =~ /\P{IsAlnum}/) {
+ print $OUT "\n$match\n";
+ edit("Junk in subfield", $line);
+ next;
+ }
+ }
+
+}
+print $NUMARC "</xml>\n";
+print $EXMARC "</xml>\n";
+
+=head2 edit
+
+Handles the Term::ReadLine loop
+
+=cut
- # everything looks ok
- print NUMARC $line1;
- $line1 = $line2;
+sub edit {
+ my ($msg, $line_in) = @_;
+ print $OUT "\r".$msg, " at line $count:\n";
+ print_context();
+ while (1) {
+ my $line = $term->readline('yaz-cleanup>');
+ if (length $line < 2)
+ { next unless (defined $commands{$line}) }
+ if (defined $commands{$line}) {
+ my $term = $commands{$line}->($line_in);
+ last if $term;
+ } else {
+ if ($linecontext[3] eq " [LINE KILLED]\n") {
+ push @record, "$line\n"
+ } else {
+ $record[-1] = "$line\n";
+ }
+ $linecontext[3] = "$line\n";
+ print_linecontext();
+ }
+ }
}
-print NUMARC $line1;
+
+=head2 getline
+
+Reads from the incoming MARC file; returns lines into the driver
+loop. Batches records for output, and maintains the linecontext listing.
+
+=cut
+
+sub getline {
+ my $l = <MARC>;
+ $count++;
+ if (defined $l) {
+ if ($l =~ /<record>/) {
+ @record = ($l);
+ %reccontext = ();
+ $reccount++;
+ } elsif ($l =~ m|</record>|) {
+ push @record, $l;
+ write_record($NUMARC) if $reccount;
+ } else {
+ push @record, $l;
+ }
+ }
+ return $l;
+}
+
+sub write_record {
+ my ($FH) = @_;
+ 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";
+ print $FH @record;
+ print $FH "</collection>\n";
+}
+
+sub update_linecontext {
+ my $line2 = <MARC2>;
+ push @linecontext, $line2;
+ shift @linecontext if (@linecontext > 5);
+}
+
+#-----------------------------------------------------------------------------------
+# command routines
+#-----------------------------------------------------------------------------------
+
+sub print_context {
+ print "\n Tag:",$reccontext{tag}, " Ind1:'",
+ $reccontext{ind1},"' Ind2:'", $reccontext{ind2}, "'";
+ print_linecontext();
+ return 0;
+}
+
+sub print_linecontext {
+ print $OUT "\n", join(' |','',@linecontext[0..2]);
+ print $OUT '==> |', $linecontext[3];
+ print $OUT ' |', $linecontext[4],"\n";
+ return 0;
+}
+
+sub show_original {
+ my ($line_in) = @_;
+ print $OUT "\n$line_in\n";
+ return 0;
+}
+
+sub merge_lines {
+ my $last = pop @record;
+ $last =~ s/^\s+//;
+ $record[-1] =~ s/\n//;
+ $record[-1] = join('', $record[-1], $last);
+ my @temp = ("\n");
+ push @temp, @linecontext[0..1];
+ $temp[3] = $record[-1];
+ $temp[4] = $linecontext[4];
+ @linecontext = @temp;
+ print_linecontext();
+ return 0;
+}
+
+sub kill_line {
+ pop @record;
+ $linecontext[3] = " [LINE KILLED]\n";
+ print_linecontext();
+ return 0;
+}
+
+sub dump_record {
+ my $line = <MARC>; $count++;
+ update_linecontext();
+ until ($line =~ m|</record>|) {
+ push @record, $line;
+ $line = <MARC>; $count++;
+ update_linecontext();
+ }
+ push @record, $line;
+ write_record($EXMARC);
+ return 1;
+}
+
+sub commit_edit { return 1 }
+
+sub help {
+print $OUT <<HELP;
+
+Type a replacement for the indicated line, or enter a command.
+
+Commands: c Show record context ('C' for brief context)
+ k Kill this line (remove from record)
+ m Merge indicated line with previous line
+ o Show original line
+ t Commit changes and resume stream edit
+ x Write this record to the exception file instead of output
+ q Quit
+
+HELP
+return 0;
+}
+
+sub quit { exit }
projects / migration-tools.git / blobdiff