diff options
Diffstat (limited to 'lib/Travel')
-rw-r--r-- | lib/Travel/Status/DE/HAFAS.pm | 24 | ||||
-rw-r--r-- | lib/Travel/Status/DE/HAFAS/Journey.pm | 80 | ||||
-rw-r--r-- | lib/Travel/Status/DE/HAFAS/Product.pm | 181 | ||||
-rw-r--r-- | lib/Travel/Status/DE/HAFAS/Stop.pm | 24 |
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. |