File Coverage

blib/lib/Biblio/Citation/Parser/Standard.pm

Criterion	Covered	Total	%
statement	146	208	70.1
branch	23	58	39.6
condition	5	30	16.6
subroutine	9	10	90.0
pod	7	8	87.5
total	190	314	60.5

package Biblio::Citation::Parser::Standard;

######################################################################
#
# Biblio::Citation::Parser::Standard;
#
######################################################################
#
#  This file is part of ParaCite Tools (http://paracite.eprints.org/developers/)
#
#  Copyright (c) 2004 University of Southampton, UK. SO17 1BJ.
#
#  ParaTools is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  ParaTools is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with ParaTools; if not, write to the Free Software
#  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
######################################################################

require Exporter;
@ISA = ("Exporter", "Biblio::Citation::Parser");

use strict;

use Biblio::Citation::Parser::Templates;
our @EXPORT_OK = ( 'parse', 'new' );


=pod

=head1 NAME

B - citation parsing functionality

=head1 SYNOPSIS

  use Biblio::Citation::Parser::Standard;
  # Parse a simple reference
  $parser = new Biblio::Citation::Parser::Standard;
  $metadata = $parser->parse("M. Jewell (2004) Citation Parsing for Beginners. Journal of Madeup References 4(3).");
  print "The title of this article is ".$metadata->{atitle}."\n";

=head1 DESCRIPTION

Biblio::Citation::Parser::Standard uses a relatively simple template matching
technique to extract metadata from citations.

The Templates.pm module currently provides almost 400 templates, with
more being added regularly, and the parser returns the metadata in a
form that is easily massaged into OpenURLs (see the Biblio::OpenURL
module for an even easier way).

=cut


my %factors =
(
	"_AUFIRST_"	=> 0.6,
	"_AULAST_"	=> 0.6,
	"_ISSN_"	=> 0.95,
	"_AUTHORS_"	=> 0.65,
	"_EDITOR_"	=> 0.6,
	"_DATE_"	=> 0.95,
	"_YEAR_" 	=> 0.8,
	"_SUBTITLE_" 	=> 0.6,
	"_TITLE_" 	=> 0.6,
	"_UCTITLE_" 	=> 0.7,
	"_CAPTITLE_"	=> 0.7,
	"_PUBLICATION_" => 0.65,
	"_PUBLISHER_" 	=> 0.65,
	"_PUBLOC_" 	=> 0.65,
	"_UCPUBLICATION_" => 0.74,
	"_CAPPUBLICATION_"	=> 0.7,
	"_CHAPTER_" 	=> 0.8,
	"_VOLUME_" 	=> 0.8,
	"_ISSUE_" 	=> 0.8,
	"_PAGES_" 	=> 0.9,
	"_ANY_" 	=> 0.05,
	"_ISBN_"	=> 0.95,
	"_ISSN_"	=> 0.95,
	"_SPAGE_"	=> 0.8,
	"_EPAGE_"	=> 0.8,
	"_URL_"		=> 0.9,
);

=pod

=head1 METHODS

=over 4

=item $parser = Biblio::Citation::Parser::Standard-Enew()

The new() method creates a new parser.

=cut

sub new
{
	my($class) = @_;
	my $self = {};
	return bless($self, $class);
}

=pod

=item $reliability = Biblio::Citation::Parser::Standard::get_reliability($template)

The get_reliability method returns a value that acts as an indicator
of the likelihood of a template matching correctly. Fields such as
page ranges, URLs, etc, have high likelihoods (as they follow rigorous
patterns), whereas titles, publications, etc have lower likelihoods.

The method takes a template as a parameter, but you shouldn't really
need to use this method much.

=cut

sub get_reliability
{
	my( $template ) = @_;
	my $reliability = 0;
	foreach(keys %factors)
	{
		if ($template =~ /$_/)
		{
			while($template =~ /$_/)
			{
				$reliability += $factors{$_};
				$template =~ s/$_//;
			}
		}
	}
	return $reliability;
}

=pod

=item $concreteness = Biblio::Citation::Parser::Standard::get_concreteness($template)

As with the get_reliability() method, get_concreteness() takes
a template as a parameter, and returns a numeric indicator. In
this case, it is the number of non-field characters in the template.
The more 'concrete' a template, the higher the probability that
it will match well. For example, '_PUBLICATION_ Vol. _VOLUME_' is
a better match than '_PUBLICATION_ _VOLUME_', as _PUBLICATION_ is
likely to subsume 'Vol.' in the second case.

=cut

