Preliminary support for stop-specific operators / operator changes (#10)

4 files changed, 256 insertions, 53 deletions

diff --git a/lib/Travel/Status/DE/HAFAS.pm b/lib/Travel/Status/DE/HAFAS.pm
index 0489901..cbd23cc 100644
--- a/lib/Travel/Status/DE/HAFAS.pm
+++ b/lib/Travel/Status/DE/HAFAS.pm
@@ -18,6 +18,7 @@ use Travel::Status::DE::HAFAS::Journey;
 use Travel::Status::DE::HAFAS::Location;
 use Travel::Status::DE::HAFAS::Message;
 use Travel::Status::DE::HAFAS::Polyline qw(decode_polyline);
+use Travel::Status::DE::HAFAS::Product;
 use Travel::Status::DE::HAFAS::StopFinder;
 
 our $VERSION = '5.05';
@@ -702,6 +703,20 @@ sub add_message {
 	return $message;
 }
 
+sub parse_prodL {
+	my ($self) = @_;
+
+	my $common = $self->{raw_json}{svcResL}[0]{res}{common};
+	return [
+		map {
+			Travel::Status::DE::HAFAS::Product->new(
+				common  => $common,
+				product => $_
+			)
+		} @{ $common->{prodL} }
+	];
+}
+
 sub parse_search {
 	my ($self) = @_;
 
@@ -730,6 +745,8 @@ sub parse_journey {
 		return $self;
 	}
 
+	my $prodL = $self->parse_prodL;
+
 	my @locL = map { Travel::Status::DE::HAFAS::Location->new( loc => $_ ) }
 	  @{ $self->{raw_json}{svcResL}[0]{res}{common}{locL} // [] };
 	my $journey = $self->{raw_json}{svcResL}[0]{res}{journey};
@@ -748,6 +765,7 @@ sub parse_journey {
 
 	$self->{result} = Travel::Status::DE::HAFAS::Journey->new(
 		common   => $self->{raw_json}{svcResL}[0]{res}{common},
+		prodL    => $prodL,
 		locL     => \@locL,
 		journey  => $journey,
 		polyline => \@polyline,
@@ -766,6 +784,8 @@ sub parse_journey_match {
 		return $self;
 	}
 
+	my $prodL = $self->parse_prodL;
+
 	my @locL = map { Travel::Status::DE::HAFAS::Location->new( loc => $_ ) }
 	  @{ $self->{raw_json}{svcResL}[0]{res}{common}{locL} // [] };
 
@@ -776,6 +796,7 @@ sub parse_journey_match {
 			@{ $self->{results} },
 			Travel::Status::DE::HAFAS::Journey->new(
 				common  => $self->{raw_json}{svcResL}[0]{res}{common},
+				prodL   => $prodL,
 				locL    => \@locL,
 				journey => $result,
 				hafas   => $self,
@@ -794,6 +815,8 @@ sub parse_board {
 		return $self;
 	}
 
+	my $prodL = $self->parse_prodL;
+
 	my @locL = map { Travel::Status::DE::HAFAS::Location->new( loc => $_ ) }
 	  @{ $self->{raw_json}{svcResL}[0]{res}{common}{locL} // [] };
 	my @jnyL = @{ $self->{raw_json}{svcResL}[0]{res}{jnyL} // [] };
@@ -803,6 +826,7 @@ sub parse_board {
 			@{ $self->{results} },
 			Travel::Status::DE::HAFAS::Journey->new(
 				common  => $self->{raw_json}{svcResL}[0]{res}{common},
+				prodL   => $prodL,
 				locL    => \@locL,
 				journey => $result,
 				hafas   => $self,
diff --git a/lib/Travel/Status/DE/HAFAS/Journey.pm b/lib/Travel/Status/DE/HAFAS/Journey.pm
index 77d5748..6a36c22 100644
--- a/lib/Travel/Status/DE/HAFAS/Journey.pm
+++ b/lib/Travel/Status/DE/HAFAS/Journey.pm
@@ -26,13 +26,12 @@ Travel::Status::DE::HAFAS::Journey->mk_ro_accessors(
 sub new {
 	my ( $obj, %opt ) = @_;
 
-	my @prodL = @{ $opt{common}{prodL} // [] };
-	my @opL   = @{ $opt{common}{opL}   // [] };
 	my @icoL  = @{ $opt{common}{icoL}  // [] };
 	my @tcocL = @{ $opt{common}{tcocL} // [] };
 	my @remL  = @{ $opt{common}{remL}  // [] };
 	my @himL  = @{ $opt{common}{himL}  // [] };
 
+	my $prodL   = $opt{prodL};
 	my $locL    = $opt{locL};
 	my $hafas   = $opt{hafas};
 	my $journey = $opt{journey};
@@ -45,34 +44,7 @@ sub new {
 	my $is_cancelled        = $journey->{isCncl};
 	my $partially_cancelled = $journey->{isPartCncl};
 
-	my $product  = $prodL[ $journey->{prodX} ];
-	my $name     = $product->{addName} // $product->{name};
-	my $line_no  = $product->{prodCtx}{line};
-	my $train_no = $product->{prodCtx}{num};
-	my $cat      = $product->{prodCtx}{catOut};
-	my $catlong  = $product->{prodCtx}{catOutL};
-	if ( $name and $cat and $name eq $cat and $product->{nameS} ) {
-		$name .= ' ' . $product->{nameS};
-	}
-	if ( defined $train_no and not $train_no ) {
-		$train_no = undef;
-	}
-	if (
-		    not defined $line_no
-		and defined $product->{prodCtx}{matchId}
-		and
-		( not defined $train_no or $product->{prodCtx}{matchId} ne $train_no )
-	  )
-	{
-		$line_no = $product->{prodCtx}{matchId};
-	}
-
-	my $operator;
-	if ( defined $product->{oprX} ) {
-		if ( my $opref = $opL[ $product->{oprX} ] ) {
-			$operator = $opref->{name};
-		}
-	}
+	my $product = $prodL->[ $journey->{prodX} ];
 
 	my @messages;
 	for my $msg ( @{ $journey->{msgL} // [] } ) {
@@ -89,25 +61,33 @@ sub new {
 
 	my $datetime_ref;
 
-	if ( @{ $journey->{stopL} // [] } or $journey->{stbStop}) {
-		my ($date_ref, $parse_fmt);
-		if ($jid =~ /#/) {
+	if ( @{ $journey->{stopL} // [] } or $journey->{stbStop} ) {
+		my ( $date_ref, $parse_fmt );
+		if ( $jid =~ /#/ ) {
+
 			# ÖBB Journey ID - technically we ought to use Europe/Vienna tz
 			#  but let's not get into that...
-			$date_ref = ( split( /#/, $jid ) )[12];
+			$date_ref  = ( split( /#/, $jid ) )[12];
 			$parse_fmt = '%d%m%y';
 			if ( length($date_ref) < 5 ) {
-				warn("HAFAS, not even once -- midnight crossing may be bogus -- date_ref $date_ref");
-			} elsif ( length($date_ref) == 5 ) {
+				warn(
+"HAFAS, not even once -- midnight crossing may be bogus -- date_ref $date_ref"
+				);
+			}
+			elsif ( length($date_ref) == 5 ) {
 				$date_ref = "0${date_ref}";
 			}
-		} else {
+		}
+		else {
 			# DB Journey ID
-			$date_ref = ( split( qr{[|]}, $jid ) )[4];
+			$date_ref  = ( split( qr{[|]}, $jid ) )[4];
 			$parse_fmt = '%d%m%Y';
 			if ( length($date_ref) < 7 ) {
-				warn("HAFAS, not even once -- midnight crossing may be bogus -- date_ref $date_ref");
-			} elsif ( length($date_ref) == 7 ) {
+				warn(
+"HAFAS, not even once -- midnight crossing may be bogus -- date_ref $date_ref"
+				);
+			}
+			elsif ( length($date_ref) == 7 ) {
 				$date_ref = "0${date_ref}";
 			}
 		}
@@ -117,8 +97,6 @@ sub new {
 		)->parse_datetime($date_ref);
 	}
 
-	my $class = $product->{cls};
-
 	my @stops;
 	my $route_end;
 	for my $stop ( @{ $journey->{stopL} // [] } ) {
@@ -128,6 +106,7 @@ sub new {
 			loc          => $loc,
 			stop         => $stop,
 			common       => $opt{common},
+			prodL        => $prodL,
 			hafas        => $hafas,
 			date         => $date,
 			datetime_ref => $datetime_ref,
@@ -150,14 +129,15 @@ sub new {
 
 	my $ref = {
 		id                     => $jid,
-		name                   => $name,
-		number                 => $train_no,
-		line                   => $name,
-		line_no                => $line_no,
-		type                   => $cat,
-		type_long              => $catlong,
-		class                  => $class,
-		operator               => $operator,
+		product                => $product,
+		name                   => $product->name,
+		number                 => $product->number,
+		line                   => $product->name,
+		line_no                => $product->line_no,
+		type                   => $product->type,
+		type_long              => $product->type_long,
+		class                  => $product->class,
+		operator               => $product->operator,
 		direction              => $direction,
 		is_cancelled           => $is_cancelled,
 		is_partially_cancelled => $partially_cancelled,
diff --git a/lib/Travel/Status/DE/HAFAS/Product.pm b/lib/Travel/Status/DE/HAFAS/Product.pm
new file mode 100644
index 0000000..5e45232
--- /dev/null
+++ b/lib/Travel/Status/DE/HAFAS/Product.pm
@@ -0,0 +1,181 @@
+package Travel::Status::DE::HAFAS::Product;
+
+# vim:foldmethod=marker
+
+use strict;
+use warnings;
+use 5.014;
+
+use parent 'Class::Accessor';
+
+our $VERSION = '5.05';
+
+Travel::Status::DE::HAFAS::Product->mk_ro_accessors(
+	qw(name type type_long class number line line_no operator)
+);
+
+# {{{ Constructor
+
+sub new {
+	my ( $obj, %opt ) = @_;
+
+	my $product      = $opt{product};
+	my $common       = $opt{common};
+	my $opL = $common->{opL};
+
+	my $class = $product->{cls};
+	my $name     = $product->{addName} // $product->{name};
+	my $line_no  = $product->{prodCtx}{line};
+	my $train_no = $product->{prodCtx}{num};
+	my $cat      = $product->{prodCtx}{catOut};
+	my $catlong  = $product->{prodCtx}{catOutL};
+	if ( $name and $cat and $name eq $cat and $product->{nameS} ) {
+		$name .= ' ' . $product->{nameS};
+	}
+	if ( defined $train_no and not $train_no ) {
+		$train_no = undef;
+	}
+	if (
+		    not defined $line_no
+		and defined $product->{prodCtx}{matchId}
+		and
+		( not defined $train_no or $product->{prodCtx}{matchId} ne $train_no )
+	  )
+	{
+		$line_no = $product->{prodCtx}{matchId};
+	}
+
+	my $operator;
+	if ( defined $product->{oprX} ) {
+		if ( my $opref = $opL->[ $product->{oprX} ] ) {
+			$operator = $opref->{name};
+		}
+	}
+
+	my $ref = {
+		name                   => $name,
+		number                 => $train_no,
+		line                   => $name,
+		line_no                => $line_no,
+		type                   => $cat,
+		type_long              => $catlong,
+		class                  => $class,
+		operator               => $operator,
+	};
+
+	bless( $ref, $obj );
+
+	return $ref;
+}
+
+# }}}
+
+sub TO_JSON {
+	my ($self) = @_;
+
+	return { %{$self} };
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Travel::Status::DE::HAFAS::Product - Information about a HAFAS product
+associated with a journey.
+
+=head1 SYNOPSIS
+
+=head1 VERSION
+
+version 5.05
+
+=head1 DESCRIPTION
+
+Travel::Status::DE::HAFAS::Product describes a product (e.g. train or bus)
+associated with a Travel::Status::DE::HAFAS::Journey(3pm) or one of its
+stops.
+
+=head1 METHODS
+
+=head2 ACCESSORS
+
+=over
+
+=item $product->name
+
+Journey or line name, either in a format like "Bus SB16" (Bus line
+SB16) or "RE 10111" (RegionalExpress train 10111, no line information).  May
+contain extraneous whitespace characters.
+
+=item $product->type
+
+Type of this journey, e.g. "S" for S-Bahn, "RE" for Regional Express
+or "STR" for tram / StraE<szlig>enbahn.
+
+=item $product->type_long
+
+Long type of this journey, e.g. "S-Bahn" or "Regional-Express".
+
+=item $product->class
+
+An integer identifying the the mode of transport class.
+Semantics depend on backend, e.g. "1" and "2" for long-distance trains and
+"4" and "8" for regional trains.
+
+=item $product->line
+
+Journey or line name, either in a format like "Bus SB16" (Bus line
+SB16), "RE 42" (RegionalExpress train 42) or "IC 2901" (InterCity train 2901,
+no line information).  May contain extraneous whitespace characters.  Note that
+this accessor does not return line information for IC/ICE/EC services, even if
+it is available. Use B<line_no> for those.
+
+=item $product->line_no
+
+Line identifier, or undef if it is unknown.
+The line identifier may be a single number such as "11" (underground train
+line U 11), a single word (e.g. "AIR") or a combination (e.g. "SB16").
+May also provide line numbers of IC/ICE services.
+
+=item $product->number
+
+Journey number (e.g. train number), or undef if it is unknown.
+
+=item $product->operator
+
+The operator responsible for this journey. Returns undef
+if the backend does not provide an operator.
+
+Foo.
+
+=back
+
+=head1 DIAGNOSTICS
+
+None.
+
+=head1 DEPENDENCIES
+
+=over
+
+=item Class::Accessor(3pm)
+
+=back
+
+=head1 BUGS AND LIMITATIONS
+
+None known.
+
+=head1 SEE ALSO
+
+Travel::Status::DE::HAFAS(3pm).
+
+=head1 AUTHOR
+
+Copyright (C) 2024 by Birte Kristina 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/HAFAS/Stop.pm b/lib/Travel/Status/DE/HAFAS/Stop.pm
index 8c63a98..3b8391c 100644
--- a/lib/Travel/Status/DE/HAFAS/Stop.pm
+++ b/lib/Travel/Status/DE/HAFAS/Stop.pm
@@ -12,8 +12,8 @@ our $VERSION = '5.05';
 
 Travel::Status::DE::HAFAS::Stop->mk_ro_accessors(
 	qw(loc
-	  rt_arr sched_arr arr arr_delay arr_cancelled
-	  rt_dep sched_dep dep dep_delay dep_cancelled
+	  rt_arr sched_arr arr arr_delay arr_cancelled prod_arr
+	  rt_dep sched_dep dep dep_delay dep_cancelled prod_dep
 	  delay direction
 	  rt_platform sched_platform platform is_changed_platform
 	  is_additional
@@ -28,6 +28,7 @@ sub new {
 
 	my $stop         = $opt{stop};
 	my $common       = $opt{common};
+	my $prodL        = $opt{prodL};
 	my $date         = $opt{date};
 	my $datetime_ref = $opt{datetime_ref};
 	my $hafas        = $opt{hafas};
@@ -38,6 +39,11 @@ sub new {
 	my $sched_dep = $stop->{dTimeS};
 	my $rt_dep    = $stop->{dTimeR};
 
+	my $prod_arr
+	  = defined $stop->{aProdX} ? $prodL->[ $stop->{aProdX} ] : undef;
+	my $prod_dep
+	  = defined $stop->{dProdX} ? $prodL->[ $stop->{dProdX} ] : undef;
+
 	# dIn. / aOut. -> may passengers enter / exit the train?
 
 	my $sched_platform   = $stop->{aPlatfS}  // $stop->{dPlatfS};
@@ -100,11 +106,13 @@ sub new {
 		arr                 => $rt_arr // $sched_arr,
 		arr_delay           => $arr_delay,
 		arr_cancelled       => $arr_cancelled,
+		prod_arr            => $prod_arr,
 		sched_dep           => $sched_dep,
 		rt_dep              => $rt_dep,
 		dep                 => $rt_dep // $sched_dep,
 		dep_delay           => $dep_delay,
 		dep_cancelled       => $dep_cancelled,
+		prod_dep            => $prod_dep,
 		delay               => $dep_delay // $arr_delay,
 		direction           => $stop->{dDirTxt},
 		sched_platform      => $sched_platform,
@@ -254,12 +262,22 @@ Departure or arrival delay in minutes.
 
 Direction signage from this stop on, undef if unchanged.
 
-=item $journey->messages
+=item $stop->messages
 
 List of Travel::Status::DE::HAFAS::Message(3pm) instances related to this stop.
 These typically refer to delay reasons, platform changes, or changes in the
 line number / direction heading.
 
+=item $stop->prod_arr
+
+Travel::Status::DE::HAFAS::Product(3pm) instance describing the transit product
+(name, type, line number, operator, ...) upon arrival at this stop.
+
+=item $stop->prod_dep
+
+Travel::Status::DE::HAFAS::Product(3pm) instance describing the transit product
+(name, type, line number, operator, ...) upon departure from this stop.
+
 =item $stop->rt_platform
 
 Actual platform.