detect and merge duplicates caused by train ID changes

3 files changed, 52 insertions, 1 deletions

diff --git a/Changelog b/Changelog
index 2f89738..94152cd 100644
--- a/Changelog
+++ b/Changelog
@@ -3,6 +3,7 @@ git HEAD
     * IRIS / db-iris: Add lookahead option
     * db-iris: Fix --via not matching destination of trains with incomplete
       route data
+    * Detect and merge duplicate results caused by train ID changes
 
 Travel::Status::DE::IRIS 0.02 - Mon Feb 03 2014
 
diff --git a/lib/Travel/Status/DE/IRIS.pm b/lib/Travel/Status/DE/IRIS.pm
index 03aa89c..002f354 100644
--- a/lib/Travel/Status/DE/IRIS.pm
+++ b/lib/Travel/Status/DE/IRIS.pm
@@ -65,6 +65,25 @@ sub new {
 
 	$self->get_realtime;
 
+	# tra (transfer?) indicates a train changing its ID, so there are two
+	# results for the same train. Remove the departure-only trains from the
+	# result set and merge them with their arrival-only counterpairt.
+	# This way, in case the arrival is available but the departure isn't,
+	# nothing gets lost.
+	my @merge_candidates
+	  = grep { $_->transfer and $_->departure } @{ $self->{results} };
+	@{ $self->{results} }
+	  = grep { not( $_->transfer and $_->departure ) } @{ $self->{results} };
+
+	for my $transfer (@merge_candidates) {
+		my $result
+		  = first { $_->transfer and $_->transfer eq $transfer->train_id }
+		@{ $self->{results} };
+		if ($result) {
+			$result->merge_with_departure($transfer);
+		}
+	}
+
 	@{ $self->{results} } = grep {
 		my $d
 		  = ( $_->departure // $_->arrival )
@@ -106,6 +125,7 @@ sub add_result {
 		$data{platform}    = $e_ar->getAttribute('pp');    # string, not number!
 		$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');
 	}
 
@@ -114,6 +134,7 @@ sub add_result {
 		$data{platform}     = $e_dp->getAttribute('pp');   # string, not number!
 		$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');
 	}
 
diff --git a/lib/Travel/Status/DE/IRIS/Result.pm b/lib/Travel/Status/DE/IRIS/Result.pm
index d1993f4..a9a8a14 100644
--- a/lib/Travel/Status/DE/IRIS/Result.pm
+++ b/lib/Travel/Status/DE/IRIS/Result.pm
@@ -19,7 +19,7 @@ Travel::Status::DE::IRIS::Result->mk_ro_accessors(
 	qw(arrival classes date datetime delay departure is_cancelled line_no
 	  platform raw_id realtime_xml route_start route_end sched_arrival
 	  sched_departure sched_route_start sched_route_end start stop_no time
-	  train_id train_no type unknown_t unknown_o)
+	  train_id train_no transfer type unknown_t unknown_o)
 );
 
 sub new {
@@ -39,6 +39,11 @@ sub new {
 	$ref->{train_id} = $train_id;
 	$ref->{stop_no}  = $stop_no;
 
+	if ( $opt{transfer} ) {
+		my ($transfer) = split( /.\K-/, $opt{transfer} );
+		$ref->{transfer} = $transfer;
+	}
+
 	my $ar = $ref->{arrival} = $ref->{sched_arrival}
 	  = $strp->parse_datetime( $opt{arrival_ts} );
 	my $dp = $ref->{departure} = $ref->{sched_departure}
@@ -161,6 +166,30 @@ sub add_tl {
 	return $self;
 }
 
+sub merge_with_departure {
+	my ( $self, $result ) = @_;
+
+	# result must be departure-only
+
+	# departure is preferred over arrival, so overwrite default values
+	$self->{date}     = $result->{date};
+	$self->{time}     = $result->{time};
+	$self->{datetime} = $result->{datetime};
+	$self->{train_id} = $result->{train_id};    # TODO save old value
+	$self->{train_no} = $result->{train_no};    # TODO save old value
+
+	$self->{departure}        = $result->{departure};
+	$self->{departure_wings}  = $result->{departure_wings};
+	$self->{route_post}       = $result->{route_post};
+	$self->{sched_departure}  = $result->{sched_departure};
+	$self->{sched_route_post} = $result->{sched_route_post};
+
+	# update realtime info only if applicable
+	$self->{is_cancelled} ||= $result->{is_cancelled};
+
+	return $self;
+}
+
 sub origin {
 	my ($self) = @_;