Provide $journey->product->line_id in a line-colors compatible format

See https://github.com/Traewelling/line-colors/blob/main/line-colors.csv

Closes #9

2 files changed, 31 insertions, 14 deletions

diff --git a/lib/Travel/Status/DE/HAFAS/Journey.pm b/lib/Travel/Status/DE/HAFAS/Journey.pm
index 6a36c22..f7206e8 100644
--- a/lib/Travel/Status/DE/HAFAS/Journey.pm
+++ b/lib/Travel/Status/DE/HAFAS/Journey.pm
@@ -17,6 +17,7 @@ Travel::Status::DE::HAFAS::Journey->mk_ro_accessors(
 	qw(datetime sched_datetime rt_datetime
 	  is_additional is_cancelled is_partially_cancelled
 	  station station_eva platform sched_platform rt_platform operator
+	  product
 	  id name type type_long class number line line_no load delay
 	  route_end route_start origin destination direction)
 );
@@ -487,6 +488,13 @@ True if the journey was cancelled, false otherwise.
 
 True if part of the journey was cancelled, false otherwise.
 
+=item $journey->product
+
+Travel::Status::DE::HAFAS::Product(3pm) instance describing the product (mode
+of transport, line number / ID, operator, ...) associated with this journey.
+Note that journeys may be associated with multiple products -- see also
+C<< $journey->route >> and C<< $stop->product >>.
+
 =item $journey->rt_platform (station only)
 
 Actual arrival/departure platform.
diff --git a/lib/Travel/Status/DE/HAFAS/Product.pm b/lib/Travel/Status/DE/HAFAS/Product.pm
index 5e45232..14cc018 100644
--- a/lib/Travel/Status/DE/HAFAS/Product.pm
+++ b/lib/Travel/Status/DE/HAFAS/Product.pm
@@ -11,19 +11,22 @@ 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)
-);
+	qw(name type type_long class number line line_id line_no operator));
 
 # {{{ Constructor
 
 sub new {
 	my ( $obj, %opt ) = @_;
 
-	my $product      = $opt{product};
-	my $common       = $opt{common};
-	my $opL = $common->{opL};
+	my $product = $opt{product};
+	my $common  = $opt{common};
+	my $opL     = $common->{opL};
 
-	my $class = $product->{cls};
+	# DB:
+	# catIn / catOutS eq "IXr" => "ICE X Regio"? regional tickets are generally accepted
+	#                          <= does not hold
+
+	my $class    = $product->{cls};
 	my $name     = $product->{addName} // $product->{name};
 	my $line_no  = $product->{prodCtx}{line};
 	my $train_no = $product->{prodCtx}{num};
@@ -45,6 +48,11 @@ sub new {
 		$line_no = $product->{prodCtx}{matchId};
 	}
 
+	my $line_id;
+	if ( $product->{prodCtx}{lineId} ) {
+		$line_id = lc( $product->{prodCtx}{lineId} =~ s{_+}{-}gr );
+	}
+
 	my $operator;
 	if ( defined $product->{oprX} ) {
 		if ( my $opref = $opL->[ $product->{oprX} ] ) {
@@ -53,14 +61,15 @@ sub new {
 	}
 
 	my $ref = {
-		name                   => $name,
-		number                 => $train_no,
-		line                   => $name,
-		line_no                => $line_no,
-		type                   => $cat,
-		type_long              => $catlong,
-		class                  => $class,
-		operator               => $operator,
+		name      => $name,
+		number    => $train_no,
+		line      => $name,
+		line_id   => $line_id,
+		line_no   => $line_no,
+		type      => $cat,
+		type_long => $catlong,
+		class     => $class,
+		operator  => $operator,
 	};
 
 	bless( $ref, $obj );