summaryrefslogtreecommitdiff
path: root/lib/Travel/Status/DE/VRR.pm
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Travel/Status/DE/VRR.pm')
-rw-r--r--lib/Travel/Status/DE/VRR.pm406
1 files changed, 18 insertions, 388 deletions
diff --git a/lib/Travel/Status/DE/VRR.pm b/lib/Travel/Status/DE/VRR.pm
index 5aa569e..23ee381 100644
--- a/lib/Travel/Status/DE/VRR.pm
+++ b/lib/Travel/Status/DE/VRR.pm
@@ -6,358 +6,16 @@ use 5.010;
no if $] >= 5.018, warnings => "experimental::smartmatch";
-our $VERSION = '1.05';
+our $VERSION = '0.00';
-use Carp qw(confess cluck);
-use Encode qw(encode decode);
-use Travel::Status::DE::VRR::Line;
-use Travel::Status::DE::VRR::Result;
-use LWP::UserAgent;
-use XML::LibXML;
+use parent 'Travel::Status::DE::EFA';
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');
- }
-
- ## no critic (RegularExpressions::ProhibitUnusedCapture)
- ## no critic (Variables::ProhibitPunctuationVars)
-
- if ( $opt{time}
- and $opt{time} =~ m{ ^ (?<hour> \d\d? ) : (?<minute> \d\d ) $ }x )
- {
- @time = @+{qw{hour minute}};
- }
- elsif ( $opt{time} ) {
- confess('Invalid time specified');
- }
-
- if (
- $opt{date}
- and $opt{date} =~ m{ ^ (?<day> \d\d? ) [.] (?<month> \d\d? ) [.]
- (?<year> \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 => $opt{name},
- outputFormat => 'XML',
- placeInfo_dm => 'invalid',
- placeState_dm => 'empty',
- place_dm => $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( 'http://efa.vrr.de/vrr/XSLT_DM_REQUEST', $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::VRR::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;
-}
+ $opt{efa_url} = 'http://efa.vrr.de/vrr/XSLT_DM_REQUEST';
-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::VRR::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;
+ return $class->SUPER::new(%opt);
}
1;
@@ -366,7 +24,7 @@ __END__
=head1 NAME
-Travel::Status::DE::VRR - unofficial VRR departure monitor
+Travel::Status::DE::VRR - unofficial VRR departure monitor.
=head1 SYNOPSIS
@@ -383,18 +41,17 @@ Travel::Status::DE::VRR - unofficial VRR departure monitor
);
}
+
=head1 VERSION
-version 1.05
+version 0.00
=head1 DESCRIPTION
Travel::Status::DE::VRR is an unofficial interface to the VRR departure
-monitor available at
+monitor at
L<http://efa.vrr.de/vrr/XSLT_DM_REQUEST?language=de&itdLPxx_transpCompany=vrr&>.
-It reports all upcoming tram/bus/train departures at a given place.
-
=head1 METHODS
=over
@@ -402,41 +59,12 @@ It reports all upcoming tram/bus/train departures at a given place.
=item my $status = Travel::Status::DE::VRR->new(I<%opt>)
Requests the departures as specified by I<opts> and returns a new
-Travel::Status::DE::VRR object. Dies if the wrong I<opts> were passed.
-
-Arguments:
-
-=over
-
-=item B<place> => I<place>
-
-Name of the place/city
-
-=item B<type> => B<address>|B<poi>|B<stop>
-
-Type of the following I<name>. B<poi> means "point of interest". Defaults to
-B<stop> (stop/station name).
+Travel::Status::DE::VRR object.
-=item B<name> => I<name>
+Calls Travel::Status::DE::EFA->new with the appropriate B<efa_url>.
+All I<opts> are passed on.
-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::VRR::Line(3pm) objects, each one
-describing one line servicing the selected station.
-
-=item $status->results
-
-Returns a list of Travel::Status::DE::VRR::Result(3pm) objects, each one describing
-one departure.
+See Travel::Status::DE::EFA(3pm) for the other parameters and methods.
=back
@@ -450,23 +78,25 @@ None.
=item * Class::Accessor(3pm)
+=item * DateTime(3pm)
+
=item * LWP::UserAgent(3pm)
-=item * XML::LibXML(3pm)
+=item * Travel::Status::DE::EFA(3pm)
=back
=head1 BUGS AND LIMITATIONS
-Not all features of the web interface are supported.
+Many.
=head1 SEE ALSO
-efa-m(1), Travel::Status::DE::VRR::Result(3pm).
+aseag-m(1), Travel::Status::DE::EFA(3pm).
=head1 AUTHOR
-Copyright (C) 2011 by Daniel Friesel E<lt>derf@finalrewind.orgE<gt>
+Copyright (C) 2013 by Daniel Friesel E<lt>derf@finalrewind.orgE<gt>
=head1 LICENSE