File Coverage

blib/lib/WWW/NationalRail.pm

Criterion	Covered	Total	%
statement	25	93	26.8
branch	0	40	0.0
condition	0	12	0.0
subroutine	8	10	80.0
pod	1	1	100.0
total	34	156	21.7

package WWW::NationalRail;

use warnings;
use strict;
use 5.006_001;
use Carp;
use HTML::TableExtract;
use WWW::Mechanize;
use base qw(Class::Accessor);

our $VERSION = "0.1";

__PACKAGE__->mk_accessors(qw(from to via out_date out_type out_hour out_minute
    ret_date ret_type ret_hour ret_minute));
__PACKAGE__->mk_ro_accessors(qw(outward_summary return_summary
    outward_detail return_detail error));

my $url = "http://www.nationalrail.co.uk/planmyjourney/";

sub search {
    my $self = shift;
    my $mech = new WWW::Mechanize;
    delete $self->{error}; # reset error
    $mech->get($url);

    # National Rail use odd field names
    $mech->field( "0", $self->{from});
    $mech->field( "1", $self->{to});
    $mech->field( "11", $self->{out_date});
    $mech->field( "14", $self->{ret_date}) if $self->{ret_date};
    $mech->field( "3", $self->{via});
    $mech->field( "9", $self->{out_type}) if $self->{out_type};
    $mech->field( "outHourField", sprintf "%02d", $self->{out_hour})
        if defined $self->{out_hour};
    $mech->field( "outMinuteField", sprintf "%02d", $self->{out_minute})
        if defined $self->{out_minute};
    $mech->field( "retHourField", sprintf "%02d", $self->{ret_hour})
        if defined $self->{ret_hour};
    $mech->field( "retMinuteField", sprintf "%02d", $self->{ret_minute})
        if defined $self->{ret_minute};

    $mech->submit_form();

    if ($mech->content =~ m!(.*)!) {
        $self->{error} = "National Rail error: $1";
        return;
    }
    if ($mech->content =~ m!You searched for (.*)!) {
        $self->{error} = "Unknown station: $1";
        return;
    }

    # At this point we are looking at a page that says "We are getting the
    # train times for the journey you have requested". Click the link. If we
    # get the same page click it again.
    while ($mech->find_link(url => "Display_Timetable.asp")) {
        $mech->follow_link(url => "Display_Timetable.asp");
    }

    $self->{_summary} = $mech->content;
    $self->_parseSummary();
    $mech->follow_link(url => "Matrix_Journey_Details.asp");
    $self->{_detail} = $mech->content;
    $self->_parseDetail();
    return 1;
}

sub _parseSummary {
    my $self = shift;
    my $te = new HTML::TableExtract( depth => 2 );
    $te->parse($self->{_summary});
    my @directions = qw(outward return);
    my @fields = qw(depart arrive changes duration);

    foreach my $ts ($te->table_states) {
        # check if we have already seen both directions
        my $direction = shift @directions or carp "summary parse error";
        my $summary;
        my $row_num = 0;
        foreach my $row ($ts->rows) { # one field per row
            defined $row->[1] and $row->[1] ne "" or next; # careful of '0's
            my $field = lc shift @$row;
            # check field name is as expected
            if ($fields[$row_num] ne $field) {
                # don't worry if single journey and we are looking for a return
                # that isn't there
                return if $row_num == 0 and $direction eq "return";
                carp "summary parse error";
            }
            $summary->[$_]{$field} = $row->[$_] for 0..$#$row; # transpose
            $row_num++;
        }
        @$summary or carp "summary parse error";
        $self->{$direction . "_summary"} = $summary;
    }
}

