my $term = new Term::ReadLine 'yaz-cleanup';
my $OUT = $term->OUT || \*STDOUT;
+my $conf = {};
+
my $count = 0;
my $reccount = 0;
my $oreccount = 0;
my $line = '';
+my %trash = (); # hash for tags to be dumped
+
+# initialization and setup
+initialize($conf);
+
+# read in trash tags file if it exists
+populate_trash() if ($conf->{trash});
-my @record = (); # current record storage
-my %reccontext = ();
-my @linecontext= (); # last 5 lines of file
+my @record = (); # current record storage
+my %recmeta = (); # metadata about current record
+my @context= (); # last 5 lines of file
my $input = shift || 'incoming.marc.xml';
-open MARC, '<', $input;
-open my $NUMARC, '>', 'incoming.clean.marc.xml';
+open MARC, '<:utf8', $input;
+open my $NUMARC, '>:utf8', $conf->{output};
print $NUMARC '<?xml version="1.0" encoding="UTF-8"?>',"\n";
print $NUMARC '<collection xmlns="http://www.loc.gov/MARC21/slim">',"\n";
-open my $EXMARC, '>', 'incoming.exceptions.marc.xml';
+open my $EXMARC, '>:utf8', $conf->{exception};
print $EXMARC '<?xml version="1.0" encoding="UTF-8"?>',"\n";
print $EXMARC '<collection xmlns="http://www.loc.gov/MARC21/slim">',"\n";
open MARC2, '<', $input;
}
update_linecontext();
+ next if ($line =~ m|</record>|);
+
# catch empty datafield elements
if ($line =~ m|</datafield>|) {
if ($record[-2] =~ m/<datafield tag="..." ind1="." ind2=".">/) {
# stow tag data if we're looking at it
if ($line =~ m/<datafield tag="(.{3})" ind1="(.)" ind2="(.)">/) {
- $reccontext{tag} = $1;
- $reccontext{ind1} = $2;
- $reccontext{ind2} = $3;
+ $recmeta{tag} = $1;
+ $recmeta{ind1} = $2;
+ $recmeta{ind2} = $3;
}
+ # automatable subfield maladies
+ $line =~ s/code=" ">c/code="c">/;
+ $line =~ s/code=" ">\$/code="c"$>/;
+
# and stow line back in record
$record[-1] = $line;
}
# subfields can't be non-alphanumeric
- if ($line =~ /<subfield code="(.+?)"/) {
+ if ($line =~ /<subfield code="(.*?)"/) {
my $match = $1;
- if ($match =~ /\P{IsAlnum}/) {
- edit("Junk in subfield code", $line);
+ if ($match =~ /\P{IsAlnum}/ or $match eq '') {
+ edit("Junk in subfield code/Null subfield code", $line);
next;
}
}
sub edit {
my ($msg, $line_in) = @_;
+ return if $trash{$recmeta{tag}};
message($msg);
print_context();
my $term = $commands{$chunks[0]}->($line_in, @chunks[1..$#chunks]);
last if $term;
} else {
- if ($linecontext[3] eq " [LINE KILLED]\n") {
+ if ($context[3] eq " [LINE KILLED]\n") {
push @record, "$line\n"
} else {
$record[-1] = "$line\n";
}
- $linecontext[3] = "$line\n";
+ $context[3] = "$line\n";
print_linecontext();
}
}
=head2 getline
Reads from the incoming MARC file; returns lines into the driver
-loop. Batches records for output, and maintains the linecontext listing.
+loop. Batches records for output, and maintains the context listing.
=cut
if (defined $l) {
if ($l =~ /<record>/) {
@record = ($l);
- %reccontext = ();
+ %recmeta = ();
$reccount++;
} elsif ($l =~ m|</record>|) {
- push @record, $l;
write_record($NUMARC) if $reccount;
} else {
push @record, $l;
sub write_record {
my ($FH) = @_;
$oreccount++ if ($FH eq $NUMARC);
- print $FH '<!-- ', $reccontext{explanation}, " -->\n"
- if(defined $reccontext{explanation});
+ print $FH '<!-- ', $recmeta{explanation}, " -->\n"
+ if(defined $recmeta{explanation});
+
+ # excise unwanted tags
+ if (keys %trash or $conf->{autoscrub}) {
+ my @trimmed = ();
+ my $istrash = 0;
+ for my $line (@record) {
+ if ($istrash) {
+ $istrash = 0 if $line =~ m|</datafield|;
+ next;
+ }
+ if ($line =~ m/<datafield tag="(.{3})"/) {
+ my $tag = $1;
+ if ($trash{$tag} or ($conf->{autoscrub} and $tag =~ /\D/)) {
+ $istrash = 1;
+ next
+ }
+ }
+ push @trimmed, $line;
+ }
+ @record = @trimmed;
+ }
+
+ # scrub newlines
+ unless ($conf->{nocollapse}) {
+ s/\n// for (@record);
+ }
+
+ # add 903(?) with new record id
+ my $renumber = '';
+ if ($conf->{'renumber-from'}) {
+ $renumber = join('', '<datafield tag="', $conf->{'renumber-tag'},
+ '" ind1=" " ind2=" ">',
+ '<subfield code="', $conf->{'renumber-subfield'}, '">',
+ $conf->{'renumber-from'}, '</subfield></datafield>');
+ $renumber .= "\n" if $conf->{nocollapse};
+ push @record, $renumber;
+ $conf->{'renumber-from'}++;
+ }
+
print $FH @record;
+ print $FH "</record>\n";
}
sub update_linecontext {
my $line2 = <MARC2>;
- push @linecontext, $line2;
- shift @linecontext if (@linecontext > 5);
+ push @context, $line2;
+ shift @context if (@context > 5);
}
sub message {
$from = join('', $from, $char);
}
$record[-1] =~ s/$from/$to/;
- $linecontext[3] = $record[-1];
+ $context[3] = $record[-1];
print_linecontext();
return 0;
}
$record[-1] =~ s/\n//;
$record[-1] = join('', $record[-1], $last);
my @temp = ("\n");
- push @temp, @linecontext[0..1];
+ push @temp, @context[0..1];
$temp[3] = $record[-1];
- $temp[4] = $linecontext[4];
- @linecontext = @temp;
+ $temp[4] = $context[4];
+ @context = @temp;
print_linecontext();
return 0;
}
sub kill_line {
pop @record;
- $linecontext[3] = " [LINE KILLED]\n";
+ $context[3] = " [LINE KILLED]\n";
print_linecontext();
return 0;
}
sub dump_record {
my ($line_in, @explanation) = @_;
- $reccontext{explanation} = join(' ', @explanation);
+ $recmeta{explanation} = join(' ', 'Tag', $recmeta{tag}, @explanation);
my $line = <MARC>; $count++;
update_linecontext();
until ($line =~ m|</record>|) {
sub commit_edit { return 1 }
sub print_context {
- print "\n Tag:",$reccontext{tag}, " Ind1:'",
- $reccontext{ind1},"' Ind2:'", $reccontext{ind2}, "'";
+ print "\n Tag:",$recmeta{tag}, " Ind1:'",
+ $recmeta{ind1},"' Ind2:'", $recmeta{ind2}, "'";
print_linecontext();
return 0;
}
sub print_linecontext {
- print $OUT "\n", join(' |','',@linecontext[0..2]);
- print $OUT '==> |', $linecontext[3];
- print $OUT ' |', $linecontext[4],"\n";
+ print $OUT "\n", join(' |','',@context[0..2]);
+ print $OUT '==> |', $context[3];
+ print $OUT ' |', $context[4],"\n";
return 0;
}
}
sub quit { exit }
+
+#-----------------------------------------------------------------------------------
+# populate_trash
+#-----------------------------------------------------------------------------------
+# defined a domain-specific language for specifying MARC tags to be dropped from
+# records during processing. it is line oriented, and is specified as follows:
+#
+# each line may specify any number of tags to be included, either singly (\d{1,3})
+# or as a range (\d{1,3}\.\.\d{1,3}
+#
+# if a single number is given, it must be between '000' and '999', inclusive.
+#
+# ranges obey the previous rule, and also the first number of the range must be less
+# than the second number
+#
+# finally, any single range in a line may be followed by the keyword 'except'. every
+# number or range after 'except' is excluded from the range specified. all these
+# numbers must actually be within the range.
+#
+# specifying a tag twice is an error, to help prevent typos
+
+sub populate_trash {
+ print $OUT ">>> TRASHTAGS FILE FOUND. LOADING TAGS TO BE STRIPPED FROM OUTPUT\n";
+ open TRASH, '<', $conf->{trash}
+ or die "Can't open trash tags file!\n";
+ while (<TRASH>) {
+ my $lastwasrange = 0;
+ my %lastrange = ( high => 0, low => 0);
+ my $except = 0;
+
+ my @chunks = split /\s+/;
+ while (my $chunk = shift @chunks) {
+
+ # single values
+ if ($chunk =~ /^\d{1,3}$/) {
+ trash_add($chunk, $except);
+ $lastwasrange = 0;
+ next;
+ }
+
+ # ranges
+ if ($chunk =~ /^\d{1,3}\.\.\d{1,3}$/) {
+ my ($low, $high) = trash_add_range($chunk, $except, \%lastrange);
+ $lastwasrange = 1;
+ %lastrange = (low => $low, high => $high)
+ unless $except;
+ next;
+ }
+
+ # 'except'
+ if ($chunk eq 'except') {
+ die "Keyword 'except' can only follow a range (line $.)\n"
+ unless $lastwasrange;
+ die "Keyword 'except' may only occur once per line (line $.)\n"
+ if $except;
+ $except = 1;
+ next;
+ }
+
+ die "Unknown chunk $chunk in .trashtags file (line $.)\n";
+ }
+ }
+
+ # remove original id sequence tag from trash hash if we know it
+ trash_add($conf->{'original-tag'}, 1)
+ if ($conf->{'original-tag'} and $trash{$conf->{'original-tag'}});
+}
+
+sub trash_add_range {
+ my ($chunk, $except, $range) = @_;
+ my ($low,$high) = split /\.\./, $chunk;
+ die "Ranges must be 'low..high' ($low is greater than $high on line $.)\n"
+ if ($low > $high);
+ if ($except) {
+ die "Exception ranges must be within last addition range (line $.)\n"
+ if ($low < $range->{low} or $high > $range->{high});
+ }
+ for my $tag ($low..$high) {
+ trash_add($tag, $except)
+ }
+ return $low, $high;
+}
+
+sub trash_add {
+ my ($tag, $except) = @_;
+ die "Trash values must be valid tags (000-999)\n"
+ unless ($tag >= 0 and $tag <= 999);
+ if ($except) {
+ delete $trash{$tag};
+ } else {
+ die "Trash tag '$tag' specified twice (line $.)\n"
+ if $trash{$tag};
+ $trash{$tag} = 1;
+ }
+}
+
+#-----------------------------------------------------------------------
+
+=head2 initialize
+
+Performs boring script initialization. Handles argument parsing,
+mostly.
+
+=cut
+
+sub initialize {
+ my ($c) = @_;
+ my @missing = ();
+
+ # set mode on existing filehandles
+ binmode(STDIN, ':utf8');
+
+ my $rc = GetOptions( $c,
+ 'autoscrub|a',
+ 'exception|x=s',
+ 'output|o=s',
+ 'nocollapse|n',
+ 'renumber-from|rf=i',
+ 'original-tag|ot=i',
+ 'renumber-tag|rt=i',
+ 'renumber-subfield|rt=i',
+ 'trash|t=s',
+ 'help|h',
+ );
+ show_help() unless $rc;
+ show_help() if ($c->{help});
+
+ # defaults
+ $c->{output} = 'incoming.cleaned.marc.xml' unless defined $c->{output};
+ $c->{exception} = 'incoming.exception.marc.xml' unless defined $c->{exception};
+ $c->{'renumber-tag'} = 903 unless defined $c->{'renumber-tag'};
+ $c->{'renumber-subfield'} = 'a' unless defined $c->{'renumber-subfield'};
+
+ my @keys = keys %{$c};
+ show_help() unless (@ARGV and @keys);
+ #for my $key ('runtype', 'tag', 'subfield', 'output', 'exception')
+ # { push @missing, $key unless $c->{$key} }
+ #if (@missing) {
+ # print "Required option: ", join(', ', @missing), " missing!\n";
+ # show_help();
+ #}
+}
+
+sub show_help {
+ print <<HELP;
+Usage is: $0 [OPTIONS] <filelist>
+Options
+ --output -o Cleaned MARCXML output filename (default: incoming.cleaned.marc.xml)
+ --exception -x Exception (dumped records) MARCXML filename (incoming.exception.marc.xml)
+HELP
+exit;
+}
projects / migration-tools.git / blobdiff