File Coverage

blib/lib/Astro/Bibcode.pm

Criterion	Covered	Total	%
statement	178	204	87.2
branch	64	104	61.5
condition	7	12	58.3
subroutine	27	29	93.1
pod	14	14	100.0
total	290	363	79.8

package Astro::Bibcode;

=head1 NAME

Astro::Bibcode - Parse standardised astronomical journal bibcode

=head1 SYNOPSIS

  use Astro::Bibcode;
  $bib = new Astro::Bibcode( '2002MNRAS.336...14J' );

  print $bib->journal(),"\n";
  print $bib->volume(),"\n";
  print $bib->year(),"\n";

=head1 DESCRIPTION

This module parses a standardised astronomical journal bibcode (see
references at end of this documentation) and allows the individual
parts to be extracted.

=cut

use 5.006;
use strict;
use warnings;
use warnings::register;
use Carp;

use vars qw/ $VERSION /;
$VERSION = sprintf("%d.%03d", q$Revision: 0.3 $ =~ /(\d+)\.(\d+)/);

# Some lookup tables

# Standard Classification codes
my %CLASS = (
	     B => 'textbook',
	     C => 'catalog',
	     M => 'digited version',
	     P => 'preprint',
	     R => 'report or conference proceedings',
	     T => 'thesis',
	     U => 'unpublished',
	    );

# Note that ADS seems to use the following classifications:
#  conf   Conference
#  book   Book
#  work   Workshop
#  symp   Symposium
#  rept   Reports
#  meet   Meeting
my %CLASS_ADS = (
		 proc => 'conference proceeding', # Alias for "conf"
		 book => 'book',
		 work => 'workshop',
		 conf => 'conference proceeding',
		 symp => 'symposium',
		 rept => 'report',
		 meet => 'meeting',
		);

# These are populated dynamically as required

# Normal standardised Journal lookup
my %JOURNALS;

# ADS conference proceedings lookup
my %CONF_ADS;


=head1 METHODS

=head2 Constructor

=over 4

=item B

Create a new C object. This constructor
can be called in a number of ways.

If a single argument is provided it is assumed to be a bibcode.
This code will be parsed, if the parse fails the object will not
be created.

  $bib = new Astro::Bibcode( '1995MNRAS.276.1024J' );

THE REST OF THIS SECTION IS PROPOSED INTERFACE AND IS NOT IMPLEMENTED

If it is called without arguments an empty object will be
created. Further calls to the C method or the individual
components will be required to configure the object.

  $bib = new Astro::Bibcode;


If a series of hash arguments are provided, the object will
be configured by calling the individual accessors in turn.

  $bib = new Astro::Bibcode( journalcode => 'ApJ',
                             year => 2002,
                           );

NOTE THAT BIBCODE CREATION IS NOT YET IMPLEMENTED

=cut

sub new {
  my $proto = shift;
  my $class = ref($proto) || $proto;

  # Create object
  my $bib = bless {
		   BIBCODE => undef,
		   YEAR => undef,
		   JOURNALCODE => undef,
		   CLASSFLAG => undef,
		   VOLUME => undef,
		   MISC => undef,
		   PAGE => undef,
		   INITIAL => undef,
		   CONFCODE => undef,
                  }, $class;

  if (@_) {
    # if we have one code it's a bibcode
    if (scalar(@_) == 1) {
      my $retval = $bib->bibcode( $_[0] );

      # if bibcode method returned undef (error in parse)
      # set the object to undef to indicate error
      $bib = undef unless defined $retval;
    } else {
      my %args = @_;

      # loop over known important methods
      for my $k (qw| year journalcode classflag volume page initial misc |) {
	$bib->$k($args{$k}) if exists $args{$k};
      }

    }

  }

  return $bib;
}

=back

=head2 Accessor Methods

=over 4

=item B

Returns the bibcode associated with this object. It will be generated
from the other object attributes if undefined (which it will be after
something in the object has changed).

  $bib->bibcode( '1998adass...7..216J' );
  $code = $bib->bibcode;

Can return undef if the bibcode did not pass verification (see
C).

=cut

