HAFAS->new: support 'journey' requests. polylines and route still WiP

3 files changed, 257 insertions, 86 deletions

diff --git a/lib/Travel/Status/DE/HAFAS.pm b/lib/Travel/Status/DE/HAFAS.pm
index 769ff39..9270d2a 100644
--- a/lib/Travel/Status/DE/HAFAS.pm
+++ b/lib/Travel/Status/DE/HAFAS.pm
@@ -17,6 +17,7 @@ use List::Util qw(any);
 use LWP::UserAgent;
 use POSIX qw(strftime);
 use Travel::Status::DE::HAFAS::Message;
+use Travel::Status::DE::HAFAS::Polyline qw(decode_polyline);
 use Travel::Status::DE::HAFAS::Journey;
 use Travel::Status::DE::HAFAS::StopFinder;
 
@@ -186,7 +187,7 @@ sub new {
 		$ua->env_proxy;
 	}
 
-	if ( not $conf{station} ) {
+	if ( not $conf{station} and not $conf{journey} ) {
 		confess('You need to specify a station');
 	}
 
@@ -215,56 +216,80 @@ sub new {
 
 	bless( $self, $obj );
 
-	my $date = ( $conf{datetime} // $now )->strftime('%Y%m%d');
-	my $time = ( $conf{datetime} // $now )->strftime('%H%M%S');
-
-	my $lid;
-	if ( $self->{station} =~ m{ ^ [0-9]+ $ }x ) {
-		$lid = 'A=1@L=' . $self->{station} . '@';
+	my $req;
+
+	if ( $conf{journey} ) {
+		$req = {
+			svcReqL => [
+				{
+					meth => 'JourneyDetails',
+					req  => {
+						jid         => $conf{journey}{id},
+						name        => $conf{journey}{name} // '0',
+						getPolyline => $conf{with_polyline} ? \1 : \0,
+					},
+				}
+			],
+			%{ $hafas_instance{$service}{request} }
+		};
 	}
 	else {
-		$lid = 'A=1@O=' . $self->{station} . '@';
-	}
+		my $date = ( $conf{datetime} // $now )->strftime('%Y%m%d');
+		my $time = ( $conf{datetime} // $now )->strftime('%H%M%S');
 
-	my $mot_mask = 2**@{ $hafas_instance{$service}{productbits} } - 1;
+		my $lid;
+		if ( $self->{station} =~ m{ ^ [0-9]+ $ }x ) {
+			$lid = 'A=1@L=' . $self->{station} . '@';
+		}
+		else {
+			$lid = 'A=1@O=' . $self->{station} . '@';
+		}
 
-	my %mot_pos;
-	for my $i ( 0 .. $#{ $hafas_instance{$service}{productbits} } ) {
-		$mot_pos{ $hafas_instance{$service}{productbits}[$i] } = $i;
-	}
+		my $mot_mask = 2**@{ $hafas_instance{$service}{productbits} } - 1;
 
-	if ( my @mots = @{ $self->{exclusive_mots} // [] } ) {
-		$mot_mask = 0;
-		for my $mot (@mots) {
-			$mot_mask |= 1 << $mot_pos{$mot};
+		my %mot_pos;
+		for my $i ( 0 .. $#{ $hafas_instance{$service}{productbits} } ) {
+			$mot_pos{ $hafas_instance{$service}{productbits}[$i] } = $i;
 		}
-	}
 
-	if ( my @mots = @{ $self->{excluded_mots} // [] } ) {
-		for my $mot (@mots) {
-			$mot_mask &= ~( 1 << $mot_pos{$mot} );
+		if ( my @mots = @{ $self->{exclusive_mots} // [] } ) {
+			$mot_mask = 0;
+			for my $mot (@mots) {
+				$mot_mask |= 1 << $mot_pos{$mot};
+			}
 		}
-	}
 
-	my $req = {
-		svcReqL => [
-			{
-				req => {
-					type     => ( $conf{arrivals} ? 'ARR' : 'DEP' ),
-					stbLoc   => { lid => $lid },
-					dirLoc   => undef,
-					maxJny   => 30,
-					date     => $date,
-					time     => $time,
-					dur      => -1,
-					jnyFltrL =>
-					  [ { type => "PROD", mode => "INC", value => $mot_mask } ]
-				},
-				meth => 'StationBoard'
+		if ( my @mots = @{ $self->{excluded_mots} // [] } ) {
+			for my $mot (@mots) {
+				$mot_mask &= ~( 1 << $mot_pos{$mot} );
 			}
-		],
-		%{ $hafas_instance{$service}{request} }
-	};
+		}
+
+		$req = {
+			svcReqL => [
+				{
+					meth => 'StationBoard',
+					req  => {
+						type     => ( $conf{arrivals} ? 'ARR' : 'DEP' ),
+						stbLoc   => { lid => $lid },
+						dirLoc   => undef,
+						maxJny   => 30,
+						date     => $date,
+						time     => $time,
+						dur      => -1,
+						jnyFltrL => [
+							{
+								type  => "PROD",
+								mode  => "INC",
+								value => $mot_mask
+							}
+						]
+					},
+				},
+			],
+			%{ $hafas_instance{$service}{request} }
+		};
+	}
 
 	my $json = $self->{json} = JSON->new->utf8;
 
@@ -318,7 +343,18 @@ sub new {
 	}
 
 	$self->check_mgate;
-	$self->parse_mgate;
+
+	$self->{strptime_obj} //= DateTime::Format::Strptime->new(
+		pattern   => '%Y%m%dT%H%M%S',
+		time_zone => 'Europe/Berlin',
+	);
+
+	if ( $conf{journey} ) {
+		$self->parse_journey;
+	}
+	else {
+		$self->parse_board;
+	}
 
 	return $self;
 }
@@ -339,7 +375,7 @@ sub new_p {
 			my ($content) = @_;
 			$self->{raw_json} = $self->{json}->decode($content);
 			$self->check_mgate;
-			$self->parse_mgate;
+			$self->parse_board;
 			$promise->resolve($self);
 			return;
 		}
@@ -549,19 +585,44 @@ sub messages {
 	return @{ $self->{messages} };
 }
 
-sub parse_mgate {
+sub parse_journey {
 	my ($self) = @_;
 
-	$self->{results} = [];
-
 	if ( $self->{errstr} ) {
 		return $self;
 	}
 
-	$self->{strptime_obj} //= DateTime::Format::Strptime->new(
-		pattern   => '%Y%m%dT%H%M%S',
-		time_zone => 'Europe/Berlin',
+	my @locL    = @{ $self->{raw_json}{svcResL}[0]{res}{common}{locL} // [] };
+	my $journey = $self->{raw_json}{svcResL}[0]{res}{journey};
+	my @polyline;
+
+	if ( $journey->{poly} ) {
+		@polyline = decode_polyline( $journey->{poly}{crdEncYX} );
+		for my $ref ( @{ $journey->{poly}{ppLocRefL} // [] } ) {
+			my $poly = $polyline[ $ref->{ppIdx} ];
+			my $loc  = $locL[ $ref->{locX} ];
+
+			$poly->{name} = $loc->{name};
+			$poly->{eva}  = $loc->{extId} + 0;
+		}
+	}
+
+	$self->{result} = Travel::Status::DE::HAFAS::Journey->new(
+		common   => $self->{raw_json}{svcResL}[0]{res}{common},
+		journey  => $journey,
+		polyline => \@polyline,
+		hafas    => $self,
 	);
+}
+
+sub parse_board {
+	my ($self) = @_;
+
+	$self->{results} = [];
+
+	if ( $self->{errstr} ) {
+		return $self;
+	}
 
 	my @jnyL = @{ $self->{raw_json}{svcResL}[0]{res}{jnyL} // [] };
 
@@ -583,6 +644,11 @@ sub results {
 	return @{ $self->{results} };
 }
 
+sub result {
+	my ($self) = @_;
+	return $self->{result};
+}
+
 # static
 sub get_services {
 	my @services;
diff --git a/lib/Travel/Status/DE/HAFAS/Journey.pm b/lib/Travel/Status/DE/HAFAS/Journey.pm
index 31675ba..da29804 100644
--- a/lib/Travel/Status/DE/HAFAS/Journey.pm
+++ b/lib/Travel/Status/DE/HAFAS/Journey.pm
@@ -29,26 +29,10 @@ sub new {
 	my $journey = $opt{journey};
 
 	my $date = $journey->{date};
-	my $time_s
-	  = $journey->{stbStop}{ $hafas->{arrivals} ? 'aTimeS' : 'dTimeS' };
-	my $time_r
-	  = $journey->{stbStop}{ $hafas->{arrivals} ? 'aTimeR' : 'dTimeR' };
-	my $datetime_s
-	  = $hafas->{strptime_obj}->parse_datetime("${date}T${time_s}");
-	my $datetime_r
-	  = $time_r
-	  ? $hafas->{strptime_obj}->parse_datetime("${date}T${time_r}")
-	  : undef;
-	my $delay
-	  = $datetime_r
-	  ? ( $datetime_r->epoch - $datetime_s->epoch ) / 60
-	  : undef;
 
 	my $destination  = $journey->{dirTxt};
 	my $is_cancelled = $journey->{isCncl};
 	my $jid          = $journey->{jid};
-	my $platform     = $journey->{stbStop}{dPlatfS};
-	my $new_platform = $journey->{stbStop}{dPlatfR};
 
 	my $product    = $prodL[ $journey->{prodX} ];
 	my $train      = $product->{prodCtx}{name};
@@ -108,33 +92,58 @@ sub new {
 	shift @stops;
 
 	my $ref = {
-		sched_datetime => $datetime_s,
-		rt_datetime    => $datetime_r,
-		datetime       => $datetime_r // $datetime_s,
-		datetime_now   => $hafas->{now},
-		delay          => $delay,
-		is_cancelled   => $is_cancelled,
-		train          => $train,
-		operator       => $operator,
-		route_end      => $destination,
-		platform       => $platform,
-		new_platform   => $new_platform,
-		messages       => \@messages,
-		route          => \@stops,
+		datetime_now => $hafas->{now},
+		is_cancelled => $is_cancelled,
+		train        => $train,
+		operator     => $operator,
+		route_end    => $destination,
+		messages     => \@messages,
+		route        => \@stops,
 	};
 
 	bless( $ref, $obj );
 
-	if ( $ref->{delay} ) {
-		$ref->{datetime} = $ref->{rt_datetime};
+	if ( $journey->{stbStop} ) {
+		$ref->{platform}     = $journey->{stbStop}{dPlatfS};
+		$ref->{new_platform} = $journey->{stbStop}{dPlatfR};
+
+		my $time_s
+		  = $journey->{stbStop}{ $hafas->{arrivals} ? 'aTimeS' : 'dTimeS' };
+		my $time_r
+		  = $journey->{stbStop}{ $hafas->{arrivals} ? 'aTimeR' : 'dTimeR' };
+
+		my $datetime_s
+		  = $hafas->{strptime_obj}->parse_datetime("${date}T${time_s}");
+		my $datetime_r
+		  = $time_r
+		  ? $hafas->{strptime_obj}->parse_datetime("${date}T${time_r}")
+		  : undef;
+
+		my $delay
+		  = $datetime_r
+		  ? ( $datetime_r->epoch - $datetime_s->epoch ) / 60
+		  : undef;
+
+		$ref->{sched_datetime} = $datetime_s;
+		$ref->{rt_datetime}    = $datetime_r;
+		$ref->{datetime}       = $datetime_r // $datetime_s;
+		$ref->{delay}          = $delay;
+
+		if ( $ref->{delay} ) {
+			$ref->{datetime} = $ref->{rt_datetime};
+		}
+		else {
+			$ref->{datetime} = $ref->{sched_datetime};
+		}
+
+		$ref->{date}       = $ref->{datetime}->strftime('%d.%m.%Y');
+		$ref->{time}       = $ref->{datetime}->strftime('%H:%M');
+		$ref->{sched_date} = $ref->{sched_datetime}->strftime('%d.%m.%Y');
+		$ref->{sched_time} = $ref->{sched_datetime}->strftime('%H:%M');
 	}
-	else {
-		$ref->{datetime} = $ref->{sched_datetime};
+	if ( $opt{polyline} ) {
+		$ref->{polyline} = $opt{polyline};
 	}
-	$ref->{date}       = $ref->{datetime}->strftime('%d.%m.%Y');
-	$ref->{time}       = $ref->{datetime}->strftime('%H:%M');
-	$ref->{sched_date} = $ref->{sched_datetime}->strftime('%d.%m.%Y');
-	$ref->{sched_time} = $ref->{sched_datetime}->strftime('%H:%M');
 
 	return $ref;
 }
diff --git a/lib/Travel/Status/DE/HAFAS/Polyline.pm b/lib/Travel/Status/DE/HAFAS/Polyline.pm
new file mode 100644
index 0000000..2d82912
--- /dev/null
+++ b/lib/Travel/Status/DE/HAFAS/Polyline.pm
@@ -0,0 +1,96 @@
+package Travel::Status::DE::HAFAS::Polyline;
+
+use strict;
+use warnings;
+use 5.014;
+
+# Adapted from code by Slaven Rezic
+#
+# Copyright (C) 2009,2010,2012,2017,2018 Slaven Rezic. All rights reserved.
+# This package is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+#
+# Mail: slaven@rezic.de
+# WWW:  http://www.rezic.de/eserte/
+
+use parent 'Exporter';
+our @EXPORT_OK = qw(decode_polyline);
+our $VERSION   = '0.06';
+
+# Translated this php script
+# <http://unitstep.net/blog/2008/08/02/decoding-google-maps-encoded-polylines-using-php/>
+# to perl
+sub decode_polyline {
+	my ($encoded) = @_;
+
+	my $length = length $encoded;
+	my $index  = 0;
+	my @points;
+	my $lat = 0;
+	my $lng = 0;
+
+	while ( $index < $length ) {
+
+		# The encoded polyline consists of a latitude value followed
+		# by a longitude value. They should always come in pairs. Read
+		# the latitude value first.
+		for my $val ( \$lat, \$lng ) {
+			my $shift  = 0;
+			my $result = 0;
+
+			# Temporary variable to hold each ASCII byte.
+			my $b;
+			do {
+				# The `ord(substr($encoded, $index++))` statement returns
+				# the ASCII code for the character at $index. Subtract 63
+				# to get the original value. (63 was added to ensure
+				# proper ASCII characters are displayed in the encoded
+				# polyline string, which is `human` readable)
+				$b = ord( substr( $encoded, $index++, 1 ) ) - 63;
+
+				# AND the bits of the byte with 0x1f to get the original
+				# 5-bit `chunk. Then left shift the bits by the required
+				# amount, which increases by 5 bits each time. OR the
+				# value into $results, which sums up the individual 5-bit
+				# chunks into the original value. Since the 5-bit chunks
+				# were reversed in order during encoding, reading them in
+				# this way ensures proper summation.
+				$result |= ( $b & 0x1f ) << $shift;
+				$shift += 5;
+			  }
+
+			  # Continue while the read byte is >= 0x20 since the last
+			  # `chunk` was not OR'd with 0x20 during the conversion
+			  # process. (Signals the end)
+			  while ( $b >= 0x20 );
+
+			# see last paragraph of "Integer Arithmetic" in perlop.pod
+			use integer;
+
+        # Check if negative, and convert. (All negative values have the last bit
+        # set)
+			my $dtmp
+			  = ( ( $result & 1 ) ? ~( $result >> 1 ) : ( $result >> 1 ) );
+
+			# Compute actual latitude (resp. longitude) since value is
+			# offset from previous value.
+			$$val += $dtmp;
+		}
+
+		# The actual latitude and longitude values were multiplied by
+		# 1e5 before encoding so that they could be converted to a 32-bit
+		# integer representation. (With a decimal accuracy of 5 places)
+		# Convert back to original values.
+		push(
+			@points,
+			{
+				lat => $lat * 1e-5,
+				lon => $lng * 1e-5
+			}
+		);
+	}
+
+	return @points;
+}
+
+1;