File Coverage

blib/lib/Biblio/Refbase.pm

Criterion	Covered	Total	%
statement	258	315	81.9
branch	75	132	56.8
condition	17	42	40.4
subroutine	58	60	96.6
pod	16	16	100.0
total	424	565	75.0

package Biblio::Refbase;

use 5.006;

use strict;
use warnings;

our $VERSION = '0.04';

$VERSION = eval $VERSION;

use Carp;
use HTTP::Request::Common;
use HTTP::Status ':constants';
use LWP::UserAgent;
use URI;
use URI::QueryParam;

use constant REFBASE_LOGIN            => 'user_login.php';
use constant REFBASE_IMPORT           => 'import_modify.php';
use constant REFBASE_SHOW             => 'show.php';
use constant REFBASE_ERROR            => 'error.php';

use constant REFBASE_DEFAULT_URL      => 'http://localhost/';
use constant REFBASE_DEFAULT_USER     => '[e-mail]';
use constant REFBASE_DEFAULT_PASSWORD => 'start';
use constant REFBASE_DEFAULT_RELOGIN  => 1;
use constant REFBASE_DEFAULT_FORMAT   => 'ASCII';

use constant REFBASE_MSG_NO_HITS      => 'Nothing found';
use constant REFBASE_MSG_FORBIDDEN    => 'you have no permission';
use constant REFBASE_MSG_ERROR        => 'The following error occurred';
use constant REFBASE_MSG_QUERY_ERROR  => 'Your query:';

use constant REFBASE_EXPORT_FORMATS => (
  'ADS',
  'Atom XML',
  'BibTeX',
  'Endnote',
  'ISI',
  'MODS XML',
  'OAI_DC XML',
  'ODF XML',
  'RIS',
  'SRW_DC XML',
  'SRW_MODS XML',
  'Word XML',
);

use constant REFBASE_CITATION_FORMATS => (
  'ASCII',
  'HTML',
  'LaTeX',
  'LaTeX .bbl',
  'Markdown',
  'PDF',
  'RTF',
);

use constant REFBASE_CITATION_STYLES => (
  'APA',
  'AMA',
  'MLA',
  'Chicago',
  'Harvard 1',
  'Harvard 2',
  'Harvard 3',
  'Vancouver',
  'Ann Glaciol',
  'Deep Sea Res',
  'J Glaciol',
  'Mar Biol',
  'MEPS',
  'Polar Biol',
  'Text Citation',
);

use constant REFBASE_QUERY_PARAMS => (
  'author',
  'title',
  'type',
  'year',
  'publication',
  'abbrev_journal',
  'keywords',
  'abstract',
  'thesis',
  'area',
  'notes',
  'location',
  'serial',
  'date',
  'contribution_id',
  'where',
);



#
#  constructor
#

sub new {
  my $class = shift;
  unshift @_, 'url' if @_ % 2;
  my %conf = @_;

  my $self = bless {}, $class;

  for (qw'url user password relogin format style order rows records ua') {
    if (defined(my $value = delete $conf{$_})) {
      $self->$_($value);
    }
  }

  my $version = eval '$' . $class . '::VERSION';
  my $client = 'cli-' . join '-', split /::/, $class;
  $client .= '-' . $version if defined $version;
  $self->{_client} = $client;

  unless ($self->ua) {
    unless (defined $conf{agent}) {
      my $agent = $class;
      $agent .= ' ' . $version if defined $version;
      $conf{agent} = $agent;
    }
    $conf{env_proxy} = 1 unless exists $conf{env_proxy};
    $self->ua(LWP::UserAgent->new(%conf));
  }

  return $self;
}



#
#  accessors
#

sub url {
  shift->_accessor('url', @_);
}

sub user {
  shift->_accessor('user', @_);
}

sub password {
  shift->_accessor('password', @_);
}

sub relogin {
  shift->_accessor('relogin', @_);
}

sub format {
  my $self = shift;
  if (@_) {
    my $format = shift;
    _check_format($format);
    $self->{format} = $format;
    return $self;
  }
  $self->{format};
}

sub style {
  my $self = shift;
  if (@_) {
    my $style = shift;
    _check_style($style);
    $self->{style} = $style;
    return $self;
  }
  $self->{style};
}

sub order {
  shift->_accessor('order', @_);
}

