From d64f9834b068d85293d7d42277d99c67163cb176 Mon Sep 17 00:00:00 2001 From: Daniel Friesel Date: Fri, 20 Dec 2013 11:19:24 +0100 Subject: Move EFA logic to ::EFA, just set URL in ::VRR --- lib/Travel/Status/DE/EFA.pm | 476 +++++++++++++++++++++++++++++++++++++ lib/Travel/Status/DE/EFA/Line.pm | 137 +++++++++++ lib/Travel/Status/DE/EFA/Result.pm | 225 ++++++++++++++++++ lib/Travel/Status/DE/VRR.pm | 406 ++----------------------------- lib/Travel/Status/DE/VRR/Line.pm | 137 ----------- lib/Travel/Status/DE/VRR/Result.pm | 225 ------------------ 6 files changed, 856 insertions(+), 750 deletions(-) create mode 100644 lib/Travel/Status/DE/EFA.pm create mode 100644 lib/Travel/Status/DE/EFA/Line.pm create mode 100644 lib/Travel/Status/DE/EFA/Result.pm delete mode 100644 lib/Travel/Status/DE/VRR/Line.pm delete mode 100644 lib/Travel/Status/DE/VRR/Result.pm (limited to 'lib/Travel/Status') 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{ ^ (? \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 => $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 and returns a new +Travel::Status::DE::EFA object. Dies if the wrong I were passed. + +Arguments: + +=over + +=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 by Daniel Friesel Ederf@finalrewind.orgE + +=head1 LICENSE + +This module is licensed under the same terms as Perl itself. diff --git a/lib/Travel/Status/DE/EFA/Line.pm b/lib/Travel/Status/DE/EFA/Line.pm new file mode 100644 index 0000000..8a22fe8 --- /dev/null +++ b/lib/Travel/Status/DE/EFA/Line.pm @@ -0,0 +1,137 @@ +package Travel::Status::DE::EFA::Line; + +use strict; +use warnings; +use 5.010; + +use parent 'Class::Accessor'; + +our $VERSION = '1.05'; + +Travel::Status::DE::EFA::Line->mk_ro_accessors( + qw(direction name operator route type valid)); + +sub new { + my ( $obj, %conf ) = @_; + + my $ref = \%conf; + + return bless( $ref, $obj ); +} + +sub TO_JSON { + my ($self) = @_; + + return { %{$self} }; +} + +1; + +__END__ + +=head1 NAME + +Travel::Status::DE::EFA::Line - Information about a line departing at the +requested station + +=head1 SYNOPSIS + + for my $line ($status->lines) { + printf( + "line %s -> %s\nRoute: %s\nType %s, operator %s\nValid: %s\n\n", + $line->name, $line->direction, $line->route, + $line->type, $line->operator, $line->valid + ); + } + +=head1 VERSION + +version 1.05 + +=head1 DESCRIPTION + +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 + +=head2 ACCESSORS + +=over + +=item $line->direction + +Direction of the line. Name of either the destination stop or one on the way. + +=item $line->name + +Name of the line, e.g. "U11", "SB15", "107". + +=item $line->operator + +Operator of the line, as in the local transit company responsible for it. +May be undefined. + +=item $line->route + +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::EFA::Line may not even be included in this listing. + +=item $line->type + +Type of the line. Observed values so far are "Bus", "NE", "StraEenbahn", +"U-Bahn". + +=item $line->valid + +When / how long above information is valid. + +=back + +=head2 INTERNAL + +=over + +=item $line = Travel::Status::DE::EFA::Line->new(I<%data>) + +Returns a new Travel::Status::DE::EFA::Line object. You should not need to +call this. + +=item $line->TO_JSON + +Allows the object data to be serialized to JSON. + +=back + +=head1 DIAGNOSTICS + +None. + +=head1 DEPENDENCIES + +=over + +=item Class::Accessor(3pm) + +=back + +=head1 BUGS AND LIMITATIONS + +The B accessor returns a simple string, an array might be better suited. + +=head1 SEE ALSO + +Travel::Status::DE::EFA(3pm). + +=head1 AUTHOR + +Copyright (C) 2011 by Daniel Friesel Ederf@finalrewind.orgE + +=head1 LICENSE + +This module is licensed under the same terms as Perl itself. diff --git a/lib/Travel/Status/DE/EFA/Result.pm b/lib/Travel/Status/DE/EFA/Result.pm new file mode 100644 index 0000000..c623f6e --- /dev/null +++ b/lib/Travel/Status/DE/EFA/Result.pm @@ -0,0 +1,225 @@ +package Travel::Status::DE::EFA::Result; + +use strict; +use warnings; +use 5.010; + +use parent 'Class::Accessor'; + +our $VERSION = '1.05'; + +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) +); + +sub new { + my ( $obj, %conf ) = @_; + + my $ref = \%conf; + + if ($ref->{delay} eq '-9999') { + $ref->{delay} = 0; + $ref->{is_cancelled} = 1; + } + else { + $ref->{is_cancelled} = 0; + } + + return bless( $ref, $obj ); +} + +sub TO_JSON { + my ($self) = @_; + + return { %{$self} }; +} + +1; + +__END__ + +=head1 NAME + +Travel::Status::DE::EFA::Result - Information about a single +departure received by Travel::Status::DE::EFA + +=head1 SYNOPSIS + + 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 1.05 + +=head1 DESCRIPTION + +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 + +=head2 ACCESSORS + +"Actual" in the description means that the delay (if available) is already +included in the calculation, "Scheduled" means it isn't. + +=over + +=item $departure->countdown + +Actual time in minutes from now until the tram/bus/train will depart. + +If delay information is available, it is already included. + +=item $departure->date + +Actual departure date (DD.MM.YYYY). + +=item $departure->delay + +Expected delay from scheduled departure time in minutes. A delay of 0 +indicates either departure on time or that no delay information is available. + +=item $departure->destination + +Destination name. + +=item $departure->info + +Additional information related to the departure (string). If departures for +an address were requested, this is the stop name, otherwise it may be recent +news related to the line's schedule. If no information is available, returns +an empty string. + +=item $departure->is_cancelled + +1 if the departure got cancelled, 0 otherwise. + +=item $departure->key + +Unknown. Unlike the name may suggest, this is not a unique key / UUID for a +departure: On the same day, different lines departing at the same station +may have the same key. It might, however, be unique when combined with the +B information. + +=item $departure->line + +The name/number of the line. + +=item $departure->lineref + +Travel::Status::DE::EFA::Line(3pm) object describing the departing line in +detail. + +=item $departure->platform + +Departure platform number. + +=item $departure->platform_db + +true if the platform number is operated by DB ("Gleis x"), false ("Bstg. x") +otherwise. + +Unfortunately, there is no distinction between tram and bus platforms yet, +which also may have the same numbers. + +=item $departure->sched_date + +Scheduled departure date (DD.MM.YYYY). + +=item $departure->sched_time + +Scheduled departure time (HH:MM). + +=item $departure->time + +Actual departure time (HH:MM). + +=item $departure->type + +Type of the departure. Note that efa.vrr.de sometimes puts bogus data in this +field. See L. + +=back + +=head2 INTERNAL + +=over + +=item $departure = Travel::Status::DE::EFA::Result->new(I<%data>) + +Returns a new Travel::Status::DE::EFA::Result object. You should not need to +call this. + +=item $departure->TO_JSON + +Allows the object data to be serialized to JSON. + +=back + +=head1 DEPARTURE TYPES + +The following are known so far: + +=over + +=item * Abellio-Zug + +=item * Bus + +=item * Eurocity + +=item * Intercity-Express + +=item * NE (NachtExpress / night bus) + +=item * Niederflurbus + +=item * R-Bahn (RE / RegionalExpress) + +=item * S-Bahn + +=item * SB (Schnellbus) + +=item * StraEenbahn + +=item * U-Bahn + +=back + +=head1 DIAGNOSTICS + +None. + +=head1 DEPENDENCIES + +=over + +=item Class::Accessor(3pm) + +=back + +=head1 BUGS AND LIMITATIONS + +C<< $result->type >> may contain bogus data. This comes from the efa.vrr.de +interface. + +=head1 SEE ALSO + +Travel::Status::DE::EFA(3pm). + +=head1 AUTHOR + +Copyright (C) 2011 by Daniel Friesel Ederf@finalrewind.orgE + +=head1 LICENSE + +This module is licensed under the same terms as Perl itself. 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{ ^ (? \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 => $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. -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 and returns a new -Travel::Status::DE::VRR object. Dies if the wrong I were passed. - -Arguments: - -=over - -=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). +Travel::Status::DE::VRR object. -=item B => I +Calls Travel::Status::DE::EFA->new with the appropriate B. +All I 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 Ederf@finalrewind.orgE +Copyright (C) 2013 by Daniel Friesel Ederf@finalrewind.orgE =head1 LICENSE diff --git a/lib/Travel/Status/DE/VRR/Line.pm b/lib/Travel/Status/DE/VRR/Line.pm deleted file mode 100644 index 27a39a2..0000000 --- a/lib/Travel/Status/DE/VRR/Line.pm +++ /dev/null @@ -1,137 +0,0 @@ -package Travel::Status::DE::VRR::Line; - -use strict; -use warnings; -use 5.010; - -use parent 'Class::Accessor'; - -our $VERSION = '1.05'; - -Travel::Status::DE::VRR::Line->mk_ro_accessors( - qw(direction name operator route type valid)); - -sub new { - my ( $obj, %conf ) = @_; - - my $ref = \%conf; - - return bless( $ref, $obj ); -} - -sub TO_JSON { - my ($self) = @_; - - return { %{$self} }; -} - -1; - -__END__ - -=head1 NAME - -Travel::Status::DE::VRR::Line - Information about a line departing at the -requested station - -=head1 SYNOPSIS - - for my $line ($status->lines) { - printf( - "line %s -> %s\nRoute: %s\nType %s, operator %s\nValid: %s\n\n", - $line->name, $line->direction, $line->route, - $line->type, $line->operator, $line->valid - ); - } - -=head1 VERSION - -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 -per actual line. - -=head1 METHODS - -=head2 ACCESSORS - -=over - -=item $line->direction - -Direction of the line. Name of either the destination stop or one on the way. - -=item $line->name - -Name of the line, e.g. "U11", "SB15", "107". - -=item $line->operator - -Operator of the line, as in the local transit company responsible for it. -May be undefined. - -=item $line->route - -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. - -=item $line->type - -Type of the line. Observed values so far are "Bus", "NE", "StraEenbahn", -"U-Bahn". - -=item $line->valid - -When / how long above information is valid. - -=back - -=head2 INTERNAL - -=over - -=item $line = Travel::Status::DE::VRR::Line->new(I<%data>) - -Returns a new Travel::Status::DE::VRR::Line object. You should not need to -call this. - -=item $line->TO_JSON - -Allows the object data to be serialized to JSON. - -=back - -=head1 DIAGNOSTICS - -None. - -=head1 DEPENDENCIES - -=over - -=item Class::Accessor(3pm) - -=back - -=head1 BUGS AND LIMITATIONS - -The B accessor returns a simple string, an array might be better suited. - -=head1 SEE ALSO - -Travel::Status::DE::VRR(3pm). - -=head1 AUTHOR - -Copyright (C) 2011 by Daniel Friesel Ederf@finalrewind.orgE - -=head1 LICENSE - -This module is licensed under the same terms as Perl itself. diff --git a/lib/Travel/Status/DE/VRR/Result.pm b/lib/Travel/Status/DE/VRR/Result.pm deleted file mode 100644 index 8172b9a..0000000 --- a/lib/Travel/Status/DE/VRR/Result.pm +++ /dev/null @@ -1,225 +0,0 @@ -package Travel::Status::DE::VRR::Result; - -use strict; -use warnings; -use 5.010; - -use parent 'Class::Accessor'; - -our $VERSION = '1.05'; - -Travel::Status::DE::VRR::Result->mk_ro_accessors( - qw(countdown date delay destination is_cancelled info key line lineref platform - platform_db sched_date sched_time time type) -); - -sub new { - my ( $obj, %conf ) = @_; - - my $ref = \%conf; - - if ($ref->{delay} eq '-9999') { - $ref->{delay} = 0; - $ref->{is_cancelled} = 1; - } - else { - $ref->{is_cancelled} = 0; - } - - return bless( $ref, $obj ); -} - -sub TO_JSON { - my ($self) = @_; - - return { %{$self} }; -} - -1; - -__END__ - -=head1 NAME - -Travel::Status::DE::VRR::Result - Information about a single -departure received by Travel::Status::DE::VRR - -=head1 SYNOPSIS - - 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 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, -line number and destination. - -=head1 METHODS - -=head2 ACCESSORS - -"Actual" in the description means that the delay (if available) is already -included in the calculation, "Scheduled" means it isn't. - -=over - -=item $departure->countdown - -Actual time in minutes from now until the tram/bus/train will depart. - -If delay information is available, it is already included. - -=item $departure->date - -Actual departure date (DD.MM.YYYY). - -=item $departure->delay - -Expected delay from scheduled departure time in minutes. A delay of 0 -indicates either departure on time or that no delay information is available. - -=item $departure->destination - -Destination name. - -=item $departure->info - -Additional information related to the departure (string). If departures for -an address were requested, this is the stop name, otherwise it may be recent -news related to the line's schedule. If no information is available, returns -an empty string. - -=item $departure->is_cancelled - -1 if the departure got cancelled, 0 otherwise. - -=item $departure->key - -Unknown. Unlike the name may suggest, this is not a unique key / UUID for a -departure: On the same day, different lines departing at the same station -may have the same key. It might, however, be unique when combined with the -B information. - -=item $departure->line - -The name/number of the line. - -=item $departure->lineref - -Travel::Status::DE::VRR::Line(3pm) object describing the departing line in -detail. - -=item $departure->platform - -Departure platform number. - -=item $departure->platform_db - -true if the platform number is operated by DB ("Gleis x"), false ("Bstg. x") -otherwise. - -Unfortunately, there is no distinction between tram and bus platforms yet, -which also may have the same numbers. - -=item $departure->sched_date - -Scheduled departure date (DD.MM.YYYY). - -=item $departure->sched_time - -Scheduled departure time (HH:MM). - -=item $departure->time - -Actual departure time (HH:MM). - -=item $departure->type - -Type of the departure. Note that efa.vrr.de sometimes puts bogus data in this -field. See L. - -=back - -=head2 INTERNAL - -=over - -=item $departure = Travel::Status::DE::VRR::Result->new(I<%data>) - -Returns a new Travel::Status::DE::VRR::Result object. You should not need to -call this. - -=item $departure->TO_JSON - -Allows the object data to be serialized to JSON. - -=back - -=head1 DEPARTURE TYPES - -The following are known so far: - -=over - -=item * Abellio-Zug - -=item * Bus - -=item * Eurocity - -=item * Intercity-Express - -=item * NE (NachtExpress / night bus) - -=item * Niederflurbus - -=item * R-Bahn (RE / RegionalExpress) - -=item * S-Bahn - -=item * SB (Schnellbus) - -=item * StraEenbahn - -=item * U-Bahn - -=back - -=head1 DIAGNOSTICS - -None. - -=head1 DEPENDENCIES - -=over - -=item Class::Accessor(3pm) - -=back - -=head1 BUGS AND LIMITATIONS - -C<< $result->type >> may contain bogus data. This comes from the efa.vrr.de -interface. - -=head1 SEE ALSO - -Travel::Status::DE::VRR(3pm). - -=head1 AUTHOR - -Copyright (C) 2011 by Daniel Friesel Ederf@finalrewind.orgE - -=head1 LICENSE - -This module is licensed under the same terms as Perl itself. -- cgit v1.2.3