sub bibcode {
  my $self = shift;
  if (@_) {
    my $code = shift;
    # Verify and store
    my %parts = $self->verify_bibcode( $code );

    # if we did not get any result; store undef and return
    if (!keys %parts) {
      $self->{BIBCODE} = undef;
      return;
    }

    # We did get some data. Configure the rest of the object
    # to match. Note that we do not go through the accessors
    # since they may well be configured to clear the bibcode
    # if they are modified and we would end up with recursion
    $self->{YEAR} = $parts{year};
    $self->{VOLUME} = $parts{volume};
    $self->{JOURNALCODE} = $parts{journalcode};
    $self->{CLASSFLAG} = $parts{classflag};
    $self->{MISC} = $parts{misc};
    $self->{PAGE} = $parts{page};
    $self->{INITIAL} = $parts{initial};

    $self->{BIBCODE} = $self->verify_bibcode( $code );

    return $self->{BIBCODE};
  } else {
    # if no bibcode is defined, attempt to generate one from the object
    if (! defined $self->{BIBCODE} ) {
      $self->_construct_bibcode();
    }
  }
  return $self->{BIBCODE};
}

=item B

Year of publication.

 $year = $bib->year;

=cut

sub year {
  my $self = shift;
  return $self->{YEAR};
}

=item B

The Journal code associated with this bib code.

For the current list of journal codes see:

  http://simbad.u-strasbg.fr/simjnl.pl

See the C method in order to translate this code to a full
journal name.

  $jcode = $bib->journalcode;

=cut

sub journalcode {
  my $self = shift;
  return $self->{JOURNALCODE};
}


=item B

Classification flag of this bib code.
Current allowed values are:

     B textbook
     C catalog
     M digited version
     P preprint
     R report or conference proceedings
     T thesis
     U unpublished

and also from ADS:

     book => 'book'
     work => 'workshop'
     conf => 'conference proceeding'
     symp => 'symposium'
     rept => 'report'
     meet => 'meeting'

Note that a null string is used to indicate a periodical.

 $code = $bib->classflag;

See the C method for the translation.

=cut

sub classflag {
  my $self = shift;
  return $self->{CLASSFLAG};
}

=item B

Volume number.

=cut

sub volume {
  my $self = shift;
  return $self->{VOLUME};
}

=item B

Value of the miscellaneous field "M" used to remove ambiguity.

=cut

sub misc {
  my $self = shift;
  return $self->{MISC};
}

=item B

Page number.

=cut

sub page {
  my $self = shift;
  return $self->{PAGE};
}

=item B

Either the first initial of the first author's last name,
or ":" for no author. Also can be "%" to indicate that some
of the other fields may be invalid.

=cut

sub initial {
  my $self = shift;
  return $self->{INITIAL};
}

=back

=head2 General Methods

=over 4

=item B

Retrieve the full journal name.

 $journal = $bib->journal;

Returns the code if the code can not be translated.

Does try to recognize ADS conference codes.

=cut

sub journal {
  my $self = shift;
  my $jcode = $self->journalcode; # Journal lookup
  my $confcode = $self->confcode; # Conference lookup

  # first time through, populate the journal lookup
  $self->_populate_journals() unless keys %JOURNALS;

  # Is it in the journal list?
  if (exists $JOURNALS{$jcode}) {
    # Straight journal lookup
    return $JOURNALS{$jcode};
  } elsif (defined $confcode) {
    # It is a conference
    return $CONF_ADS{$confcode};
  } else {
    # do not know
    return $jcode;
  }
}

=item B

Retrieve the full name associated with the classification flag.

 $class = $bib->class;

Returns undef if no name can be translated.

=cut

sub class {
  my $self = shift;
  my $flag = $self->classflag;

  # in some cases a "periodical" style bibcode can actually be associated
  # with a conference. Check this by looking to see if confcode is true
  my $confcode = $self->confcode;

  # if confcode is defined but flag is not, we are really a recurring "conf"
  return "recurring conference" if defined $confcode && !$flag;

  # Sometimes a blank classflag simply means that ADS is lying...
  # rather than it being a "periodical"
  if (!length($flag)) {
    my $journal = $self->journal;
    if ($journal =~ /thesi/i) {
      # it is really a thesis
      return "thesis";
    } else {
      # no hint - use periodical
      return "periodical";
    }
  }

  if (exists $CLASS{$flag}) {
    return $CLASS{$flag};
  } elsif (exists $CLASS_ADS{$flag}) {
    return $CLASS_ADS{$flag};
  }
  return undef;
}