sub rows {
  shift->_accessor('rows', @_);
}

sub records {
  shift->_accessor('records', @_);
}

sub ua {
  my $self = shift;
  if (@_) {
    my $ua = shift;
    croak q{Accessor 'ua' requires an object based on 'LWP::UserAgent'}
      unless ref $ua and $ua->isa('LWP::UserAgent');
    $self->{ua} = $ua;
    return $self;
  }
  $self->{ua};
}



#
#  public instance methods
#

sub search {
  my $self = shift;
  my %args = @_;

  my $account = $self->_account_args(\%args);
  my $search  = $self->_search_args(\%args);

  if (%args) {
    croak q{Unknown arguments provided to 'search' method:}
      . join("\n    ", '', sort keys %args) . "\n";
  }

  return $self->_search($account, $search);
}

sub upload {
  my $self = shift;
  unshift @_, 'content' if @_ % 2;
  my %args = @_;

  my $account = $self->_account_args(\%args);
  my $upload  = $self->_upload_args(\%args);

  my $show = delete $args{show};
  $show = %args unless defined $show;

  my $search = $self->_search_args(\%args);

  if (%args) {
    croak q{Unknown arguments provided to 'upload' method:}
      . join("\n    ", '', sort keys %args) . "\n";
  }

  my $url = $account->{url} . REFBASE_IMPORT;

  my $request = $upload->{uploadFile}
    ? POST $url, Content_Type => 'form-data', Content => $upload
    : POST $url, $upload;

  my $response = $self->_request($account, $request);

  unless ($response->is_error) {
    if (defined(my $location = $response->header('location'))) {
      if ($location =~ /^(${\REFBASE_SHOW}\?)/o) {
        my $q = URI->new($location)->query_form_hash;
        my ($rows) = ($q->{headerMsg} || '') =~ /(\d+)/;
        my $records = $q->{records} || '';
        if ($show) {
          $search->{records} ||= $q->{records};
          $search->{rows} ||= $rows;
          $response = $self->_search($account, $search);
        }
        else {
          my $content = $q->{headerMsg} ? $q->{headerMsg} . ' ' : '';
          $content   .= $q->{records}  if $q->{records};
          $response->code(HTTP_OK);
          $response->message('');
          $response->content($content);
        }
        $response->records($records)->rows($rows);
      }
      else {
        $response->code(HTTP_NOT_IMPLEMENTED);
        $response->message('Unexpected redirect location');
      }
    }
    elsif (index(${$response->content_ref}, scalar REFBASE_MSG_FORBIDDEN) == 0) {
      $response->code(HTTP_FORBIDDEN);
      $response->message('');
    }
    else {
      $response->code(HTTP_NOT_IMPLEMENTED);
      $response->message('Unexpected response');
    }
  }
  return $response
}

sub ping {
  my $self = shift;
  unshift @_, 'url' if @_ % 2;

  # use 'simple_request' instead of 'head' so redirections won't be followed
  # thus a redirection (e.g. to error page) will fail, too
  return $self->ua->simple_request(
    HEAD $self->_account_args({ @_ })->{url}
  )->is_success;
}



#
#  public static methods
#

sub formats {
  return sort +REFBASE_CITATION_FORMATS, REFBASE_EXPORT_FORMATS;
}

sub styles {
  return sort +REFBASE_CITATION_STYLES;
}



#
#  static fields and helper functions
#

# format and style mappings/parameters in static fields

my %_formats = map {
  _normalize_format_name($_) => {
    exportFormat => $_,
    submit       => 'Export',
    exportType   => 'file'
  }
} REFBASE_EXPORT_FORMATS;

for (REFBASE_CITATION_FORMATS) {
  $_formats{_normalize_format_name($_)} = {
    citeType => $_ ,
    submit   => 'Cite'
  };
}

my %_styles = map {
  _normalize_style_name($_) => $_
} REFBASE_CITATION_STYLES;

# storage for user sessions

my %_sessions;

# normalization functions for format and style names

sub _normalize_format_name {
  (my $name = lc shift) =~ s/\s+xml$//;
  $name =~ s/ \./_/;
  return $name;
}

sub _normalize_style_name {
  (my $name = lc shift) =~ s/\s+//g;
  return $name;
}

# functions for checking format and style and getting parameters

