package Travel::Status::DE::HAFAS; use strict; use warnings; use 5.014; use utf8; no if $] >= 5.018, warnings => 'experimental::smartmatch'; use Carp qw(confess); use DateTime; use DateTime::Format::Strptime; 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.03'; 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 => 'https://reiseauskunft.bahn.de/bin/bhftafel.exe', stopfinder => 'https://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 '{raw_xml} = '' . $ref->{raw_xml} . ''; } 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} = []; $self->{datetime_now} //= DateTime->now( time_zone => 'Europe/Berlin', ); $self->{strptime_obj} //= DateTime::Format::Strptime->new( pattern => '%d.%m.%YT%H:%M', time_zone => 'Europe/Berlin', ); 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{#.*$}{}; my $datetime = $self->{strptime_obj}->parse_datetime("${date}T${time}"); push( @{ $self->{results} }, Travel::Status::DE::HAFAS::Result->new( date => $date, datetime => $datetime, datetime_now => $self->{datetime_now}, 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.03 =head1 DESCRIPTION Travel::Status::DE::HAFAS is an interface to HAFAS-based arrival/departure monitors, for instance the one available at L. 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 and returns a new Travel::Status::DE::HAFAS element with the results. Dies if the wrong I were passed. Supported I are: =over =item B => I The station or stop to report for, e.g. "Essen HBf" or "Alfredusbad, Essen (Ruhr)". Mandatory. =item B => I
.I.I Date to report for. Defaults to the current day. =item B => [I, I, ...] By default, all modes of transport (trains, trams, buses etc.) are returned. If this option is set, all modes appearing in I, I, ... will be excluded. The supported modes depend on B, use B or B to get the supported values. Note that this parameter does not work if the B parameter is set. =item B => [I, I, ...] If this option is set, only the modes of transport appearing in I, I, ... will be returned. The supported modes depend on B, use B or B to get the supported values. Note that this parameter does not work if the B parameter is set. =item B => I Set language for additional information. Accepted arguments are Beutsch, Bnglish, Btalian and B (dutch), depending on the used service. =item B => 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 => B|B By default, Travel::Status::DE::HAFAS reports train departures (B). Set this to B to get arrivals instead. =item B => I Request results from I, defaults to "DB". See B (and C<< hafas-m --list >>) for a list of supported services. =item B