=item B

Returns the ADS conference code associated with this bibcode.
Returns undef if this bibcode is not associated with a conference.

  $confcode = $bib->confcode;

In some cases (eg 2000immm.proc...77G), a "proc" classification
is used when the ADS standard seems to imply "conf" instead.
This is taken into account when returning the confcode.

=cut

sub confcode {
  my $self = shift;
  my $bibcode = $self->bibcode(); # For ADS conference proceedings translation

  # Force read of DATA segment
  $self->_populate_journals unless keys %CONF_ADS;

  my $confcode;
  if (exists $CONF_ADS{substr($bibcode,0,13)}) {
    # Now try an exact ADS match with the first 13 characters
    # This gives us the journal code
    $confcode = substr($bibcode,0,13);

  } elsif (exists $CONF_ADS{substr($bibcode,4,9)}) {
    # try ADS conference lookup without the year prefix
    $confcode = substr($bibcode,4,9);

  } elsif ($bibcode =~ /proc/) {
    # if we have a .proc see whether .conf matches anywhere
    my $c = $bibcode;
    $c =~ s/proc/conf/;
    if (exists $CONF_ADS{substr($c,0,13)}) {
      $confcode = substr($c,0,13);
    }
  }

  return $confcode;
}

=item B

Return a multi-line summary string describing the bibcode status.

 $text = $bib->summary;

=cut

sub summary {
  my $self = shift;
  my $str = '';

  my @keys = qw/ class journal year volume page /;

  # Find the max length of the key
  my $max = 0;
  for (@keys) {
    $max = length($_) if length($_) > $max;
  }

  for my $m (@keys) {
    my $data = $self->$m();
    $str .= sprintf("%-".$max."s : %s\n", ucfirst($m), $data);
  }
  return $str;
}

=item B

Given a bibcode, return false if the bibcode does not seem to be
valid (e.g. it is the wrong lenght, first 4 characters are not digits),
returns the bibcode in scalar context.

  $ok = $bib->verify_bibcode( '1999adass...8...11E' );

In list context returns a hash consisting of the constituent (untranslated)
parts of the bib code.

  %parts = $bib->verify_bibcode( '1998SPIE.3357..548J' );

Since ADS is prone to replacing & with & in Journal codes due to
HTML transport, this routine will reverse this.

Note that in some special cases a bibcode can be specified such
that it is known not to match all the rules (last character is a '%').
In such cases only the length of the bicode is checked.

=cut

sub verify_bibcode {
  my $self = shift;
  my $bibcode = shift;
  return unless defined $bibcode;

  # Fix HTML-ification
  $bibcode =~ s/&/&/;

  # Check length
  return unless length($bibcode) == 19;

  # Rather than one enormous pattern match, split the string
  # into fixed length chunks
  my $yyyy = substr($bibcode,0,4);
  my $jjjjj= substr($bibcode,4,5);
  my $vvvv = substr($bibcode,9,4);
  my $m    = substr($bibcode,13,1);
  my $pppp = substr($bibcode,14,4);
  my $a    = substr($bibcode,18,1);

  # Verify each component and store in hash
  my %parts;

  # Note that ADS conference proceeding extensions are still valid bibcodes
  $parts{year} = $self->_verify_year( $yyyy );
  $parts{journalcode} = $self->_verify_journalcode( $jjjjj );

  my ($class, $vol) = $self->_verify_volume( $vvvv );
  $parts{volume} = $vol;
  $parts{classflag} = $class;

  $parts{misc} = $self->_verify_misc( $m );
  $parts{page} = $self->_verify_page( $pppp );
  $parts{initial} = $self->_verify_initial( $a );


  # Ordinarily we would return if any of the values in the hash
  # are undef. There is a special case if $a is "%" since this
  # indicates that some of them may not match. In this case
  # we do what we can.

  if ($a ne "%") {
    for my $v (values %parts) {
      return unless defined $v;
    }
  }

  # Return the answer
  if (!wantarray) {
    return $bibcode;
  } else {
    return %parts;
  }
}