sub _check_format {
  my $name = shift;
  return unless defined $name and length $name;
  if (defined(my $format = $_formats{_normalize_format_name($name)})) {
    return $format;
  }
  croak "Format '$name' not available.\n"
    . 'Available formats:'
    . join("\n    ", '', formats()) . "\n";
}

sub _check_style {
  my $name = shift;
  return unless defined $name and length $name;
  if (defined(my $style = $_styles{_normalize_style_name($name)})) {
    return $style;
  }
  croak "Citation style '$name' not available.\n"
    . 'Available styles:'
    . join("\n    ", '', styles()) . "\n";
}



#
#  private instance methods
#

# accessor helper method

sub _accessor {
  my $self = shift;
  my $field = shift;
  if (@_) {
    $self->{$field} = shift;
    return $self;
  }
  return $self->{$field};
}

# perform a search query

sub _search {
  my ($self, $account, $param) = @_;

  my $request = POST $account->{url} . REFBASE_SHOW, $param;
  my $response = $self->_request($account, $request, 1);

  if ($response->is_success) {
    # idea: could parse number of hits from content when using ASCII format
    # or explicitly re-send query with format=ASCII and rows=1
    # then set $response->rows, too!
    $response->hits(index(${$response->content_ref}, scalar REFBASE_MSG_NO_HITS) == 0 ? 0 : 1);
  }
  return $response;
}

# HTTP request and error handling

sub _request {
  my ($self, $account, $request, $redirect) = @_;
  my $relogin = $account->{relogin};
  my $failed = 0;
  {
    # catch possible login failure
    eval { $request->header( cookie => $self->_session($account) ) };
    my $response = $@ ? $@ : $self->ua->simple_request($request);

    if (defined(my $location = $response->header('location'))) {
      if ($location =~ /^${\REFBASE_LOGIN}(\?|$)/o) {
        # handle redirection to login page

        # undefine stored session string
        $self->_session($account, undef);

        if ($relogin > $failed++) {
          redo;
        }
        elsif ($relogin < 1) {
          $response->code(HTTP_REQUEST_TIMEOUT);
          $response->message('Relogin required but disabled');
        }
        else {
          $response->code(HTTP_UNAUTHORIZED);
          $response->message("Relogin failed (tried $relogin times)");
        }
      }
      elsif ($location =~ /^${\REFBASE_ERROR}(\?|$)/o) {
        # turn redirection to error page into HTTP error
        my $q = URI->new($location)->query_form_hash;
        my $content = $q->{headerMsg} ? $q->{headerMsg} . ' ' : '';
        $content   .= $q->{errorMsg} if $q->{errorMsg};
        $response->code(HTTP_INTERNAL_SERVER_ERROR);
        $response->message('');
        $response->content($content);
      }
      elsif ($redirect) {
        # follow the redirection with redirect count subtracted by 1
        return $self->_request($account, GET($account->{url} . $location), $redirect - 1);
      }
    }
    elsif ($response->is_success) {
      if (index(${$response->content_ref}, scalar REFBASE_MSG_ERROR) == 0) {
        # inconsistency in refbase: POST to show.php in search method
        # does not return redirection to error.php when MySQL database fails
        $response->code(HTTP_INTERNAL_SERVER_ERROR);
        $response->message('');
      }
      elsif (index(${$response->content_ref}, scalar REFBASE_MSG_QUERY_ERROR) == 0) {
        # inconsistency in refbase: GET from search.php (redirected by a POST)
        # does not return redirection to error.php when SQL query is broken
        $response->code(HTTP_BAD_REQUEST);
        $response->message('');
      }
    }
    return bless $response, 'Biblio::Refbase::Response';
  }
}

# user authentication, session handling and relogin

sub _session {
  my $self = shift;
  my $account = shift;
  my $url  = $account->{url};
  my $user = $account->{user};
  if (@_) {
    $_sessions{$url}->{$user} = shift;
    return $self;
  }
  unless ($_sessions{$url}->{$user}) {
    my $response = $self->ua->simple_request(POST $url . REFBASE_LOGIN, {
      loginEmail    => $user,
      loginPassword => $account->{password},
    });
    if ($response->is_redirect and my $cookie = $response->header('set-cookie')) {
      $_sessions{$url}->{$user} = (split /;/, $cookie)[0];
    }
    else {
      unless ($response->is_error) {
        $response->code(HTTP_UNAUTHORIZED);
        $response->message('Login request denied');
        # wipe out HTML page
        $response->content('');
      }
      # raise an exception
      die $response;
    }
  }
  return $_sessions{$url}->{$user};
}

