File Coverage

blib/lib/Finance/Quote/RBA.pm

Criterion	Covered	Total	%
statement	80	101	79.2
branch	15	28	53.5
condition			n/a
subroutine	11	12	91.6
pod	0	3	0.0
total	106	144	73.6

# Copyright 2007, 2008, 2009, 2010, 2011, 2014, 2015 Kevin Ryde

# This file is part of Finance-Quote-Grab.
#
# Finance-Quote-Grab 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 3, or (at your option) any
# later version.
#
# Finance-Quote-Grab 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, see .


package Finance::Quote::RBA;
use strict;
use Scalar::Util;
use Finance::Quote 1.15; # for isoTime()

use vars qw($VERSION %name_to_symbol);
$VERSION = 14;

# uncomment this to run the ### lines
#use Smart::Comments;


sub methods {
  return (rba => \&rba_quotes);
}
sub labels {
  return (rba => [ qw(date isodate name currency
                      last close
                      method source success errormsg

                      time copyright_url) ]);
}

use constant EXCHANGE_RATES_URL =>
  'http://www.rba.gov.au/statistics/frequency/exchange-rates.html';

use constant COPYRIGHT_URL =>
  'http://www.rba.gov.au/copyright/index.html';

sub rba_quotes {
  my ($fq, @symbol_list) = @_;
  if (! @symbol_list) { return; }

  my $ua = $fq->user_agent;
  require HTTP::Request;
  my $req = HTTP::Request->new ('GET', EXCHANGE_RATES_URL);
  $ua->prepare_request ($req);
  $req->accept_decodable; # using decoded_content() below
  $req->user_agent (__PACKAGE__."/$VERSION " . $req->user_agent);

  my $resp = $ua->request ($req);
  my %quotes;
  _parse ($fq, $resp, \%quotes, \@symbol_list);
  return wantarray() ? %quotes : \%quotes;
}

sub _parse {
  my ($fq, $resp, $quotes, $symbol_list) = @_;

  foreach my $symbol (@$symbol_list) {
    $quotes->{$symbol,'method'}  = 'rba';
    $quotes->{$symbol,'source'}  = __PACKAGE__;
    $quotes->{$symbol,'success'} = 0;
  }

  if (! $resp->is_success) {
    _errormsg ($quotes, $symbol_list, $resp->status_line);
    return;
  }
  my $content = $resp->decoded_content (raise_error => 1, charset => 'none');

  # mung
  $content =~ s{
  $content =~ s{(

  require HTML::TableExtract;
  my $te = HTML::TableExtract->new
    (headers => ['Units of foreign currency per'],
     slice_columns => 0);
  $te->parse($content);
  my $ts = $te->first_table_found;
  if (! $ts) {
    _errormsg ($quotes, $symbol_list, 'rates table not found in HTML');
    return;
  }

  # column of letters "P" "U" "B" "L" "I" "C" "H" "O" "L" "I" "D" "A" "Y"
  # on a bank holiday -- skip those
  my ($col, $prevcol);
  for (my $i = $ts->columns - 1; $i >= 2; $i--) {
    if (Scalar::Util::looks_like_number ($ts->cell (1, $i))) {
      $col = $i;
      last;
    }
  }
  for (my $i = $col - 1; $i >= 2; $i--) {
    if (Scalar::Util::looks_like_number ($ts->cell (1, $i))) {
      $prevcol = $i;
      last;
    }
  }
  ### $col
  ### $prevcol
  if (! defined $col) {
    _errormsg ($quotes, $symbol_list, 'No numeric columns found');
    return;
  }

  my $date = $ts->cell (0, $col);

  my %want_symbol;
  @want_symbol{@$symbol_list} = (); # hash slice
  my %seen_symbol;

  foreach my $row (@{$ts->rows()}) {
    ### $row

    my $symbol = $row->[0];
    $symbol or next;       # dates row, or no id="" in
    $symbol =~ s/_.*//; # _4pm on TWI
    $symbol = "AUD$symbol";
    if (! exists $want_symbol{$symbol}) { next; } # unwanted row

    my $name   = $row->[1];
    defined $name or next; # dates row
    ($name, my $time) = _name_extract_time ($fq, $name);

    my $rate = $row->[$col];
    my $prev = $row->[$prevcol];

    $fq->store_date($quotes, $symbol, {eurodate => $date});
    if (defined $time) {
      $quotes->{$symbol,'time'} = $time;
    }
    $quotes->{$symbol,'name'}   = $name;
    $quotes->{$symbol,'last'}   = $rate;
    $quotes->{$symbol,'close'}  = $prev;
    if ($symbol ne 'TWI') {
      $quotes->{$symbol,'currency'} = $symbol;
    }
    $quotes->{$symbol,'copyright_url'} = COPYRIGHT_URL;
    $quotes->{$symbol,'success'}  = 1;

    # don't delete AUDTWI from %want_symbol since want to get the last row
    # which is 16:00 instead of the 9:00 one
    $seen_symbol{$symbol} = 1;
  }


  delete @want_symbol{keys %seen_symbol}; # hash slice
  # any not seen
  _errormsg ($quotes, [keys %want_symbol], 'No such symbol');
}

sub _errormsg {
  my ($quotes, $symbol_list, $errormsg) = @_;
  foreach my $symbol (@$symbol_list) {
    $quotes->{$symbol,'errormsg'} = $errormsg;
  }
}

# pick out name and time from forms like
#     Trade-weighted index (9am)
#     Trade-weighted index (Noon)
#     Trade-weighted index (4pm)
# or without a time is 4pm, like
#     UK pound sterling
#
sub _name_extract_time {
  my ($fq, $name) = @_;

  if ($name =~ m/(.*?) +\(Noon\)$/i) {   # Noon
    return ($1, '12:00');
  } elsif ($name =~ m/(.*?) +\(([0-9]+)([ap]m)\)$/i) {  # 9am, 4pm
    return ($1, $fq->isoTime("$2:00$3"));
  } else {
    return ($name, '16:00');   # default 4pm
  }
}

1;
__END__