Unverified Commit 9ef75520 authored by Birte Kristina Friesel's avatar Birte Kristina Friesel
Browse files

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

parent 20b537ca

bin/hafas-m

+31 −4
Original line number Diff line number Diff line
@@ -384,6 +384,8 @@ elsif ( $opt{locationSearch} ) { 
}

elsif ( $opt{journey} ) {

	my $result = $status->result;

	my @prods;

	my $prev_prod = 0;



	printf( "%s → %s", $result->name, $result->route_end );

	if ( $result->number ) {
@@ -392,7 +394,7 @@ elsif ( $opt{journey} ) { 
	if ( $result->line_no ) {

		printf( " / Linie %s", $result->line_no );

	}

	printf( "\nFahrt %s am %s\n\n",

	printf( "\nFahrt %s am %s\n",

		$result->id, ( $result->route )[0]->sched_dep->strftime('%d.%m.%Y') );



	my $delay_len     = 0;
@@ -406,11 +408,24 @@ elsif ( $opt{journey} ) { 
		{

			$occupancy_len = 2;

		}

		my $prod = $stop->prod_dep // $stop->prod_arr;

		if ( $prod and $prod != $prev_prod ) {

			push( @prods, $prod );

			$prev_prod = $prod;

		}

	}

	if ($delay_len) {

		$delay_fmt = $delay_len + 3;

	}



	if ( @prods == 1 ) {

		printf( "Betrieb: %s\n\n", $prev_prod->operator );

	}

	else {

		printf( "Betrieb: %s\n\n", join( q{, }, map { $_->operator } @prods ) );

	}

	$prev_prod = 0;



	my $now       = DateTime->now( time_zone => 'Europe/Berlin' );

	my $mark_stop = 0;

	for my $i ( reverse 1 .. scalar $result->route ) {
@@ -440,8 +455,19 @@ elsif ( $opt{journey} ) { 
				$msg_line .= sprintf( ' (%d)', $message->{id} );

			}

		}



		my $prod_line = q{};

		if ( @prods > 1 ) {

			my $prod = $stop->prod_dep // $stop->prod_arr;

			if ( $prod and $prod != $prev_prod ) {

				$prod_line

				  = sprintf( " : %s (%s)", $prod->name, $prod->operator );

				$prev_prod = $prod;

			}

		}



		printf(

"%s%5s %s %5s %-${delay_fmt}s%${occupancy_len}s%-${occupancy_len}s %s%s%s%s\n",

"%s%5s %s %5s %-${delay_fmt}s%${occupancy_len}s%-${occupancy_len}s %s%s%s%s%s\n",

			$stop == $mark_stop  ? $output_bold : q{},

			$stop->arr_cancelled ? '--:--'

			: ( $stop->arr ? $stop->arr->strftime('%H:%M') : q{} ),
@@ -455,6 +481,7 @@ elsif ( $opt{journey} ) { 
			: q{},

			$stop->loc->name,

			$stop == $mark_stop ? $output_reset : q{},

			$prod_line,

			$stop->direction ? sprintf( ' → %s', $stop->direction ) : q{},

			$msg_line,

		);

lib/Travel/Status/DE/HAFAS.pm

+24 −0
Original line number Diff line number Diff line
@@ -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,

lib/Travel/Status/DE/HAFAS/Journey.pm

+30 −50
Original line number Diff line number Diff line
@@ -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} // [] } ) {
@@ -92,22 +64,30 @@ sub new { 
	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];

			$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];

			$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,

lib/Travel/Status/DE/HAFAS/Product.pm

0 → 100644
+181 −0
Original line number Diff line number Diff line 
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.

lib/Travel/Status/DE/HAFAS/Stop.pm

+21 −3
Original line number Diff line number Diff line
@@ -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.