=back

=begin PRIVATE__METHODS

Internal routines which may change and should not be used in external
classes.

These are methods, although there is no expectation that subclasses
will be required.

=over 4

=item B<_construct_bibcode>

=cut

sub _construct_bibcode {
  my $self = shift;

  Carp::confess "Bibcode construction is not yet implemented. It may be hard.";

}

=item B<_verify_year>

Check the year looks okay, return false if it does not, the year
if it looks okay.

=cut

sub _verify_year {
  my $self = shift;
  my $year = shift;
  return (($year =~ /^\d{4}$/) ? $year : () );
}

=item B<_verify_journalcode>

Check that the journal code looks okay. Returns the code if okay,
false otherwise.

Does not check to see if the journal code can be translated.

Trailing dots are removed from the input string.

=cut

sub _verify_journalcode {
  my $self = shift;
  my $jcode = shift;

  # Clean the string
  $jcode = _clean_string($jcode, 'L');

  # Just make sure we have A-Z and &
  return ( ( $jcode =~ /^[A-Za-z&]+$/) ? $jcode : () );
}

=item B<_verify_volume>

Check that the volume and class are okay.

In scalar context returns the verified string (with leading
dots removed).

  ($class, $volume) = $bib->_verify_volume( $v );
  $v = $bib->_verify_volume($v);

In list context returns two values. First is the classification
flag (blank string for a periodical), second is the volume number
(leasing zeroes removed).

Note that since ADS does not seem to use the classification
code as presented in the reference documentation, this is a bit
of a hack (eg a Thesis would be expected to have class = T but
instead simply uses PhDT in the journal name and not the university).

This means that a blank volume and class are okay and the
class needs to be hacked in higher up.

=cut

sub _verify_volume {
  my $self = shift;
  my $vol = shift;

  # Second character is important so we need to get that before
  # cleaning
  my $second = substr($vol,1,1);


  # Clean the string
  $vol = _clean_string( $vol, 'R' );

  # empty is okay [need to guess later on]
  return (wantarray ? ('', '') : $vol) unless $vol;

  # Get standard classification codes
  my $classes = join( "", keys %CLASS);

  # Get adass codes and form a pattern match string
  my $adsmatch = join("|",keys %CLASS_ADS);

  # Either we are all numbers
  if ($vol =~ /^\d+$/) {
    # periodical. Test calling context
    return (wantarray ? ('',$vol) : $vol );
  } elsif ($vol =~ /([$classes])(\d\d)$/) {
    # We are a classification other than a published journal
    # with multi-volume
    my $c = $1;
    my $num = $2;
    # strip leading zero
    $num =~ s/^0+//g;

    # return the result (checking for context)
    return (wantarray ? ($c, $num) : $vol);

  } elsif ($second =~ /^([$classes])$/) {
    my $class = $1;
    return (wantarray ? ($class, '') : $vol );
  } elsif ($vol =~ /^($adsmatch)$/) {
    return (wantarray ? ($1, '') : $vol);
  }
  # bad code
  return;
}

=item B<_verify_misc>

Verify the misc field which is used to break ambiguity.

 L     letter section in periodical
 p     pink MNRAS pages
 a-z   issue number in same volume
 A-K   issue designations within same volume
 Q-Z   articles on same page
 A-Z   For theses, first initial of author
 E     "ephemeral". These are temporary bibcodes
       submitted prior to publication [ADS-specific]

Fundamentally, any letter matches or a ".".

To be truly accurate the verification requires the
journal name and classification flag.

=cut

sub _verify_misc {
  my $self = shift;
  my $m = shift;

  # a . is fine
  return "" if $m eq ".";

  # Now pattern match
  return ( ($m =~ /^[A-Za-z]$/) ? $m : ());
}


=item B<_verify_page>

Verifies the page number. Returns the page number with leading "."
removed. Returns false on error.

=cut