# setup account configuration from arguments hash, dynamic and static defaults

sub _account_args {
  my ($self, $args) = @_;

  my $url = delete $args->{url} || $self->url || REFBASE_DEFAULT_URL;
  $url .= '/' if substr($url, -1) ne '/';
  $url = 'http://' . $url unless $url =~ m{^https?://};

  my $relogin = delete $args->{relogin};
  $relogin = $self->relogin unless defined $relogin;
  $relogin = defined $relogin && $relogin =~ /(\d+)/ ? int $1 : REFBASE_DEFAULT_RELOGIN;

  return {
    url      => $url,
    user     => delete $args->{user}     || $self->user     || REFBASE_DEFAULT_USER,
    password => delete $args->{password} || $self->password || REFBASE_DEFAULT_PASSWORD,
    relogin  => $relogin,
  };
}

# mapping of module's argument names to refbase names

my %_names = (
  records => 'records',
  order   => 'citeOrder',
  rows    => 'showRows',
  start   => 'startRecord',
  query   => 'queryType',
  view    => 'viewType',
);

# setup search parameters from arguments hash, dynamic and static defaults

sub _search_args {
  my ($self, $args) = @_;
  my %param;

  for (REFBASE_QUERY_PARAMS) {
    if (defined(my $value = delete $args->{$_})) {
      $param{$_} = $value;
    }
  }
  $param{serial} = '.+' unless %param;

  my $format = $self->_format(delete $args->{format});
  @param{keys %$format} = values %$format;

  if (not exists $args->{style} or defined(my $style = delete $args->{style})) {
    if (defined($style = $self->_style($style))) {
      $param{citeStyle} = $style;
    }
  }

  for (qw'records order rows') {
    if (my $value = delete $args->{$_} || $self->$_) {
      $param{$_names{$_}} = $value;
    }
  }
  for (qw'start query view') {
    if (my $value = delete $args->{$_}) {
      $param{$_names{$_}} = $value;
    }
  }

  if (delete $args->{showquery}) {
    $param{showquery} = 1;
  }
  if (defined(my $showlinks = delete $args->{showLinks})) {
    $param{showLinks} = 0 if $showlinks eq '0';
  }
  $param{client} = $self->{_client};

  return \%param;
}

# setup upload parameters from arguments hash, dynamic and static defaults

sub _upload_args {
  my ($self, $args) = @_;
  my %param;

  if (defined(my $content = delete $args->{content})) {
    $param{uploadFile} = [ undef, 'filename', Content => $content ];
    $param{formType} = 'import';
  }
  elsif (defined(my $source_ids = delete $args->{source_ids})) {
    $param{sourceIDs} = ref $source_ids eq 'ARRAY'
      ? join ' ', @$source_ids
      : $source_ids;
    $param{formType} = 'importID';
  }
  else {
    croak q{upload requires either record content supplied by parameter 'content' or }
        . q{a list of record IDs in parameter 'source_ids'};
  }
  if (delete $args->{skipbad}) {
    $param{skipBadRecords} = 1;
  }
  if (defined(my $only = delete $args->{only})) {
    $param{importRecords} = $only;
    $param{importRecordsRadio} = 'only';
  }
  $param{client} = $self->{_client};

  return \%param;
}

# get the format and style parameters

sub _format {
  my ($self, $name) = @_;
  return _check_format($name || $self->format || REFBASE_DEFAULT_FORMAT);
}

sub _style {
  my ($self, $name) = @_;
  return _check_style($name || $self->style);
}



# extension to HTTP::Response

package Biblio::Refbase::Response;

# todo: investigation required on adding a DESTROY method

use base 'HTTP::Response';

sub _accessor {
  my $self = shift;
  my $field = '_BRR_' . shift;
  if (@_) {
    $self->{$field} = shift;
    return $self;
  }
  return $self->{$field};
}

sub hits { shift->_accessor('hits', @_) }

sub rows { shift->_accessor('rows', @_) }

sub records { shift->_accessor('records', @_) }



1;

__END__