summaryrefslogtreecommitdiff
path: root/lib/Travel/Status/DE
diff options
context:
space:
mode:
authorBirte Kristina Friesel <derf@finalrewind.org>2024-03-26 12:06:35 +0100
committerBirte Kristina Friesel <derf@finalrewind.org>2024-03-26 12:06:35 +0100
commit9ef75520eeaf1a568650f7368782ac63b80c09b2 (patch)
tree0a933ef6dec6a6d90178e97022b14f9fe8b45bf5 /lib/Travel/Status/DE
parent20b537ca899215ef0d4989f350547159426c5f32 (diff)
Preliminary support for stop-specific operators / operator changes (#10)
Diffstat (limited to 'lib/Travel/Status/DE')
-rw-r--r--lib/Travel/Status/DE/HAFAS.pm24
-rw-r--r--lib/Travel/Status/DE/HAFAS/Journey.pm80
-rw-r--r--lib/Travel/Status/DE/HAFAS/Product.pm181
-rw-r--r--lib/Travel/Status/DE/HAFAS/Stop.pm24
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.