package Travel::Status::DE::EFA; use strict; use warnings; use 5.010; no if $] >= 5.018, warnings => "experimental::smartmatch"; our $VERSION = '1.06'; use Carp qw(confess cluck); use Encode qw(encode decode); use Travel::Status::DE::EFA::Line; use Travel::Status::DE::EFA::Result; use LWP::UserAgent; use XML::LibXML; sub new { my ( $class, %opt ) = @_; my $ua = LWP::UserAgent->new(%opt); my @now = localtime( time() ); my @time = @now[ 2, 1 ]; my @date = ( $now[3], $now[4] + 1, $now[5] + 1900 ); if ( not( $opt{place} and $opt{name} ) ) { confess('You need to specify a place and a name'); } if ( $opt{type} and not( $opt{type} ~~ [qw[stop address poi]] ) ) { confess('type must be stop, address or poi'); } if ( not $opt{efa_url} ) { confess('efa_url is mandatory'); } ## no critic (RegularExpressions::ProhibitUnusedCapture) ## no critic (Variables::ProhibitPunctuationVars) if ( $opt{time} and $opt{time} =~ m{ ^ (? \d\d? ) : (? \d\d ) $ }x ) { @time = @+{qw{hour minute}}; } elsif ( $opt{time} ) { confess('Invalid time specified'); } if ( $opt{date} and $opt{date} =~ m{ ^ (? \d\d? ) [.] (? \d\d? ) [.] (? \d{4} )? $ }x ) { if ( $+{year} ) { @date = @+{qw{day month year}}; } else { @date[ 0, 1 ] = @+{qw{day month}}; } } elsif ( $opt{date} ) { confess('Invalid date specified'); } my $self = { post => { command => q{}, deleteAssignedStops_dm => '1', help => 'Hilfe', itdDateDay => $date[0], itdDateMonth => $date[1], itdDateYear => $date[2], itdLPxx_id_dm => ':dm', itdLPxx_mapState_dm => q{}, itdLPxx_mdvMap2_dm => q{}, itdLPxx_mdvMap_dm => '3406199:401077:NAV3', itdLPxx_transpCompany => 'vrr', itdLPxx_view => q{}, itdTimeHour => $time[0], itdTimeMinute => $time[1], language => 'de', mode => 'direct', nameInfo_dm => 'invalid', nameState_dm => 'empty', name_dm => encode( 'ISO-8859-15', $opt{name} ), outputFormat => 'XML', placeInfo_dm => 'invalid', placeState_dm => 'empty', place_dm => encode( 'ISO-8859-15', $opt{place} ), ptOptionsActive => '1', requestID => '0', reset => 'neue Anfrage', sessionID => '0', submitButton => 'anfordern', typeInfo_dm => 'invalid', type_dm => $opt{type} // 'stop', useProxFootSearch => '0', useRealtime => '1', }, }; bless( $self, $class ); $ua->env_proxy; my $response = $ua->post( $opt{efa_url}, $self->{post} ); if ( $response->is_error ) { $self->{errstr} = $response->status_line; return $self; } $self->{xml} = $response->decoded_content; $self->{tree} = XML::LibXML->load_xml( string => $self->{xml}, ); # say $self->{tree}->toString(1); $self->check_for_ambiguous(); return $self; } sub new_from_xml { my ( $class, %opt ) = @_; my $self = { xml => $opt{xml}, }; $self->{tree} = XML::LibXML->load_xml( string => $self->{xml}, ); return bless( $self, $class ); } sub errstr { my ($self) = @_; return $self->{errstr}; } sub sprintf_date { my ($e) = @_; return sprintf( '%02d.%02d.%d', $e->getAttribute('day'), $e->getAttribute('month'), $e->getAttribute('year'), ); } sub sprintf_time { my ($e) = @_; return sprintf( '%02d:%02d', $e->getAttribute('hour'), $e->getAttribute('minute'), ); } sub check_for_ambiguous { my ($self) = @_; my $xml = $self->{tree}; my $xp_place = XML::LibXML::XPathExpression->new('//itdOdv/itdOdvPlace'); my $xp_name = XML::LibXML::XPathExpression->new('//itdOdv/itdOdvName'); my $xp_mesg = XML::LibXML::XPathExpression->new('//itdMessage[@type="error"]'); my $xp_place_elem = XML::LibXML::XPathExpression->new('./odvPlaceElem'); my $xp_name_elem = XML::LibXML::XPathExpression->new('./odvNameElem'); my $e_place = ( $xml->findnodes($xp_place) )[0]; my $e_name = ( $xml->findnodes($xp_name) )[0]; my @e_mesg = $xml->findnodes($xp_mesg); if ( not( $e_place and $e_name ) ) { # this should not happen[tm] cluck('skipping ambiguity check- itdOdvPlace/itdOdvName missing'); return; } my $s_place = $e_place->getAttribute('state'); my $s_name = $e_name->getAttribute('state'); if ( $s_place eq 'list' ) { $self->{errstr} = sprintf( 'Ambiguous place input: %s', join( q{ | }, map { decode( 'UTF-8', $_->textContent ) } @{ $e_place->findnodes($xp_place_elem) } ) ); return; } if ( $s_name eq 'list' ) { $self->{errstr} = sprintf( 'Ambiguous name input: %s', join( q{ | }, map { decode( 'UTF-8', $_->textContent ) } @{ $e_name->findnodes($xp_name_elem) } ) ); return; } if ( $s_place eq 'notidentified' ) { $self->{errstr} = 'invalid place parameter'; return; } if ( $s_name eq 'notidentified' ) { $self->{errstr} = 'invalid name parameter'; return; } if (@e_mesg) { $self->{errstr} = join( q{; }, map { $_->textContent } @e_mesg ); return; } return; } sub lines { my ($self) = @_; my @lines; my $xp_element = XML::LibXML::XPathExpression->new('//itdServingLines/itdServingLine'); my $xp_info = XML::LibXML::XPathExpression->new('./itdNoTrain'); my $xp_route = XML::LibXML::XPathExpression->new('./itdRouteDescText'); my $xp_oper = XML::LibXML::XPathExpression->new('./itdOperator/name'); if ( $self->{lines} ) { return @{ $self->{lines} }; } for my $e ( $self->{tree}->findnodes($xp_element) ) { my $e_info = ( $e->findnodes($xp_info) )[0]; my $e_route = ( $e->findnodes($xp_route) )[0]; my $e_oper = ( $e->findnodes($xp_oper) )[0]; if ( not($e_info) ) { cluck( 'node with insufficient data. This should not happen. ' . $e->getAttribute('number') ); next; } my $line = $e->getAttribute('number'); my $direction = $e->getAttribute('direction'); my $valid = $e->getAttribute('valid'); my $type = $e_info->getAttribute('name'); my $route = ( $e_route ? $e_route->textContent : undef ); my $operator = ( $e_oper ? $e_oper->textContent : undef ); my $identifier = $e->getAttribute('stateless'); push( @lines, Travel::Status::DE::EFA::Line->new( name => $line, direction => decode( 'UTF-8', $direction ), valid => $valid, type => decode( 'UTF-8', $type ), route => decode( 'UTF-8', $route ), operator => decode( 'UTF-8', $operator ), identifier => $identifier, ) ); } $self->{lines} = \@lines; return @lines; } sub results { my ($self) = @_; my @results; my $xp_element = XML::LibXML::XPathExpression->new('//itdDeparture'); my $xp_date = XML::LibXML::XPathExpression->new('./itdDateTime/itdDate'); my $xp_time = XML::LibXML::XPathExpression->new('./itdDateTime/itdTime'); my $xp_rdate = XML::LibXML::XPathExpression->new('./itdRTDateTime/itdDate'); my $xp_rtime = XML::LibXML::XPathExpression->new('./itdRTDateTime/itdTime'); my $xp_line = XML::LibXML::XPathExpression->new('./itdServingLine'); my $xp_info = XML::LibXML::XPathExpression->new('./itdServingLine/itdNoTrain'); if ( $self->{results} ) { return @{ $self->{results} }; } $self->lines; for my $e ( $self->{tree}->findnodes($xp_element) ) { my $e_date = ( $e->findnodes($xp_date) )[0]; my $e_time = ( $e->findnodes($xp_time) )[0]; my $e_line = ( $e->findnodes($xp_line) )[0]; my $e_info = ( $e->findnodes($xp_info) )[0]; my $e_rdate = ( $e->findnodes($xp_rdate) )[0]; my $e_rtime = ( $e->findnodes($xp_rtime) )[0]; if ( not( $e_date and $e_time and $e_line ) ) { cluck('node with insufficient data. This should not happen'); next; } my $date = sprintf_date($e_date); my $time = sprintf_time($e_time); my $rdate = $e_rdate ? sprintf_date($e_rdate) : $date; my $rtime = $e_rtime ? sprintf_time($e_rtime) : $time; my $platform = $e->getAttribute('platform'); my $line = $e_line->getAttribute('number'); my $dest = $e_line->getAttribute('direction'); my $info = $e_info->textContent; my $key = $e_line->getAttribute('key'); my $countdown = $e->getAttribute('countdown'); my $delay = $e_info->getAttribute('delay') // 0; my $type = $e_info->getAttribute('name'); my $platform_is_db = 0; my @line_obj = grep { $_->{identifier} eq $e_line->getAttribute('stateless') } @{ $self->{lines} }; if ( $platform =~ s{ ^ \# }{}ox ) { $platform_is_db = 1; } push( @results, Travel::Status::DE::EFA::Result->new( date => $rdate, time => $rtime, platform => $platform, platform_db => $platform_is_db, key => $key, lineref => $line_obj[0] // undef, line => $line, destination => decode( 'UTF-8', $dest ), countdown => $countdown, info => decode( 'UTF-8', $info ), delay => $delay, sched_date => $date, sched_time => $time, type => $type, ) ); } @results = map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [ $_, $_->countdown ] } @results; $self->{results} = \@results; return @results; } 1; __END__ =head1 NAME Travel::Status::DE::EFA - unofficial EFA departure monitor =head1 SYNOPSIS use Travel::Status::DE::EFA; my $status = Travel::Status::DE::EFA->new( efa_url => 'http://efa.vrr.de/vrr/XSLT_DM_REQUEST', place => 'Essen', name => 'Helenenstr' ); for my $d ($status->results) { printf( "%s %d %-5s %s\n", $d->time, $d->platform, $d->line, $d->destination ); } =head1 VERSION version 1.06 =head1 DESCRIPTION Travel::Status::DE::EFA is an unofficial interface to EFA-based departure monitors. It reports all upcoming tram/bus/train departures at a given place. =head1 METHODS =over =item my $status = Travel::Status::DE::EFA->new(I<%opt>) Requests the departures as specified by I and returns a new Travel::Status::DE::EFA object. Dies if the wrong I were passed. Arguments: =over =item B => I URL to the EFA service. Known URLs are: =over =item * L (Verkehrsverbund GroEraum NErnberg) =item * L (Verkehrsverbund Rhein-Ruhr) =item * L (Verkehrsverbund Stuttgart) =back If you found a URL not listed here, please send it to Ederf@finalrewind.orgE. =item B => I Name of the place/city =item B => B
|B|B Type of the following I. B means "point of interest". Defaults to B (stop/station name). =item B => I address / poi / stop name to list departures for. =back =item $status->errstr In case of en HTTP request or EFA error, returns a string describing it. If none occured, returns undef. =item $status->lines Returns a list of Travel::Status::DE::EFA::Line(3pm) objects, each one describing one line servicing the selected station. =item $status->results Returns a list of Travel::Status::DE::EFA::Result(3pm) objects, each one describing one departure. =back =head1 DIAGNOSTICS None. =head1 DEPENDENCIES =over =item * Class::Accessor(3pm) =item * LWP::UserAgent(3pm) =item * XML::LibXML(3pm) =back =head1 BUGS AND LIMITATIONS Not all features of the web interface are supported. =head1 SEE ALSO efa-m(1), Travel::Status::DE::EFA::Result(3pm). =head1 AUTHOR Copyright (C) 2011-2014 by Daniel Friesel Ederf@finalrewind.orgE =head1 LICENSE This module is licensed under the same terms as Perl itself.