sub _verify_page {
  my $self = shift;
  my $page = shift;
  $page = _clean_string( $page, 'R');
  return (($page =~ /^\d+$/) ? $page : () );
}

=item B<_verify_initial>

Check that the initial is valid. In addition to letters,
':' indicates that there is no author, '%' indicates that
the code may be dodgy.

=cut

sub _verify_initial {
  my $self = shift;
  my $i = shift;
  return ( ($i =~ /^[A-Za-z:%]$/) ? $i : () );
}

=item B<_populate_journals>

Populate the internal journal code to journal name lookup table.

Also populates the ADS conference proceedings table.

=cut

sub _populate_journals {
  my $self = shift;

  # Buffer for concatenating journals that go over a single line
  my $jbuff = '';

  # Current journal code in "scope"
  my $current;

  # Read from data handle
  while (my $line = ) {
    next if $line =~ /^\#/;

    # This means we are at the end of the journals
    last if $line =~ /^=cut/;

    # Code is first 7 characters
    my $code = substr($line,0,7);
    $code =~ s/\s+$//;

    # Get the translation. Remove newline. remove trailing and leading space
    my $fullname = substr($line,7);
    chomp($fullname);
    $fullname =~ s/^\s+//;
    $fullname =~ s/\s+$//;

    # Do we have a code? If yes, clear previous buffer
    if (length($code)) {
      # Update the new current value
      my $old = $current;
      $current = $code;

      # if we have a previous entry, store it and reset the buffers
      $JOURNALS{$old} = $jbuff if ($old && $jbuff);
      $jbuff = '';

    }

    # Append to buffer, making sure we have a space if concatenating
    $jbuff .= " " if $jbuff;
    $jbuff .= $fullname;

  }

  # Leftover
  $JOURNALS{$current} = $jbuff if ($current && $jbuff);

  # Now try to populate the ADS lookup (if we have it in DATA
  # ADS bibcode is first 13 characters
  while (my $line = ) {
    next if $line =~ /^\#/;
    next if length($line) < 14;
    my $bcode = substr($line,0,13);
    my $conf  = substr($line,14);
    chomp($conf);
    $conf =~ s/^\s+//;
    $CONF_ADS{$bcode} = $conf;
  }

  return;
}

=back

=end PRIVATE__METHODS

=cut

# Really really private helper subs

# This subroutine cleans the supplied bibcode substring
# Remove "spaces" from the string (ie ".")

# Arg 1: The substring
# Arg 2: Justification for the string "L" or "R"

sub _clean_string {
  my $str = shift;
  my $j = uc(shift);

  if ($j eq 'L') {
    $str =~ s/\.+$//g;
  } elsif ($j eq 'R') {
    $str =~ s/^\.+//g;
  } else {
    croak "Internal error: Justification string was '$j' not L or R";
  }
  return $str;
}



=head1 REFERENCES

Details on the bibcode standard can be obtained from

 http://cdsweb.u-strasbg.fr/simbad/refcode.html

A complete description of the reference coding has been published as a
chapter of the book "Information & On-Line Data in Astronomy", 1995,
D. Egret and M. A. Albrecht (Eds), Kluwer Acad. Publ.

ADS seems to use non-standard bibcodes for meetings and conferences:

  http://adsabs.harvard.edu/abs_doc/conferences.html

ADS Journal codes are here:

  http://adsabs.harvard.edu/abs_doc/all_journals.html

but are not currently used.

=head1 NOTES

Currently the lookup tables for the journal translation and ADS conference
proceedings are embedded in the module. There is no facility for triggering
a remote update from the referenced web sites or for easily updating a
configuration file as new codes are issued. This will probably change in
future releases.

=head1 AUTHOR

Tim Jenness [e-mail]

=head1 COPYRIGHT

Copyright (C) 2004 Tim Jenness and the Particle Physics and
Astronomy Research Council.

This program 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.

This program 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
this program; if not, write to the Free Software Foundation, Inc., 59 Temple
Place,Suite 330, Boston, MA  02111-1307, USA

=head1 SEE ALSO

L

=cut

1;

# Note that some entries have been added that were not found on
# the CDS list but were found in some papers on ADS
#
#   OLEB
#
__DATA__