sub _parseDetail {
    my $self = shift;
    my $te = new HTML::TableExtract( );
    $te->parse($self->{_detail});
    my $direction;
    foreach my $ts ($te->table_states) {
        if ($ts->depth eq 3) {
            (($ts->rows)[0]->[0]) =~ /^(.*) Journey: /
                    or carp "direction not found";
            $direction = lc $1;
        }
        next if $ts->depth != 2 or $ts->rows == 1;
        $direction or carp "direction not found";
        my $journey = {};
        my @legs;
        foreach my $row ($ts->rows) {
            next if not $row->[0] or $row->[0] eq "Station";
            if ($row->[0] =~ /DURATION: ([0-9:]+)/) {
                $journey->{duration} = $1;
            } else {
                my %leg;
                @leg{qw(station arrive depart travelby operator)} = map {
                    s/[^a-zA-Z0-9: ]//g;
                    $_ ne "" ? $_ : undef; # careful of '0's
                } @$row;
                push @legs, \%leg;
            }
        }
        $journey->{legs} = \@legs;
        push @{$self->{$direction . "_detail"}}, $journey;
    }
}

1;

=head1 NAME

WWW::NationalRail - Perl interface to the UK rail timetable

=head1 SYNOPSIS

  use WWW::NationalRail;

  my $rail = WWW::NationalRail->new({
    from        => "London",
    to          => "Cambridge",
    out_date    => "18/12/05",
    out_type    => "depart",
    out_hour    => 9,
    out_minute  => 0,
    ret_date    => "18/12/05",
    ret_type    => "depart",
    ret_hour    => 17,
    ret_minute  => 0,
  });

  $rail->search or die $rail->error();

  my $os = $rail->outward_summary; # array reference
  my $rs = $rail->return_summary;

  $os->[0]{depart}      # "09:06"
  $os->[0]{arrive}      # "10:25"
  $os->[0]{changes}     # "0"
  $os->[0]{duration}    # "1:19"

  my $od = $rail->outward_detail;
  my $rd = $rail->return_detail;

  $od->[0]->{duration}; # "1:19"

  my $legs = $od->[0]{legs} # array reference

  $legs->[0]{station}   # "LONDON KINGS CROSS"
  $legs->[0]{arrive}    # undef
  $legs->[0]{depart}    # "09:06"
  $legs->[0]{travelby}  # "Train"
  $legs->[0]{operator}  # "WAGN RAIL"

  $rail->ret_hour(19);  # change search parameters
  $rail->search();      # and search again

=head1 DESCRIPTION

WWW::NationalRail is a Perl interface to the UK national rail timetable at
http://www.nationalrail.co.uk/planmyjourney/

=over 4

=item new()

The constructor accepts the arguments for the search as a has
reference. The from and to fields are required, the rest are optional and will
use a National Rail supplied default.

=over 11

=item from

Departure station.

=item to

Destination station.

=item via

Via station.

=item out_date

Outbound date in the format "DD/MM/YY". Defaults to today.

=item out_type

Possible values are "depart" to search by outbound departure time or
"arrive" to search by outbound arrival time. Defaults to "depart".

=item out_hour

Outbound hour, 0 to 23. Defaults to sometime in the near future.

=item out_minute

Outbound minute, 0 to 59. Defaults to sometime in the near future.

=item ret_date

Return date in the format "DD/MM/YY". Leave blank for one-way.

=item ret_type

Similar to out_type. Either "depart or "arrive". Defaults to "depart".

=item ret_hour

Return hour, 0 to 23. Leave blank for one-way.

=item ret_minute

Return minute, 0 to 59. Leave blank for one-way.

=back

=item search()

Object method to run the search and parse the results.

=item outbound_summary() and return_summary()

Each returns a reference to an array of hashes.
For journeys in one direction return_summary() will be undef.
The hash representing a summary has four fields:

=over 9

=item depart

Time of departure.

=item arrive

Time of arrival.

=item changes

Number of changes.

=item duration

Duration of the journey.

=back

=item outbound_details() and return_details()

Each returns a reference to an array of hashes.
For journeys in one direction return_details() will be undef.
The hash representing a journey has four two fields:

=over 9

=item legs

Reference to an array of hashes.

=item duration

Duration of the journey.

=back

The legs hash has four five fields:

=over 9

=item station

Name of the station.

=item arrive

Time of arrival at this station, undef for the first leg.

=item depart

Time of departure from this station, undef for the last leg.

=item travelby

Means of transport, will usually be train, but could also be foot,
coach, or tube.

=item operator

The train operating company.

=back

=back

=head1 AUTHOR

Edward Betts, C<<  >>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2005 by Edward Betts

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.4 or,
at your option, any later version of Perl 5 you may have available.

=cut