diff options
| -rw-r--r-- | lib/Travel/Status/DE/EFA.pm | 476 | ||||
| -rw-r--r-- | lib/Travel/Status/DE/EFA/Line.pm (renamed from lib/Travel/Status/DE/VRR/Line.pm) | 20 | ||||
| -rw-r--r-- | lib/Travel/Status/DE/EFA/Result.pm (renamed from lib/Travel/Status/DE/VRR/Result.pm) | 20 | ||||
| -rw-r--r-- | lib/Travel/Status/DE/VRR.pm | 406 | ||||
| -rw-r--r-- | t/20-vrr.t | 4 |
5 files changed, 516 insertions, 410 deletions
diff --git a/lib/Travel/Status/DE/EFA.pm b/lib/Travel/Status/DE/EFA.pm new file mode 100644 index 0000000..4391a72 --- /dev/null +++ b/lib/Travel/Status/DE/EFA.pm @@ -0,0 +1,476 @@ +package Travel::Status::DE::EFA; + +use strict; +use warnings; +use 5.010; + +no if $] >= 5.018, warnings => "experimental::smartmatch"; + +our $VERSION = '1.05'; + +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{ ^ (?<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( $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.05 + +=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<opts> and returns a new +Travel::Status::DE::EFA 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). + +=item B<name> => I<name> + +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 by Daniel Friesel E<lt>derf@finalrewind.orgE<gt> + +=head1 LICENSE + +This module is licensed under the same terms as Perl itself. diff --git a/lib/Travel/Status/DE/VRR/Line.pm b/lib/Travel/Status/DE/EFA/Line.pm index 27a39a2..8a22fe8 100644 --- a/lib/Travel/Status/DE/VRR/Line.pm +++ b/lib/Travel/Status/DE/EFA/Line.pm @@ -1,4 +1,4 @@ -package Travel::Status::DE::VRR::Line; +package Travel::Status::DE::EFA::Line; use strict; use warnings; @@ -8,7 +8,7 @@ use parent 'Class::Accessor'; our $VERSION = '1.05'; -Travel::Status::DE::VRR::Line->mk_ro_accessors( +Travel::Status::DE::EFA::Line->mk_ro_accessors( qw(direction name operator route type valid)); sub new { @@ -31,7 +31,7 @@ __END__ =head1 NAME -Travel::Status::DE::VRR::Line - Information about a line departing at the +Travel::Status::DE::EFA::Line - Information about a line departing at the requested station =head1 SYNOPSIS @@ -50,9 +50,9 @@ version 1.05 =head1 DESCRIPTION -Travel::Status::DE::VRR::Line describes a tram/bus/train line departing at the -stop requested by Travel::Status::DE::VRR. Note that it only covers one -direction, so in most cases, you get two Travel::Status::DE::VRR::Line objects +Travel::Status::DE::EFA::Line describes a tram/bus/train line departing at the +stop requested by Travel::Status::DE::EFA. Note that it only covers one +direction, so in most cases, you get two Travel::Status::DE::EFA::Line objects per actual line. =head1 METHODS @@ -80,7 +80,7 @@ Partial route of the line (as string), usually start and destination with two stops in between. May be undefined. Note that start means the actual start of the line, the stop requested by -Travel::Status::DE::VRR::Line may not even be included in this listing. +Travel::Status::DE::EFA::Line may not even be included in this listing. =item $line->type @@ -97,9 +97,9 @@ When / how long above information is valid. =over -=item $line = Travel::Status::DE::VRR::Line->new(I<%data>) +=item $line = Travel::Status::DE::EFA::Line->new(I<%data>) -Returns a new Travel::Status::DE::VRR::Line object. You should not need to +Returns a new Travel::Status::DE::EFA::Line object. You should not need to call this. =item $line->TO_JSON @@ -126,7 +126,7 @@ The B<route> accessor returns a simple string, an array might be better suited. =head1 SEE ALSO -Travel::Status::DE::VRR(3pm). +Travel::Status::DE::EFA(3pm). =head1 AUTHOR diff --git a/lib/Travel/Status/DE/VRR/Result.pm b/lib/Travel/Status/DE/EFA/Result.pm index 8172b9a..c623f6e 100644 --- a/lib/Travel/Status/DE/VRR/Result.pm +++ b/lib/Travel/Status/DE/EFA/Result.pm @@ -1,4 +1,4 @@ -package Travel::Status::DE::VRR::Result; +package Travel::Status::DE::EFA::Result; use strict; use warnings; @@ -8,7 +8,7 @@ use parent 'Class::Accessor'; our $VERSION = '1.05'; -Travel::Status::DE::VRR::Result->mk_ro_accessors( +Travel::Status::DE::EFA::Result->mk_ro_accessors( qw(countdown date delay destination is_cancelled info key line lineref platform platform_db sched_date sched_time time type) ); @@ -41,8 +41,8 @@ __END__ =head1 NAME -Travel::Status::DE::VRR::Result - Information about a single -departure received by Travel::Status::DE::VRR +Travel::Status::DE::EFA::Result - Information about a single +departure received by Travel::Status::DE::EFA =head1 SYNOPSIS @@ -60,8 +60,8 @@ version 1.05 =head1 DESCRIPTION -Travel::Status::DE::VRR::Result describes a single departure as obtained by -Travel::Status::DE::VRR. It contains information about the time, platform, +Travel::Status::DE::EFA::Result describes a single departure as obtained by +Travel::Status::DE::EFA. It contains information about the time, platform, line number and destination. =head1 METHODS @@ -116,7 +116,7 @@ The name/number of the line. =item $departure->lineref -Travel::Status::DE::VRR::Line(3pm) object describing the departing line in +Travel::Status::DE::EFA::Line(3pm) object describing the departing line in detail. =item $departure->platform @@ -154,9 +154,9 @@ field. See L</DEPARTURE TYPES>. =over -=item $departure = Travel::Status::DE::VRR::Result->new(I<%data>) +=item $departure = Travel::Status::DE::EFA::Result->new(I<%data>) -Returns a new Travel::Status::DE::VRR::Result object. You should not need to +Returns a new Travel::Status::DE::EFA::Result object. You should not need to call this. =item $departure->TO_JSON @@ -214,7 +214,7 @@ interface. =head1 SEE ALSO -Travel::Status::DE::VRR(3pm). +Travel::Status::DE::EFA(3pm). =head1 AUTHOR 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 @@ -17,13 +17,13 @@ my $xml = slurp('t/in/essen_hb.xml'); my $status = Travel::Status::DE::VRR->new_from_xml(xml => $xml); -isa_ok($status, 'Travel::Status::DE::VRR'); +isa_ok($status, 'Travel::Status::DE::EFA'); can_ok($status, qw(errstr results)); my @results = $status->results; for my $result (@results) { - isa_ok($result, 'Travel::Status::DE::VRR::Result'); + isa_ok($result, 'Travel::Status::DE::EFA::Result'); can_ok($result, qw(date destination info line time type platform)); } |