summaryrefslogtreecommitdiff
path: root/lib/Travel/Status/DE
diff options
context:
space:
mode:
authorDaniel Friesel <derf@finalrewind.org>2015-04-18 20:28:49 +0200
committerDaniel Friesel <derf@finalrewind.org>2015-04-18 20:28:49 +0200
commitef40feb961f363029d98524b62a38a977823bb2b (patch)
tree645534359fe155d0991bba458b8f6f491064ce5b /lib/Travel/Status/DE
parent70033e0073c04903e228f0535bf68d55106779e0 (diff)
Start work on wings support
Diffstat (limited to 'lib/Travel/Status/DE')
-rw-r--r--lib/Travel/Status/DE/IRIS.pm52
-rw-r--r--lib/Travel/Status/DE/IRIS/Result.pm32
2 files changed, 80 insertions, 4 deletions
diff --git a/lib/Travel/Status/DE/IRIS.pm b/lib/Travel/Status/DE/IRIS.pm
index ae614dc..da39a7c 100644
--- a/lib/Travel/Status/DE/IRIS.pm
+++ b/lib/Travel/Status/DE/IRIS.pm
@@ -13,6 +13,7 @@ use DateTime;
use Encode qw(encode decode);
use List::Util qw(first);
use LWP::UserAgent;
+use Scalar::Util qw(weaken);
use Travel::Status::DE::IRIS::Result;
use XML::LibXML;
@@ -96,6 +97,10 @@ sub new {
@{ $self->{results} }
= sort { $a->{datetime} <=> $b->{datetime} } @{ $self->{results} };
+ # wings (different departures which are coupled as one train) contain
+ # references to each other. therefore, they must be processed last.
+ $self->create_wing_refs;
+
return $self;
}
@@ -128,8 +133,8 @@ sub add_result {
$data{route_pre} = $e_ar->getAttribute('ppth');
$data{route_start} = $e_ar->getAttribute('pde');
$data{transfer} = $e_ar->getAttribute('tra');
- $data{arrival_wings} = $e_ar->getAttribute('wings');
- $data{unk_ar_hi} = $e_ar->getAttribute('hi');
+ $data{arrival_wing_ids} = $e_ar->getAttribute('wings');
+ $data{unk_ar_hi} = $e_ar->getAttribute('hi');
}
if ($e_dp) {
@@ -138,8 +143,16 @@ sub add_result {
$data{route_post} = $e_dp->getAttribute('ppth');
$data{route_end} = $e_dp->getAttribute('pde');
$data{transfer} = $e_dp->getAttribute('tra');
- $data{departure_wings} = $e_dp->getAttribute('wings');
- $data{unk_dp_hi} = $e_dp->getAttribute('hi');
+ $data{departure_wing_ids} = $e_dp->getAttribute('wings');
+ $data{unk_dp_hi} = $e_dp->getAttribute('hi');
+ }
+
+ if ( $data{arrival_wing_ids} ) {
+ $data{arrival_wing_ids} = [ split( /\|/, $data{arrival_wing_ids} ) ];
+ }
+ if ( $data{departure_wing_ids} ) {
+ $data{departure_wing_ids}
+ = [ split( /\|/, $data{departure_wing_ids} ) ];
}
my $result = Travel::Status::DE::IRIS::Result->new(%data);
@@ -282,6 +295,37 @@ sub get_realtime {
return $self;
}
+sub get_result_by_id {
+ my ( $self, $id ) = @_;
+
+ my $res = first { $_->{raw_id} eq $id } $self->results;
+ return $res;
+}
+
+sub create_wing_refs {
+ my ($self) = @_;
+
+ for my $r ( $self->results ) {
+ if ( $r->{departure_wing_ids} ) {
+ for my $wing_id ( @{ $r->{departure_wing_ids} } ) {
+ my $wingref = $self->get_result_by_id($wing_id);
+ if ($wingref) {
+ $r->add_departure_wingref($wingref);
+ }
+ }
+ }
+ if ( $r->{arrival_wing_ids} ) {
+ for my $wing_id ( @{ $r->{arrival_wing_ids} } ) {
+ my $wingref = $self->get_result_by_id($wing_id);
+ if ($wingref) {
+ $r->add_departure_wingref($wingref);
+ }
+ }
+ }
+ }
+
+}
+
sub errstr {
my ($self) = @_;
diff --git a/lib/Travel/Status/DE/IRIS/Result.pm b/lib/Travel/Status/DE/IRIS/Result.pm
index d4e3821..e49750f 100644
--- a/lib/Travel/Status/DE/IRIS/Result.pm
+++ b/lib/Travel/Status/DE/IRIS/Result.pm
@@ -323,6 +323,20 @@ sub set_tl {
return $self;
}
+sub add_arrival_wingref {
+ my ( $self, $ref ) = @_;
+
+ weaken($ref);
+ push( @{ $self->{arrival_wings} }, $ref );
+}
+
+sub add_departure_wingref {
+ my ( $self, $ref ) = @_;
+
+ weaken($ref);
+ push( @{ $self->{departure_wings} }, $ref );
+}
+
# List::Compare does not keep the order of its arguments (even with unsorted).
# So we need to re-sort all stops to maintain their original order.
sub sorted_sublist {
@@ -434,6 +448,24 @@ sub delay_messages {
return @ret;
}
+sub arrival_wings {
+ my ($self) = @_;
+
+ if ( $self->{arrival_wings} ) {
+ return @{ $self->{arrival_wings} };
+ }
+ return;
+}
+
+sub departure_wings {
+ my ($self) = @_;
+
+ if ( $self->{departure_wings} ) {
+ return @{ $self->{departure_wings} };
+ }
+ return;
+}
+
sub dump_message_codes {
my ($self) = @_;