package Travel::Status::DE::HAFAS;
use strict;
use warnings;
use 5.010;
use utf8;
no if $] >= 5.018, warnings => 'experimental::smartmatch';
use Carp qw(confess);
use LWP::UserAgent;
use POSIX qw(strftime);
use Travel::Status::DE::HAFAS::Result;
use Travel::Status::DE::HAFAS::StopFinder;
use XML::LibXML;
our $VERSION = '2.01';
my %hafas_instance = (
BVG => {
url => 'http://bvg.hafas.de/bin/stboard.exe',
stopfinder => 'http://bvg.hafas.de/bin/ajax-getstop.exe',
name => 'Berliner Verkehrsgesellschaft',
productbits => [qw[s u tram bus ferry ice regio ondemand]],
},
DB => {
url => 'http://reiseauskunft.bahn.de/bin/bhftafel.exe',
stopfinder => 'http://reiseauskunft.bahn.de/bin/ajax-getstop.exe',
name => 'Deutsche Bahn',
productbits =>
[qw[ice ic_ec d regio s bus ferry u tram ondemand x x x x]],
},
NAHSH => {
url => 'http://nah.sh.hafas.de/bin/stboard.exe',
stopfinder => 'http://nah.sh.hafas.de/bin/ajax-getstop.exe',
name => 'Nahverkehrsverbund Schleswig-Holstein',
productbits => [qw[ice ice ice regio s bus ferry u tram ondemand]],
},
NASA => {
url => 'http://reiseauskunft.insa.de/bin/stboard.exe',
stopfinder => 'http://reiseauskunft.insa.de/bin/ajax-getstop.exe',
name => 'Nahverkehrsservice Sachsen-Anhalt',
productbits => [qw[ice ice regio regio regio tram bus ondemand]],
},
NVV => {
url => 'http://auskunft.nvv.de/auskunft/bin/jp/stboard.exe',
stopfinder => 'http://auskunft.nvv.de/auskunft/bin/jp/ajax-getstop.exe',
name => 'Nordhessischer VerkehrsVerbund',
productbits =>
[qw[ice ic_ec regio s u tram bus bus ferry ondemand regio regio]],
},
'ÖBB' => {
url => 'http://fahrplan.oebb.at/bin/stboard.exe',
stopfinder => 'http://fahrplan.oebb.at/bin/ajax-getstop.exe',
name => 'Österreichische Bundesbahnen',
productbits =>
[qw[ice ice ice regio regio s bus ferry u tram ice ondemand ice]],
},
RSAG => {
url => 'http://fahrplan.rsag-online.de/hafas/stboard.exe',
stopfinder => 'http://fahrplan.rsag-online.de/hafas/ajax-getstop.exe',
name => 'Rostocker Straßenbahn AG',
productbits => [qw[ice ice ice regio s bus ferry u tram ondemand]],
},
SBB => {
url => 'http://fahrplan.sbb.ch/bin/stboard.exe',
stopfinder => 'http://fahrplan.sbb.ch/bin/ajax-getstop.exe',
name => 'Schweizerische Bundesbahnen',
productbits =>
[qw[ice ice regio regio ferry s bus cablecar regio tram]],
},
VBB => {
url => 'http://fahrinfo.vbb.de/bin/stboard.exe',
stopfinder => 'http://fahrinfo.vbb.de/bin/ajax-getstop.exe',
name => 'Verkehrsverbund Berlin-Brandenburg',
productbits => [qw[s u tram bus ferry ice regio]],
},
VBN => {
url => 'https://fahrplaner.vbn.de/hafas/stboard.exe',
stopfinder => 'https://fahrplaner.vbn.de/hafas/ajax-getstop.exe',
name => 'Verkehrsverbund Bremen/Niedersachsen',
productbits => [qw[ice ice regio regio s bus ferry u tram ondemand]],
},
);
sub new {
my ( $obj, %conf ) = @_;
my $date = $conf{date} // strftime( '%d.%m.%Y', localtime(time) );
my $time = $conf{time} // strftime( '%H:%M', localtime(time) );
my $lang = $conf{language} // 'd';
my $mode = $conf{mode} // 'dep';
my $service = $conf{service};
my %lwp_options = %{ $conf{lwp_options} // { timeout => 10 } };
my $ua = LWP::UserAgent->new(%lwp_options);
$ua->env_proxy;
my $reply;
if ( not $conf{station} ) {
confess('You need to specify a station');
}
if ( not defined $service and not defined $conf{url} ) {
$service = 'DB';
}
if ( defined $service and not exists $hafas_instance{$service} ) {
confess("The service '$service' is not supported");
}
my $ref = {
active_service => $service,
developer_mode => $conf{developer_mode},
exclusive_mots => $conf{exclusive_mots},
excluded_mots => $conf{excluded_mots},
station => $conf{station},
ua => $ua,
post => {
input => $conf{station},
date => $date,
time => $time,
start => 'yes', # value doesn't matter, just needs to be set
boardType => $mode,
L => 'vs_java3',
},
};
bless( $ref, $obj );
$ref->set_productfilter;
my $url = ( $conf{url} // $hafas_instance{$service}{url} ) . "/${lang}n";
$reply = $ua->post( $url, $ref->{post} );
if ( $reply->is_error ) {
$ref->{errstr} = $reply->status_line;
return $ref;
}
$ref->{raw_xml} = $reply->content;
# the interface often does not return valid XML (but it's close!)
if ( substr( $ref->{raw_xml}, 0, 5 ) ne '<?xml' ) {
$ref->{raw_xml}
= '<?xml version="1.0" encoding="iso-8859-15"?><wrap>'
. $ref->{raw_xml}
. '</wrap>';
}
if ( defined $service and $service eq 'NVV' ) {
# Returns invalid XML with tags inside HIMMessage's lead attribute.
# Fix this.
$ref->{raw_xml}
=~ s{ lead = " \K ( [^"]+ ) }{ $1 =~ s{ < [^>]+ > }{}grx }egx;
}
# TODO the DB backend also retuns invalid XML (similar to above, but with
# errors in delay="...") when setting the language to dutch/italian.
# No, I don't know why.
if ( $ref->{developer_mode} ) {
say $ref->{raw_xml};
}
$ref->{tree} = XML::LibXML->load_xml(
string => $ref->{raw_xml},
);
if ( $ref->{developer_mode} ) {
say $ref->{tree}->toString(1);
}
$ref->check_input_error;
return $ref;
}
sub set_productfilter {
my ($self) = @_;
my $service = $self->{active_service};
my $mot_default = '1';
if ( not $service or not exists $hafas_instance{$service}{productbits} ) {
return;
}
my %mot_pos;
for my $i ( 0 .. $#{ $hafas_instance{$service}{productbits} } ) {
$mot_pos{ $hafas_instance{$service}{productbits}[$i] } = $i;
}
if ( $self->{exclusive_mots} and @{ $self->{exclusive_mots} } ) {
$mot_default = '0';
}
$self->{post}{productsFilter}
= $mot_default x ( scalar @{ $hafas_instance{$service}{productbits} } );
if ( $self->{exclusive_mots} and @{ $self->{exclusive_mots} } ) {
for my $mot ( @{ $self->{exclusive_mots} } ) {
if ( exists $mot_pos{$mot} ) {
substr( $self->{post}{productsFilter}, $mot_pos{$mot}, 1, '1' );
}
}
}
if ( $self->{excluded_mots} and @{ $self->{excluded_mots} } ) {
for my $mot ( @{ $self->{excluded_mots} } ) {
if ( exists $mot_pos{$mot} ) {
substr( $self->{post}{productsFilter}, $mot_pos{$mot}, 1, '0' );
}
}
}
return;
}
sub check_input_error {
my ($self) = @_;
my $xp_err = XML::LibXML::XPathExpression->new('//Err');
my $err = ( $self->{tree}->findnodes($xp_err) )[0];
if ($err) {
$self->{errstr}
= $err->getAttribute('text')
. ' (code '
. $err->getAttribute('code') . ')';
$self->{errcode} = $err->getAttribute('code');
}
return;
}
sub errcode {
my ($self) = @_;
return $self->{errcode};
}
sub errstr {
my ($self) = @_;
return $self->{errstr};
}
sub similar_stops {
my ($self) = @_;
my $service = $self->{active_service};
if ( $service and exists $hafas_instance{$service}{stopfinder} ) {
# we do not pass our constructor's language argument here,
# because most stopfinder services do not return any results
# for languages other than german ('d' aka the default)
my $sf = Travel::Status::DE::HAFAS::StopFinder->new(
url => $hafas_instance{$service}{stopfinder},
input => $self->{station},
ua => $self->{ua},
developer_mode => $self->{developer_mode},
);
if ( my $err = $sf->errstr ) {
$self->{errstr} = $err;
return;
}
return $sf->results;
}
return;
}
sub results {
my ($self) = @_;
my $mode = $self->{post}->{boardType};
my $xp_element = XML::LibXML::XPathExpression->new('//Journey');
my $xp_msg = XML::LibXML::XPathExpression->new('./HIMMessage');
if ( defined $self->{results} ) {
return @{ $self->{results} };
}
if ( not defined $self->{tree} ) {
return;
}
$self->{results} = [];
for my $tr ( @{ $self->{tree}->findnodes($xp_element) } ) {
my @message_nodes = $tr->findnodes($xp_msg);
my $train = $tr->getAttribute('prod');
my $time = $tr->getAttribute('fpTime');
my $date = $tr->getAttribute('fpDate');
my $dest = $tr->getAttribute('targetLoc');
my $platform = $tr->getAttribute('platform');
my $new_platform = $tr->getAttribute('newpl');
my $delay = $tr->getAttribute('delay');
my $e_delay = $tr->getAttribute('e_delay');
my $info = $tr->getAttribute('delayReason');
my @messages;
if ( not( $time and $dest ) ) {
next;
}
for my $n (@message_nodes) {
push( @messages, $n->getAttribute('header') );
}
substr( $date, 6, 0, '20' );
# TODO the first charactor of delayReason is special:
# " " -> no additional data, rest (if any) is delay reason
# else -> first word is not a delay reason but additional data,
# for instance "Zusatzfahrt/Ersatzfahrt" for a replacement train
if ( defined $info and $info eq q{ } ) {
$info = undef;
}
elsif ( defined $info and substr( $info, 0, 1 ) eq q{ } ) {
substr( $info, 0, 1, q{} );
}
$train =~ s{#.*$}{};
push(
@{ $self->{results} },
Travel::Status::DE::HAFAS::Result->new(
date => $date,
raw_delay => $delay,
raw_e_delay => $e_delay,
messages => \@messages,
time => $time,
train => $train,
route_end => $dest,
platform => $platform,
new_platform => $new_platform,
info => $info,
)
);
}
return @{ $self->{results} };
}
# static
sub get_services {
my @services;
for my $service ( sort keys %hafas_instance ) {
my %desc = %{ $hafas_instance{$service} };
$desc{shortname} = $service;
push( @services, \%desc );
}
return @services;
}
# static
sub get_service {
my ($service) = @_;
if ( defined $service and exists $hafas_instance{$service} ) {
return $hafas_instance{$service};
}
return;
}
sub get_active_service {
my ($self) = @_;
if ( defined $self->{active_service} ) {
return $hafas_instance{ $self->{active_service} };
}
return;
}
1;
__END__
=head1 NAME
Travel::Status::DE::HAFAS - Interface to HAFAS-based online arrival/departure
monitors
=head1 SYNOPSIS
use Travel::Status::DE::HAFAS;
my $status = Travel::Status::DE::HAFAS->new(
station => 'Essen Hbf',
);
if (my $err = $status->errstr) {
die("Request error: ${err}\n");
}
for my $departure ($status->results) {
printf(
"At %s: %s to %s from platform %s\n",
$departure->time,
$departure->line,
$departure->destination,
$departure->platform,
);
}
=head1 VERSION
version 2.01
=head1 DESCRIPTION
Travel::Status::DE::HAFAS is an interface to HAFAS-based
arrival/departure monitors, for instance the one available at
L<http://reiseauskunft.bahn.de/bin/bhftafel.exe/dn>.
It takes a station name and (optional) date and time and reports all arrivals
or departures at that station starting at the specified point in time (now if
unspecified).
=head1 METHODS
=over
=item my $status = Travel::Status::DE::HAFAS->new(I<%opts>)
Requests the departures/arrivals as specified by I<opts> and returns a new
Travel::Status::DE::HAFAS element with the results. Dies if the wrong
I<opts> were passed.
Supported I<opts> are:
=over
=item B<station> => I<station>
The station or stop to report for, e.g. "Essen HBf" or
"Alfredusbad, Essen (Ruhr)". Mandatory.
=item B<date> => I<dd>.I<mm>.I<yyyy>
Date to report for. Defaults to the current day.
=item B<excluded_mots> => [I<mot1>, I<mot2>, ...]
By default, all modes of transport (trains, trams, buses etc.) are returned.
If this option is set, all modes appearing in I<mot1>, I<mot2>, ... will
be excluded. The supported modes depend on B<service>, use
B<get_services> or B<get_service> to get the supported values.
Note that this parameter does not work if the B<url> parameter is set.
=item B<exclusive_mots> => [I<mot1>, I<mot2>, ...]
If this option is set, only the modes of transport appearing in I<mot1>,
I<mot2>, ... will be returned. The supported modes depend on B<service>, use
B<get_services> or B<get_service> to get the supported values.
Note that this parameter does not work if the B<url> parameter is set.
=item B<language> => I<language>
Set language for additional information. Accepted arguments are B<d>eutsch,
B<e>nglish, B<i>talian and B<n> (dutch), depending on the used service.
=item B<lwp_options> => I<\%hashref>
Passed on to C<< LWP::UserAgent->new >>. Defaults to C<< { timeout => 10 } >>,
you can use an empty hashref to override it.
=item B<mode> => B<arr>|B<dep>
By default, Travel::Status::DE::HAFAS reports train departures
(B<dep>). Set this to B<arr> to get arrivals instead.
=item B<service> => I<service>
Request results from I<service>, defaults to "DB".
See B<get_services> (and C<< hafas-m --list >>) for a list of supported
services.
=item B<time> => I<hh>:I<mm>
Time to report for. Defaults to now.
=item B<url> => I<url>
Request results from I<url>, defaults to the one belonging to B<service>.
=back
=item $status->errcode
In case of an error in the HAFAS backend, returns the corresponding error code
as string. If no backend error occurred, returns undef.
=item $status->errstr
In case of an error in the HTTP request or HAFAS backend, returns a string
describing it. If no error occurred, returns undef.
=item $status->results
Returns a list of arrivals/departures. Each list element is a
Travel::Status::DE::HAFAS::Result(3pm) object.
If no matching results were found or the parser / http request failed, returns
undef.
=item $status->similar_stops
Returns a list of hashrefs describing stops whose name is similar to the one
requested in the constructor's B<station> parameter. Returns nothing if
the active service does not support this feature.
This is most useful if B<errcode> returns 'H730', which means that the
HAFAS backend could not identify the stop.
See Travel::Status::DE::HAFAS::StopFinder(3pm)'s B<results> method for details
on the return value.
=item $status->get_active_service
Returns a hashref describing the active service when a service is active and
nothing otherwise. The hashref contains the keys B<url> (URL to the station
board service), B<stopfinder> (URL to the stopfinder service, if supported),
B<name>, and B<productbits> (arrayref describing the supported modes of
transport, may contain duplicates).
=item Travel::Status::DE::HAFAS::get_services()
Returns an array containing all supported HAFAS services. Each element is a
hashref and contains all keys mentioned in B<get_active_service>.
It also contains a B<shortname> key, which is the service name used by
the constructor's B<service> parameter.
=item Travel::Status::DE::HAFAS::get_service(I<$service>)
Returns a hashref describing the service I<$service>. Returns nothing if
I<$service> is not supported. See B<get_active_service> for the hashref layout.
=back
=head1 DIAGNOSTICS
None.
=head1 DEPENDENCIES
=over
=item * Class::Accessor(3pm)
=item * LWP::UserAgent(3pm)
=item * XML::LibXML(3pm)
=back
=head1 BUGS AND LIMITATIONS
The non-default services (anything other than DB) are not well tested.
=head1 SEE ALSO
Travel::Status::DE::HAFAS::Result(3pm), Travel::Status::DE::HAFAS::StopFinder(3pm).
=head1 AUTHOR
Copyright (C) 2015 by Daniel Friesel E<lt>derf@finalrewind.orgE<gt>
=head1 LICENSE
This module is licensed under the same terms as Perl itself.