sub get_concreteness
{
	my( $template ) = @_;
	my $concreteness = 0;
	foreach(keys %factors)
	{
		$template =~ s/$_//g;
	}
	return length($template);
}

=pod

=item $string = Biblio::Citation::Parser::Standard::strip_spaces(@strings)

This is a helper function to remove spaces from all elements
of an array.

=cut

sub strip_spaces
{
	my(@bits) = @_;
	foreach(@bits) { s/^[[:space:]]*(.+)[[:space:]]*$/$1/;}
	return @bits;
}

=pod

=item $templates = Biblio::Citation::Parser::Standard::get_templates()

Returns the current template list from the Biblio::Citation::Parser::Templates
module. Useful for giving status lists.

=cut

sub get_templates
{
	return $Biblio::Citation::Parser::Templates::templates;
}

=pod

=item @authors = Biblio::Citation::Parser::Standard::handle_authors($string)

This (rather large) function handles the author fields of a reference.
It is not all-inclusive yet, but it is usably accurate. It can handle
author lists that are separated by semicolons, commas, and a few other
delimiters, as well as &, and, and 'et al'.

The method takes an author string as a parameter, and returns an array
of extracted information in the format '{family => $family, given =>
$given}'.

=cut

sub handle_authors
{
	my($authstr) = @_;

	my @authsout = ();
	$authstr =~ s/\bet al\b//;
	# Handle semicolon lists
	if ($authstr =~ /;/)
	{
		my @auths = split /[[:space:]]*;[[:space:]]*/, $authstr;
		foreach(@auths)
		{
			my @bits = split /[,[:space:]]+/;
			@bits = strip_spaces(@bits);
			push @authsout, {family => $bits[0], given => $bits[1]};
		}
	}
	elsif ($authstr =~ /^[[:upper:]\.]+[[:space:]]+[[:alnum:]]/)
	{
		my @bits = split /[[:space:]]+/, $authstr;
		@bits = strip_spaces(@bits);
		my $fam = 0;
		my($family, $given);
		foreach(@bits)
		{
			next if ($_ eq "and" || $_ eq "&" || /^[[:space:]]*$/);
			s/,//g;
			if ($fam)
			{
				$family = $_;
				push @authsout, {family => $family, given => $given};
				$fam = 0;
			}
			else
			{
				$given = $_;
				$fam = 1;
			}
		}
	}
	elsif ($authstr =~ /^.+[[:space:]]+[[:upper:]\.]+/)
	{
		# Foo AJ, Bar PJ
		my $fam = 1;
		my $family = "";
		my $given = "";
		my @bits = split /[[:space:]]+/, $authstr;
		@bits = strip_spaces(@bits);
		foreach(@bits)
		{
			s/[,;\.]//g;
			s/\bet al\b//g;
			s/\band\b//;
			s/\b&\b//;
			next if /^[[:space:]]*$/;
			if ($fam == 1)
			{
				$family = $_;
				$fam = 0;
			}
			else
			{
				$given = $_;
				$fam = 1;
				push @authsout, {family => $family, given => $given};

			}
		}
	}
	elsif ($authstr =~ /^.+,[[:space:]]*.+/ || $authstr =~ /.+\band\b.+/)
	{
		my $fam = 1;
		my $family = "";
		my $given = "";
		my @bits = split /[[:space:]]*,|\band\b|&[[:space:]]*/, $authstr;
		@bits = strip_spaces(@bits);
		foreach(@bits)
		{
			next if /^[[:space:]]*$/;
			if ($fam)
			{
				$family = $_;
				$fam = 0;
			}
			else
			{
				$given = $_;
				push @authsout, {family => $family, given => $given};
				$fam = 1;
			}
		}
	}
	elsif ($authstr =~ /^[[:alpha:][:space:]]+$/)
	{
		$authstr =~ /^([[:alpha:]]+)[[:space:]]*([[:alpha:]]*)$/;
		my $given = "";
		my $family = "";
		if (defined $1 && defined $2)
		{
			$given = $1;
			$family = $2;
		}
		if (!defined $2 || $2 eq "")
		{
			$family = $1;
			$given = "";
		}
		push @authsout, {family => $family, given => $given};
	}
	elsif( $authstr =~ /[[:word:]]+[[:space:]]+[[:word:]]?[[:space:]]*[[:word:]]+/)
	{
		my @bits = split /[[:space:]]+/, $authstr;
		my $rest = $authstr;
		$rest =~ s/$bits[-1]//;
		push @authsout, {family => $bits[-1], given => $rest};
	}
	else
	{

	}
	return @authsout;
}

