MARC
view release on metacpan or search on metacpan
# indicators. If there is no match, it does nothing. Deletefirst also
# rebuilds the map if $do_rebuild_map. Deletefirst returns the number
# of matches deleted (that would be 0 or 1), or undef if it feels
# grumpy (i.e. carps).
####################################################################
sub deletefirst { # rec
my $marc = shift || return;
my $template = shift;
my $recnum = $template->{'record'};
if (!$recnum) {mycarp "Need a record to confine my destructive tendencies"; return undef}
return $marc->[$recnum]->deletefirst($template);
}
####################################################################
# field_is_empty takes a ref to an array formatted like
# an element of $marc->[$recnum]{array}. It returns 1 if there are
# no "significant" elements of the array (e.g. nothing but indicators
# if $tag>10), else 0. Override this if you want to delete fields
# that have "insignificant" subfields inside deletefirst.
####################################################################
sub field_is_empty { # rec
my ($marc,$rfield) = @_;
return $marc->[0]{proto_rec}->field_is_empty($rfield);
}
####################################################################
# field_updatehook takes a ref to an array formatted like
# $marc->[$recnum]{'array'}. It is there so that
# subclasses can override it to do something before calling
# addfield(), e.g. store field-specific information in the affected
# field or log information in an external file/database. One notes that
# since this is a method, it can ignore its arguments and log global
# information about $marc, e.g. order information in $marc->[$rnum]{'array'}
####################################################################
sub field_updatehook { # rec
my ($marc,$rfield)=@_;
$marc->[0]{'proto_rec'}->field_updatehook($rfield);
}
####################################################################
# updatefirst() takes a template, a request to rebuild the index, and
# an array from $marc->[recnum]{array}. It replaces/creates the field
# data for a first match, using the template, and leaves the rest
# alone. If the template has a subfield element, (this includes
# indicators) it ignores all other information in the array and only
# updates/creates based on the subfield information in the array. If
# the template has no subfield information then indicators are left
# untouched unless a new field needs to be created, in which case they
# are left blank.
####################################################################
sub updatefirst { # rec
my $marc = shift || return;
my $template = shift;
return unless (ref($template) eq "HASH");
return unless (@_);
return if (defined $template->{'value'});
my $recnum = $template->{'record'};
if (!$recnum) {mycarp "Need a record to confine my changing needs."; return undef}
return $marc->[$recnum]->updatefirst($template,@_);
}
####################################################################
# updatefields() takes a template which specifies recnum, a
# $do_rebuild_map and a field (needs the field in case $rafields->[0]
# is empty). It also takes a ref to an array of fieldrefs formatted
# like the output of getfields(), and replaces/creates the field
# data. It assumes that it should remove the fields with the first tag
# in the fieldrefs. It calls rebuild_map() if $do_rebuild_map.
####################################################################
sub updatefields { # rec
my $marc = shift || return;
my $template = shift;
my $rafieldrefs = shift;
my $recnum = $template->{'record'};
return $marc->[$recnum]->updatefields($template,$rafieldrefs);
}
####################################################################
# getmatch() takes a subfield code (can be an indicator) and a fieldref
# Returns 0 or a ref to the value to be updated.
####################################################################
sub getmatch { # rec
my $marc = shift || return;
return $marc->[0]{proto_rec}->getmatch(@_);
}
####################################################################
# deletesubfield() takes a subfield code (can not be an indicator) and a
# fieldref. Deletes the subfield code and its value in the fieldref at
# the first match on subfield code. Assumes there is an exact
# subfield match in $fieldref.
####################################################################
sub deletesubfield { # rec
my $marc = shift || return;
return $marc->[0]{proto_rec}->deletesubfield(@_);
}
####################################################################
# insertpos() takes a subfield code (can not be an indicator), a
# value, and a fieldref. Updates the fieldref with the first
# place that the fieldref can match. Assumes there is no exact
# subfield match in $fieldref.
####################################################################
sub insertpos { # rec
my $marc = shift || return;
return $marc->[0]{proto_rec}->insertpos(@_);
}
####################################################################
# updaterecord() takes an array of key/value pairs, formatted like #
# the output of getupdate(), and replaces/creates the field data. #
# For repeated tags, a "\036" element is used to delimit data into #
# separate addfield() commands. #
####################################################################
sub updaterecord {
my $marc = shift || return;
my $template = shift;
return unless (ref($template) eq "HASH");
return unless (@_);
return if (defined $template->{'value'});
my $count = 0;
my @records = ();
unless ($marc->deletemarc($template)) {mycarp "not deleted\n"; return;}
foreach my $y1 (@_) {
unless ($y1 eq "\036") {
push @records, $y1;
next;
}
unless ($marc->addfield($template, @records)) {
mycarp "not added\n";
return;
}
@records = ();
$count++;
}
return $count;
}
####################################################################
# _offset is an internal subroutine used by writemarc to offset #
# number ie. making "34" into "00034". #
####################################################################
sub _offset{
return MARC::Rec::_offset(@_);
}
####################################################################
# MARC::Rec is responsible for the methods and representation of
# a single MARC record. Its protocol is very close to that of MARC:
# in fact, most MARC methods have been moved here without the record
# number and re-implemented in standard form by delegation.
####################################################################
package MARC::Rec;
use Carp;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS
@LDR_FIELDS $LDR_TEMPLATE %FF_FIELDS %FF_TEMPLATE
);
$VERSION = $MARC::VERSION;
@ISA = qw(Exporter);
@EXPORT= qw();
@EXPORT_OK= qw();
#### Not using these yet
#### %EXPORT_TAGS = (USTEXT => [qw( marc2ustext )]);
#### Exporter::export_ok_tags('USTEXT');
#### $EXPORT_TAGS{ALL} = \@EXPORT_OK;
# gotta know where to find leader information....
$inchar{uhorn} = chr(0xbd); # latin small letter u with horn
$inchar{deg} = chr(0xc0); # degree sign
$inchar{scriptl} = chr(0xc1); # latin small letter script l
$inchar{phono} = chr(0xc2); # sound recording copyright
$inchar{copy} = chr(0xc3); # copyright sign
$inchar{sharp} = chr(0xc4); # sharp
$inchar{iquest} = chr(0xc5); # inverted question mark
$inchar{iexcl} = chr(0xc6); # inverted exclamation mark
$inchar{hooka} = chr(0xe0); # combining hook above
$inchar{grave} = chr(0xe1); # combining grave
$inchar{acute} = chr(0xe2); # combining acute
$inchar{circ} = chr(0xe3); # combining circumflex
$inchar{tilde} = chr(0xe4); # combining tilde
$inchar{macr} = chr(0xe5); # combining macron
$inchar{breve} = chr(0xe6); # combining breve
$inchar{dot} = chr(0xe7); # combining dot above
$inchar{diaer} = chr(0xe8); # combining diaeresis
$inchar{uml} = chr(0xe8); # combining umlaut
$inchar{caron} = chr(0xe9); # combining hacek
$inchar{ring} = chr(0xea); # combining ring above
$inchar{llig} = chr(0xeb); # combining ligature left half
$inchar{rlig} = chr(0xec); # combining ligature right half
$inchar{rcommaa} = chr(0xed); # combining comma above right
$inchar{dblac} = chr(0xee); # combining double acute
$inchar{candra} = chr(0xef); # combining candrabindu
$inchar{cedil} = chr(0xf0); # combining cedilla
$inchar{ogon} = chr(0xf1); # combining ogonek
$inchar{dotb} = chr(0xf2); # combining dot below
$inchar{dbldotb} = chr(0xf3); # combining double dot below
$inchar{ringb} = chr(0xf4); # combining ring below
$inchar{dblunder} = chr(0xf5); # combining double underscore
$inchar{under} = chr(0xf6); # combining underscore
$inchar{commab} = chr(0xf7); # combining comma below
$inchar{rcedil} = chr(0xf8); # combining right cedilla
$inchar{breveb} = chr(0xf9); # combining breve below
$inchar{ldbltil} = chr(0xfa); # combining double tilde left half
$inchar{rdbltil} = chr(0xfb); # combining double tilde right half
$inchar{commaa} = chr(0xfe); # combining comma above
if ($MARC::DEBUG) {
foreach my $str (sort keys %inchar) {
printf "%s = %x\n", $str, ord($inchar{$str});
}
}
return \%inchar;
}
####################################################################
# updatefirst() takes a template, a request to rebuild the index, and
# an array from $marc->[recnum]{array}. It replaces/creates the field
# data for a first match, using the template, and leaves the rest
# alone. If the template has a subfield element, (this includes
# indicators) it ignores all other information in the array and only
# updates/creates based on the subfield information in the array. If
# the template has no subfield information then indicators are left
# untouched unless a new field needs to be created, in which case they
# are left blank.
####################################################################
sub updatefirst { # rec
my $marcrec = shift || return;
my $template = shift;
return unless (ref($template) eq "HASH");
return unless (@_);
return if (defined $template->{'value'});
my @ufield = @_;
my $field = $template->{'field'};
my $subfield = $template->{'subfield'};
my $do_rebuild_map = $template->{'rebuild_map'};
$ufield[0]= $field;
my $ufield_lt_10_value = $ufield[1];
my $ftemplate = {field=>$field};
if (!$field) {mycarp "Need a field to configure my changing needs."; return undef}
my @fieldrefs = $marcrec->getfields($template);
# An invariant is that at most one element of @fieldrefs is affected.
if ($field and not($subfield)) {
#save the indicators! Yes! Yes!
my ($i1,$i2) = (" "," ");
if (defined($fieldrefs[0])) {
$i1 = $fieldrefs[0][1];
$i2 = $fieldrefs[0][2];
}
$ufield[1]=$i1;
$ufield[2]=$i2;
if ($field <10) {@ufield = ($field,$ufield_lt_10_value)}
my $rafieldrefs = \@fieldrefs;
$marcrec->field_updatehook(\@ufield);
$rafieldrefs->[0] = \@ufield;
if (!scalar(@fieldrefs)) {
$marcrec->updatefields($template,$rafieldrefs);
return;
}
$fieldrefs[0]=\@ufield;
#There is no issue with $fieldrefs being taken over by the splice in updatefields.
# in current testing. Perl may change its behavior later...
$marcrec->updatefields($template,\@fieldrefs);
return;
} #end field.
# The case of adding first subfields is hard. (Not too bad with
# indicators since every non-control field has them.)
# OK, we have field, and subfield.
if ($field and $subfield) {
if ($field <10) {croak "Cannot update subfields of control fields"; return undef}
my $rvictim=0;
my $fieldnum = 0;
my $rval = 0;
foreach my $fieldref (@fieldrefs) {
$rval = $marcrec->getmatch($subfield,$fieldref);
if ($rval){
$rvictim=$fieldref;
last;
}
$fieldnum++;
}
}
#Now we need to find first match in @ufield.
my $usub = undef;
$usub=$ufield[1] if $subfield eq 'i1';
$usub=$ufield[2] if $subfield eq 'i2';
for(my $i=3;$i<@ufield;$i = $i+2) {
my $sub = $ufield[$i];
if ($sub eq $subfield) {
$usub = $ufield[$i+1];
last;
}
}
mycarp(
"Did not find $subfield in spec (".
join " ",@ufield . ")"
) if !defined($usub);
if (!scalar(@fieldrefs)) {
my @newfield = ($field, ' ',' ', $subfield =>$usub);
my $rafields;
$marcrec->field_updatehook(\@newfield);
$rafields->[0] = \@newfield;
return $marcrec->updatefields($template,$rafields);
}
#The general insert case.
if (!$rvictim and scalar(@fieldrefs)) {
$rvictim = $fieldrefs[0];
$marcrec->insertpos($subfield,$usub,$rvictim);
$marcrec->field_updatehook($rvictim);
$marcrec->rebuild_map($field) if $do_rebuild_map;
return 1; # $rvictim is now defined, so can't depend on future
# control logic.
}
#The general replace case.
if ($rvictim) {
$$rval = $usub;
$marcrec->field_updatehook($rvictim);
# The following line is unecessary for this class:
# everything updates due to hard-coded ref
# relationships in the index. Left so that subclasses
# can do their thing with less over-ruling.
$marcrec->rebuild_map($field) if $do_rebuild_map;
return 1;
}
} #end $field and $subfield
}
####################################################################
# updatefields() takes a template which specifies a
# $do_rebuild_map and a field (needs the field in case $rafields->[0]
# is empty). It also takes a ref to an array of fieldrefs formatted
# like the output of getfields(), and replaces/creates the field
# data. It assumes that it should remove the fields with the first tag
# in the fieldrefs. It calls rebuild_map() if $do_rebuild_map.
####################################################################
sub updatefields { # rec
my $marcrec = shift || return;
my $template = shift;
my $do_rebuild_map = $template->{'rebuild_map'};
my $tag = $template->{'field'};
my $rafieldrefs = shift;
my @fieldrefs = @$rafieldrefs;
my $pos = 0;
my $first=undef;
my $last = $first; # Should be "Let the first be last". Misbegotten Perl syntax.
my $firstpast = undef;
my $len = 0;
my @mfields = @{$marcrec->{'array'}};
my $insertpos = undef;
for (@mfields) {
$first = $pos if ($_->[0] eq $tag and !defined($first)) ;
$last = $pos if $_->[0] eq $tag;
$firstpast = $pos if ($_->[0] >= $tag and !defined($firstpast)) ;
$pos++;
}
$len = $last - $first +1 if defined($first);
$insertpos = scalar(@mfields) if !defined($firstpast);
$insertpos = $first if (defined($first));
$insertpos = $firstpast unless $insertpos;
splice @{$marcrec->{'array'}},$insertpos,$len,@fieldrefs;
$marcrec->rebuild_map($tag) if $do_rebuild_map;
}
####################################################################
# output() will call the appropriate output method using the marc #
# object and desired format parameters. #
####################################################################
sub output {
my $marcrec=shift;
my $args=shift;
my $output = "";
my $newline = $args->{'lineterm'} || "\n";
$marcrec->add_005($args) if ($args->{'file'} or $args->{'add_005s'});
unless (exists $args->{'format'}) {
# everything to string
$args->{'format'} = "usmarc";
$args->{'lineterm'} = $newline;
}
if ($args->{'format'} =~ /marc$/oi) {
$output = _writemarc($marcrec,$args);
}
elsif ($args->{'format'} =~ /marcmaker$/oi) {
$output = _marcmaker($marcrec,$args);
}
elsif ($args->{'format'} =~ /ascii$/oi) {
$output = _marc2ascii($marcrec,$args);
}
elsif ($args->{'format'} =~ /html$/oi) {
$output .= _marc2html($marcrec,$args);
}
elsif ($args->{'format'} =~ /html_header$/oi) {
( run in 1.480 second using v1.01-cache-2.11-cpan-d8267643d1d )