=pod

=item %metadata = $parser-Extract_metadata($reference)

This is the key method in the Standard module, although it is not actually
called directly by users (the 'parse' method provides a wrapper). It takes
a reference, and returns a hashtable representing extracted metadata.

A regular expression map is present in this method to transform '_AUFIRST_',
'_ISSN_', etc, into expressions that should match them. The method then
finds the template which best matches the reference, picking the result that
has the highest concreteness and reliability (see above), and returns the
fields in the hashtable. It also creates the marked-up version, that is
useful for further formatting.

=cut

sub extract_metadata
{
	my($self, $ref) = @_;
	# Skip to the first Alpha char
	if ($ref !~ /^[[:digit:]]-X\.]+$/) { $ref =~ s/^[^[:alpha:]]+//; }
	$ref =~ s/[[:space:]\*]+$//;
	$ref =~ s/[[:space:]]{2}[[:space:]]+/ /g;
	$ref =~ s/^[[:space:]\*]*(.+)[[:space:]\*]*$/$1/;
	my %metaout = ();
	$metaout{ref} = $ref;

	$metaout{id} = [];
        # Pull out doi addresses
	if ($ref =~ s/doi:(.+)\b//)
	{
		push @{$metaout{id}}, "doi:$1";
	}
	if ($ref =~ s/((astro-ph|cond-mat|gr-qc|hep-ex|hep-lat|hep-ph|hep-th|math-th|nucl-ex|nucl-th|physics|quant-ph|math|nlin|cs)\/\d+\b)//)
	{
		push @{$metaout{id}}, "arxiv:$1";
	}
	my @specific_pubs =
	(
		# Put any specific publications in here
	);

	my $spec_pubs = "";
	if (scalar @specific_pubs > 0)
	{
 		$spec_pubs = join("|", @specific_pubs);
		$spec_pubs = "|".$spec_pubs;
	}

	my $initial_match = "(?:\\b[[:alpha:]]\\.|\\b[[:alpha:]]\\b)";
	my $name_match = "(?:(?:[[:alpha:],;&-]+)\\b)";
	my $conjs = "(?:\\s+und\\s+|\\s+band\\s+|\\s|,|&|;)";

	my %matches =
	(
		"_AUFIRST_"	=> "([[:alpha:]\.]+)",
		"_AULAST_"	=> "([[:alpha:]-]+)",
		"_ISSN_"	=> "([[:digit:]-]+)",
		"_AUTHORS_"	=> "((?:$initial_match|$name_match|$conjs)+?)",
		"_DATE_"	=> "([[:digit:]]{2}/[[:digit:]]{2}/[[:digit]]{2})",
		"_YEAR_" 	=> "([[:digit:]]{4})",
		"_TITLE_" 	=> "(.+?[a-zA-Z]+.+?)",
		"_SUBTITLE_" 	=> "(.+)",
		"_CHAPTER_"	=> "([[:digit:]]+)",
		"_UCTITLE_" 	=> "([^[:lower:]]+)",
		"_CAPTITLE_"	=> "([[:upper:]][^[:upper:]]+)",
		"_PUBLICATION_" => "([^0-9\(\);\"']{4,}$spec_pubs)",
		"_PUBLISHER_" => "(.+)",
		"_PUBLOC_" => "(.+)",
		"_EDITOR_" => "([[:alpha:]\\.,;\\s&-]+)",
		"_UCPUBLICATION_" => "([^[:lower:]]+)",
		"_CAPPUBLICATION_"	=> "([[:upper:]][^[:upper:]]+)",
		"_VOLUME_" 	=> "([[:digit:]]+)",
		"_ISSUE_" 	=> "([[:digit:]]+)",
		"_PAGES_" 	=> "([[:digit:]]+-{1,2}[[:digit:]]+?)",
		"_ANY_" 	=> "(.+?)",
		"_ISBN_"	=> "([[:digit:]X-]+)",
		"_ISSN_"	=> "([[:digit:]X-]+)",
		"_SPAGE_"	=> "([[:digit:]]+)",
		"_EPAGE_"	=> "([[:digit:]]+)",
		"_URL_"		=> "(((http(s?):\\/\\/(www\\.)?)|(\\bwww\\.)|(ftp:\\/\\/(ftp\\.)?))([-\\w\\.:\\/\\s]+)(\\/|\\.\\S+|#\\w+))",
	);


	my(@newtemplates) = ();
	foreach my $template (@$Biblio::Citation::Parser::Templates::templates)
	{
		$_ = $template;
		s/\\/\\\\/g;
		s/\(/\\\(/g;
		s/\)/\\\)/g;
		s/\[/\\\[/g;
		s/\]/\\\]/g;
		s/\./\\\./g;
		s/ /\[\[:space:\]\]+/g;
		s/\?/\\\?/g;
		foreach my $key (keys %matches)
		{
			s/$key/$matches{$key}/g;
		}
		$_ .= "[.]?";
		push @newtemplates,$_;
	}
	my $index = 0;
	my @vars = ();
	my @matchedvars = ();

	my $curr_conc = 0;
	my $curr_rel = 0;
	my $max_conc = 0;
	my $max_rel = 0;
	my $best_match = "";
	my $best_orig = "";
	foreach my $currtemplate (@newtemplates)
	{
		my $original = $Biblio::Citation::Parser::Templates::templates->[$index];
		if ($ref =~ /^$currtemplate$/)
		{
			$curr_rel = get_reliability($original);
			$curr_conc = get_concreteness($original);
			if ($curr_rel > $max_rel)
			{
				$best_match = $currtemplate;
				$best_orig = $original;
				$max_conc = $curr_conc;
				$max_rel = $curr_rel;
			}
			elsif ($curr_rel == $max_rel && $curr_conc > $max_conc)
			{
				$best_match = $currtemplate;
				$best_orig = $original;
				$max_conc = $curr_conc;
				$max_rel = $curr_rel;
			}
		}
		$index++;
	}

	$metaout{match} = $best_orig;
	@vars = ($best_orig =~ /_([A-Z]+)_/g);
	@matchedvars = ($ref =~ /^$best_match$/);

	$index = 0;
	if (scalar @matchedvars > 0)
	{
		foreach(@vars)
		{
			$matchedvars[$index] =~ s/^\s*(.+)\s*$/$1/;
			$metaout{lc $_} = $matchedvars[$index];
			$index++;
		}
	}
	foreach(keys %metaout)
	{
		if (/^uc/)
		{
			my $alt = $_;
			$alt =~ s/^uc//;
			if (!defined $metaout{$alt} || $metaout{$alt} eq "")
			{
				$metaout{$alt} = $metaout{$_};
			}
		}
	}

	# Create a marked-up version
	my $in_ref = $ref;
	my $in_tmp = $best_orig;
	my $in_tmp2 = $best_orig;
	foreach(keys %metaout)
	{
		next if (!defined $metaout{$_} || $metaout{$_} eq "" || $_ eq "any");
		my $toreplace = "_".(uc $_)."_";
		$in_tmp =~ s/$toreplace/<$_>$metaout{$_}<\/$_>/g;
		$in_tmp2 =~ s/$toreplace/$metaout{$_}/g;
	}

	# Fix any _ANY_s
	$in_tmp2 =~ s/\\/\\\\/g;
	$in_tmp2 =~ s/\(/\\\(/g;
	$in_tmp2 =~ s/\)/\\\)/g;
	$in_tmp2 =~ s/\[/\\\[/g;
	$in_tmp2 =~ s/\]/\\\]/g;
	$in_tmp2 =~ s/\./\\\./g;
	$in_tmp2 =~ s/ /\[\[:space:\]\]+/g;
	$in_tmp2 =~ s/\?/\\\?/g;
	$in_tmp2 =~ s/_ANY_/(.+)/g;
	my(@anys) = ($in_ref =~ /$in_tmp2/g);

	foreach(@anys)
	{
		$in_tmp =~ s/_ANY_/$_<\/any>/;
	}
	$metaout{marked} = $in_tmp;
	# Map to OpenURL
	if (defined $metaout{authors})
	{
		$metaout{authors} = [handle_authors($metaout{authors})];
		$metaout{aulast} = $metaout{authors}[0]->{family};
		$metaout{aufirst} = $metaout{authors}[0]->{given};
	}
	if (defined $metaout{publisher} && !defined $metaout{publication})
	{
		$metaout{genre} = "book";
	}
	$metaout{atitle} = $metaout{title};
	$metaout{title} = $metaout{publication};
	if (defined $metaout{cappublication}) { $metaout{title} = $metaout{cappublication} };
	$metaout{date} = $metaout{year};
	return %metaout;

}

=pod

=item $metadata = $parser-Eparse($reference);

This method provides a wrapper to the extract_metadata
function. Simply pass a reference string, and a metadata
hash is returned.

=cut

sub parse
{
	my($self, $ref) = @_;
	my $hashout = {$self->extract_metadata($ref)};
	return $hashout;
}

1;

__END__