summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Changelog29
-rwxr-xr-xbin/db-wagenreihung80
-rw-r--r--lib/Travel/Status/DE/DBWagenreihung.pm584
-rw-r--r--lib/Travel/Status/DE/DBWagenreihung/Group.pm74
-rw-r--r--lib/Travel/Status/DE/DBWagenreihung/Section.pm2
-rw-r--r--lib/Travel/Status/DE/DBWagenreihung/Wagon.pm9
6 files changed, 445 insertions, 333 deletions
diff --git a/Changelog b/Changelog
index a2306ef..479004e 100644
--- a/Changelog
+++ b/Changelog
@@ -1,3 +1,32 @@
+Travel::Status::DE::DBWagenreihung 0.14 - Sun Apr 28 2024
+
+ * This module now explicitly treats carriages as groups, just like the
+ backend does. Each group contains at least one carriage and has a
+ distinct number, origin, destination, and train type / description.
+ * Add Travel::Status::DE::DBWagenreihung::Group module.
+ * DBWagenreihung: Add groups, carriages, and train_nos accessors.
+ * DBWagenreihung: origins, destinations: Return hashrefs with
+ "name" / "groups" / "sections" rather than "name" / "sections".
+ * DBWagenreihung: Remove train_descriptions, wagongroup_description,
+ wagongroup_subtype, and wagongroup_model accessors. Use $wr->groups and
+ $group->description / $group->desc_short instead.
+ This is a breaking change.
+
+Travel::Status::DE::DBWagenreihung 0.13 - Sat Apr 27 2024
+
+ * DBWagenreihung: Add station accessor.
+ * DBWagenreihung: Add TO_JSON function.
+ * DBWagenreihung: remove station_ds100, station_name, and station_uic
+ accessors. Use station->{ds100}, station->{name} and station->{eva}
+ instead. This is a breaking change.
+ * DBWagenreihung: origins now returns a list of hashrefs, just like
+ destinations. It used to return a list of names. This is a breaking
+ change.
+
+Travel::Status::DE::DBWagenreihung 0.12 - Fri Mar 29 2024
+
+ * Wagon: Add is_closed accessor
+
Travel::Status::DE::DBWagenreihung 0.11 - Thu Mar 07 2024
* Add another regional train model
diff --git a/bin/db-wagenreihung b/bin/db-wagenreihung
index 73bbdb4..e4e3a46 100755
--- a/bin/db-wagenreihung
+++ b/bin/db-wagenreihung
@@ -4,7 +4,7 @@ use warnings;
use 5.020;
use utf8;
-our $VERSION = '0.11';
+our $VERSION = '0.14';
use Getopt::Long;
use List::Util qw(min);
@@ -73,7 +73,12 @@ my $wr = Travel::Status::DE::DBWagenreihung->new(
printf(
"%s: %s ā†’ %s\n",
join( ' / ', map { $wr->train_type . ' ' . $_ } $wr->train_numbers ),
- join( ' / ', $wr->origins ),
+ join(
+ ' / ',
+ map {
+ sprintf( '%s (%s)', $_->{name}, join( q{}, @{ $_->{sections} } ) )
+ } $wr->origins
+ ),
join(
' / ',
map {
@@ -82,7 +87,7 @@ printf(
),
);
-printf( "%s Gleis %s\n\n", $wr->station_name, $wr->platform );
+printf( "%s Gleis %s\n\n", $wr->station->{name}, $wr->platform );
for my $section ( $wr->sections ) {
my $section_length = $section->length_percent;
@@ -94,14 +99,15 @@ for my $section ( $wr->sections ) {
}
printf( "ā–%s%s%sā–•",
- ' ' x $spacing_left,
- $section->name,
- ' ' x $spacing_right );
+ ( $spacing_left >= 0 ) ? ' ' x $spacing_left : q{},
+ $section->name, ( $spacing_right >= 0 ) ? ' ' x $spacing_right : q{} );
}
print "\n";
my @start_percentages = map { $_->{position}{start_percent} } $wr->wagons;
-print ' ' x ( ( min @start_percentages ) - 1 );
+if ( my $min_percentage = min @start_percentages ) {
+ print ' ' x ( $min_percentage - 1 );
+}
print $wr->direction == 100 ? '>' : '<';
for my $wagon ( $wr->wagons ) {
@@ -142,29 +148,40 @@ for my $wagon ( $wr->wagons ) {
print $wr->direction == 100 ? '>' : '<';
print "\n\n";
-for my $desc ( $wr->train_descriptions ) {
- if ( $desc->{text} ) {
+for my $group ( $wr->groups ) {
+ if ( $group->has_sections ) {
printf( "%s (%s)\n",
- $desc->{text}, join( q{}, @{ $desc->{sections} } ) );
+ $group->description || 'Zug',
+ join( q{}, $group->sections ) );
+ }
+ else {
+ say $group->description || 'Zug';
}
-}
-
-say "";
-
-for my $wagon ( $wr->wagons ) {
printf(
- "%3s: %3s %10s %s\n",
- $wagon->is_closed ? 'X' : ( $wagon->number || '?' ),
- $wagon->model || '???',
- $wagon->type, join( q{ }, $wagon->attributes )
+ "%s %s %s ā†’ %s\n\n",
+ $wr->train_type, $group->train_no,
+ $group->origin, $group->destination
);
+
+ for my $wagon ( $group->wagons ) {
+ printf(
+ "%3s: %3s %10s %s\n",
+ $wagon->is_closed ? 'X'
+ : $wagon->is_locomotive ? 'Lok'
+ : $wagon->number || '?',
+ $wagon->model || '???',
+ $wagon->type,
+ join( q{ }, $wagon->attributes )
+ );
+ }
+ say "";
}
__END__
=head1 NAME
-db-wagenreihung - Interface to Deutsche Bahn Wagon Order API
+db-wagenreihung - Interface to Deutsche Bahn carriage formation API
=head1 SYNOPSIS
@@ -172,21 +189,20 @@ B<db-wagenreihung> I<station> I<train-number>
=head1 VERSION
-version 0.11
+version 0.14
This is beta software: API and output format may change without notice.
=head1 DESCRIPTION
-db-wagenreihung shows the wagon order of train I<train-number> at station
-I<station> (must be a name or DS100 code) as reported by the Deutsche Bahn
-Wagon Order API. As of April 2020, long-distance IC/EC/ICFE trains are widely
-supported, and some regions (e.g. Stuttgart/Karlsruhe) also provide wagon
-orders for select regional trains. Data accuracy varies, but seems to be
-improving over time.
+db-wagenreihung shows the carriage formation (also known as coach sequence) of
+train I<train-number> at station I<station> (must be a name or DS100 code) as
+reported by the Deutsche Bahn Wagenreihung API. As of April 2024, it has mature
+support for long-distance (IC/EC/ICE) trains and a growing number of regional
+transport providers that also offer mostly correct carriage formation data.
-It is not possible to request the wagon order at a train's terminus station.
-This is a known limitation.
+It is not possible to request the carriage formation at a train's terminus
+station. This is a known limitation.
The departure of I<train-number> must be in the time range between now and
two hours in the future.
@@ -197,11 +213,11 @@ two hours in the future.
=item db-wagenreihung 'Essen Hbf' 723
-Show wagon order of ICE 723 at Essen Hbf
+Show carriage formation of ICE 723 at Essen Hbf
=item db-wagenreihung TS 3259
-Show wagon order of IRE 3259 at Stuttgart Hbf
+Show carriage formation of IRE 3259 at Stuttgart Hbf
=back
@@ -219,7 +235,7 @@ Show wagon order of IRE 3259 at Stuttgart Hbf
=head1 AUTHOR
-Copyright (C) 2018-2020 by Birte Kristina Friesel E<lt>derf@finalrewind.orgE<gt>
+Copyright (C) 2018-2024 by Birte Kristina Friesel E<lt>derf@finalrewind.orgE<gt>
=head1 LICENSE
diff --git a/lib/Travel/Status/DE/DBWagenreihung.pm b/lib/Travel/Status/DE/DBWagenreihung.pm
index 09abb79..f3e38f0 100644
--- a/lib/Travel/Status/DE/DBWagenreihung.pm
+++ b/lib/Travel/Status/DE/DBWagenreihung.pm
@@ -5,15 +5,23 @@ use warnings;
use 5.020;
use utf8;
-our $VERSION = '0.11';
+use parent 'Class::Accessor';
use Carp qw(cluck confess);
use JSON;
use List::Util qw(uniq);
use LWP::UserAgent;
+use Travel::Status::DE::DBWagenreihung::Group;
use Travel::Status::DE::DBWagenreihung::Section;
use Travel::Status::DE::DBWagenreihung::Wagon;
+our $VERSION = '0.14';
+
+Travel::Status::DE::DBWagenreihung->mk_ro_accessors(
+ qw(direction platform station train_no train_type));
+
+# {{{ Rolling Stock Models
+
my %is_redesign = (
"02" => 1,
"03" => 1,
@@ -57,6 +65,7 @@ my %model_name = (
'411.S2' => [ 'ICE T', 'BR 411, 2. Serie' ],
'412' => ['ICE 4'],
'415' => [ 'ICE T', 'BR 415' ],
+ '420' => ['BR 420'],
'422' => ['BR 422'],
'423' => ['BR 423'],
'425' => ['BR 425'],
@@ -98,6 +107,9 @@ my %power_desc = (
99 => 'Sonderfahrzeug',
);
+# }}}
+# {{{ Constructors
+
sub new {
my ( $class, %opt ) = @_;
@@ -117,7 +129,6 @@ sub new {
departure => $opt{departure},
from_json => $opt{from_json},
json => JSON->new,
- serializable => $opt{serializable},
train_number => $opt{train_number},
user_agent => $opt{user_agent},
};
@@ -170,107 +181,226 @@ sub get_wagonorder {
if ( @{ $json->{data}{istformation}{allFahrzeuggruppe} // [] } == 0
and @{ $json->{data}{istformation}{halt} // [] } == 0 )
{
- $self->{errstr} = 'No wagon order available';
+ $self->{errstr} = 'No carriage formation available';
return;
}
$self->{data} = $json->{data};
$self->{meta} = $json->{meta};
-}
-sub errstr {
- my ($self) = @_;
-
- return $self->{errstr};
+ return $self->parse_wagonorder;
}
-sub direction {
- my ($self) = @_;
+# }}}
+# {{{ Internal Helpers
- if ( not exists $self->{direction} ) {
+sub get_with_cache {
+ my ( $self, $cache, $url ) = @_;
- # direction is set while parsing wagons
- $self->wagons;
+ if ( $self->{developer_mode} ) {
+ say "GET $url";
}
- return $self->{direction};
-}
+ if ($cache) {
+ my $content = $cache->thaw($url);
+ if ($content) {
+ if ( $self->{developer_mode} ) {
+ say ' cache hit';
+ }
+ return ( ${$content}, undef );
+ }
+ }
-sub has_bad_wagons {
- my ($self) = @_;
+ if ( $self->{developer_mode} ) {
+ say ' cache miss';
+ }
- if ( defined $self->{has_bad_wagons} ) {
- return $self->{has_bad_wagons};
+ my $ua = $self->{user_agent};
+ my $res = $ua->get($url);
+
+ if ( $res->is_error ) {
+ return ( undef, $res->status_line );
}
+ my $content = $res->decoded_content;
- for my $group ( @{ $self->{data}{istformation}{allFahrzeuggruppe} } ) {
- for my $wagon ( @{ $group->{allFahrzeug} } ) {
- my $pos = $wagon->{positionamhalt};
- if ( $pos->{startprozent} eq ''
- or $pos->{endeprozent} eq ''
- or $pos->{startmeter} eq ''
- or $pos->{endemeter} eq '' )
- {
- return $self->{has_bad_wagons} = 1;
- }
- }
+ if ($cache) {
+ $cache->freeze( $url, \$content );
}
- return $self->{has_bad_wagons} = 0;
+ return ( $content, undef );
}
-sub origins {
- my ($self) = @_;
+sub wagongroup_powertype {
+ my ( $self, @wagons ) = @_;
- if ( exists $self->{origins} ) {
- return @{ $self->{origins} };
+ if ( not @wagons ) {
+ @wagons = $self->wagons;
}
- my @origins;
+ my %ml = map { $_ => 0 } ( 90 .. 99 );
- for my $group ( @{ $self->{data}{istformation}{allFahrzeuggruppe} } ) {
- push( @origins, $group->{startbetriebsstellename} );
+ for my $wagon (@wagons) {
+
+ if ( not $wagon->uic_id or length( $wagon->uic_id ) != 12 ) {
+ next;
+ }
+
+ my $wagon_type = substr( $wagon->uic_id, 0, 2 );
+ if ( $wagon_type < 90 ) {
+ next;
+ }
+
+ $ml{$wagon_type}++;
}
- @origins = uniq @origins;
+ my @likelihood = reverse sort { $ml{$a} <=> $ml{$b} } keys %ml;
- $self->{origins} = \@origins;
+ if ( $ml{ $likelihood[0] } == 0 ) {
+ return undef;
+ }
- return @origins;
+ return $likelihood[0];
}
-sub destinations {
+sub parse_wagonorder {
my ($self) = @_;
- if ( exists $self->{destinations} ) {
- return @{ $self->{destinations} };
+ $self->{platform} = $self->{data}{istformation}{halt}{gleisbezeichnung};
+
+ $self->{station} = {
+ ds100 => $self->{data}{istformation}{halt}{rl100},
+ eva => $self->{data}{istformation}{halt}{evanummer},
+ name => $self->{data}{istformation}{halt}{bahnhofsname},
+ };
+
+ $self->{train_type} = $self->{data}{istformation}{zuggattung};
+ $self->{train_no} = $self->{data}{istformation}{zugnummer};
+
+ $self->parse_wagons;
+ $self->{origins} = $self->merge_group_attr('origin');
+ $self->{destinations} = $self->merge_group_attr('destination');
+ $self->{train_nos} = $self->merge_group_attr('train_no');
+}
+
+sub merge_group_attr {
+ my ( $self, $attr ) = @_;
+
+ my @attrs;
+ my %attr_to_group;
+ my %attr_to_sections;
+
+ for my $group ( $self->groups ) {
+ push( @attrs, $group->{$attr} );
+ push( @{ $attr_to_group{ $group->{$attr} } }, $group );
+ push( @{ $attr_to_sections{ $group->{$attr} } }, $group->sections );
}
- my @destinations;
- my %section;
+ @attrs = uniq @attrs;
+
+ return [
+ map {
+ {
+ name => $_,
+ groups => $attr_to_group{$_},
+ sections => $attr_to_sections{$_}
+ }
+ } @attrs
+ ];
+}
+
+sub parse_wagons {
+ my ($self) = @_;
+
+ my @wagon_groups;
for my $group ( @{ $self->{data}{istformation}{allFahrzeuggruppe} } ) {
- my $destination = $group->{zielbetriebsstellename};
- my @sections = map { $_->{fahrzeugsektor} } @{ $group->{allFahrzeug} };
- push( @{ $section{$destination} }, @sections );
- push( @destinations, $destination );
+ my @group_wagons;
+ for my $wagon ( @{ $group->{allFahrzeug} } ) {
+ my $wagon_object
+ = Travel::Status::DE::DBWagenreihung::Wagon->new( %{$wagon},
+ train_no => $group->{verkehrlichezugnummer} );
+ push( @{ $self->{wagons} }, $wagon_object );
+ push( @group_wagons, $wagon_object );
+ if ( not $wagon_object->{position}{valid} ) {
+ $self->{has_bad_wagons} = 1;
+ }
+ }
+ my $group_obj = Travel::Status::DE::DBWagenreihung::Group->new(
+ id => $group->{fahrzeuggruppebezeichnung},
+ train_no => $group->{verkehrlichezugnummer},
+ origin => $group->{startbetriebsstellename},
+ destination => $group->{zielbetriebsstellename},
+ wagons => \@group_wagons,
+ );
+ push( @wagon_groups, $group_obj );
+
+ my ( $short, $desc )
+ = $self->wagongroup_description( $group_obj->wagons );
+ my @sections = uniq map { $_->section } $group_obj->wagons;
+
+ if ( @sections and length( join( q{}, @sections ) ) ) {
+ $group_obj->set_sections(@sections);
+ }
+ $group_obj->set_description( $desc, $short );
+ }
+ if ( @{ $self->{wagons} // [] } > 1 and not $self->has_bad_wagons ) {
+ if ( $self->{wagons}[0]->{position}{start_percent}
+ > $self->{wagons}[-1]->{position}{start_percent} )
+ {
+ $self->{direction} = 100;
+ }
+ else {
+ $self->{direction} = 0;
+ }
}
+ if ( not $self->has_bad_wagons ) {
+ @{ $self->{wagons} } = sort {
+ $a->{position}->{start_percent} <=> $b->{position}->{start_percent}
+ } @{ $self->{wagons} };
+ for my $group (@wagon_groups) {
+ $group->sort_wagons;
+ }
+ @wagon_groups = sort {
+ $a->{wagons}[0]{position}{start_percent}
+ <=> $b->{wagons}[0]{position}{start_percent}
+ } @wagon_groups;
+ }
+
+ for my $i ( 0 .. $#wagon_groups ) {
+ my $group = $wagon_groups[$i];
+ my $tt = $self->wagongroup_subtype( $group->wagons );
+ $group->set_traintype( $i, $tt );
+ $group->{type} = $tt;
+ }
+
+ $self->{wagongroups} = [@wagon_groups];
+}
+
+# }}}
+# {{{ Public Functions
+
+sub errstr {
+ my ($self) = @_;
+
+ return $self->{errstr};
+}
- @destinations = uniq @destinations;
+sub destinations {
+ my ($self) = @_;
- @destinations
- = map { { name => $_, sections => [ uniq @{ $section{$_} } ] } }
- @destinations;
+ return @{ $self->{destinations} // [] };
+}
- $self->{destinations} = \@destinations;
+sub origins {
+ my ($self) = @_;
- return @destinations;
+ return @{ $self->{origins} // [] };
}
-sub platform {
+sub train_nos {
my ($self) = @_;
- return $self->{data}{istformation}{halt}{gleisbezeichnung};
+ return @{ $self->{train_nos} // [] };
}
sub sections {
@@ -300,30 +430,6 @@ sub sections {
return @{ $self->{sections} // [] };
}
-sub station_ds100 {
- my ($self) = @_;
-
- return $self->{data}{istformation}{halt}{rl100};
-}
-
-sub station_name {
- my ($self) = @_;
-
- return $self->{data}{istformation}{halt}{bahnhofsname};
-}
-
-sub station_uic {
- my ($self) = @_;
-
- return $self->{data}{istformation}{halt}{evanummer};
-}
-
-sub train_type {
- my ($self) = @_;
-
- return $self->{data}{istformation}{zuggattung};
-}
-
sub train_numbers {
my ($self) = @_;
@@ -344,72 +450,27 @@ sub train_numbers {
return @numbers;
}
-sub train_no {
- my ($self) = @_;
-
- return $self->{data}{istformation}{zugnummer};
-}
-
-sub wagongroup_powertype {
- my ( $self, @wagons ) = @_;
-
- if ( not @wagons ) {
- @wagons = $self->wagons;
- }
-
- my %ml = map { $_ => 0 } ( 90 .. 99 );
-
- for my $wagon (@wagons) {
-
- if ( not $wagon->uic_id or length( $wagon->uic_id ) != 12 ) {
- next;
- }
-
- my $wagon_type = substr( $wagon->uic_id, 0, 2 );
- if ( $wagon_type < 90 ) {
- next;
- }
-
- $ml{$wagon_type}++;
- }
-
- my @likelihood = reverse sort { $ml{$a} <=> $ml{$b} } keys %ml;
-
- if ( $ml{ $likelihood[0] } == 0 ) {
- return undef;
- }
-
- return $likelihood[0];
-}
-
-sub train_descriptions {
+sub has_bad_wagons {
my ($self) = @_;
- if ( exists $self->{train_descriptions} ) {
- return @{ $self->{train_descriptions} };
- }
-
- if ( not exists $self->{wagons} ) {
-
- # wagongroups are set while parsong wagons
- $self->wagons;
+ if ( defined $self->{has_bad_wagons} ) {
+ return $self->{has_bad_wagons};
}
- for my $wagons ( @{ $self->{wagongroups} } ) {
- my ( $short, $desc ) = $self->wagongroup_description( @{$wagons} );
- my @sections = uniq map { $_->section } @{$wagons};
-
- push(
- @{ $self->{train_descriptions} },
+ for my $group ( @{ $self->{data}{istformation}{allFahrzeuggruppe} } ) {
+ for my $wagon ( @{ $group->{allFahrzeug} } ) {
+ my $pos = $wagon->{positionamhalt};
+ if ( $pos->{startprozent} eq ''
+ or $pos->{endeprozent} eq ''
+ or $pos->{startmeter} eq ''
+ or $pos->{endemeter} eq '' )
{
- sections => [@sections],
- short => $short,
- text => $desc,
+ return $self->{has_bad_wagons} = 1;
}
- );
+ }
}
- return @{ $self->{train_descriptions} };
+ return $self->{has_bad_wagons} = 0;
}
sub wagongroup_description {
@@ -478,6 +539,7 @@ sub wagongroup_subtype {
'411.S2' => 0,
'412' => 0,
'415' => 0,
+ '420' => 0,
'422' => 0,
'423' => 0,
'425' => 0,
@@ -554,6 +616,9 @@ sub wagongroup_subtype {
elsif ( $wagon->model == 415 ) {
$ml{'415'}++;
}
+ elsif ( $wagon->model == 420 or $wagon->model == 421 ) {
+ $ml{'420'}++;
+ }
elsif ( $wagon->model == 422 or $wagon->model == 432 ) {
$ml{'422'}++;
}
@@ -650,110 +715,57 @@ sub wagongroup_subtype {
# Less than two wagons are generally inconclusive.
# Exception: BR 631 (Link I) only has a single wagon
- if ( $ml{ $likelihood[0] } < 2 and $likelihood[0] ne '631' ) {
+ if (
+ $ml{ $likelihood[0] } < 2
+ and not($likelihood[0] eq '631'
+ and @wagons == 1
+ and substr( $wagons[0]->uic_id, 0, 2 ) eq '95' )
+ )
+ {
return undef;
}
return $likelihood[0];
}
-sub wagons {
+sub groups {
my ($self) = @_;
+ return @{ $self->{wagongroups} // [] };
+}
- if ( exists $self->{wagons} ) {
- return @{ $self->{wagons} };
- }
-
- my @wagon_groups;
-
- for my $group ( @{ $self->{data}{istformation}{allFahrzeuggruppe} } ) {
- my @group;
- for my $wagon ( @{ $group->{allFahrzeug} } ) {
- my $wagon_object
- = Travel::Status::DE::DBWagenreihung::Wagon->new( %{$wagon},
- train_no => $group->{verkehrlichezugnummer} );
- push( @{ $self->{wagons} }, $wagon_object );
- push( @group, $wagon_object );
- if ( not $wagon_object->{position}{valid} ) {
- $self->{has_bad_wagons} = 1;
- }
- }
- push( @wagon_groups, [@group] );
- }
- if ( @{ $self->{wagons} // [] } > 1 and not $self->has_bad_wagons ) {
- if ( $self->{wagons}[0]->{position}{start_percent}
- > $self->{wagons}[-1]->{position}{start_percent} )
- {
- $self->{direction} = 100;
- }
- else {
- $self->{direction} = 0;
- }
- }
- if ( not $self->has_bad_wagons ) {
- @{ $self->{wagons} } = sort {
- $a->{position}->{start_percent} <=> $b->{position}->{start_percent}
- } @{ $self->{wagons} };
- }
-
- for my $i ( 0 .. $#wagon_groups ) {
- my $group = $wagon_groups[$i];
- my $tt = $self->wagongroup_subtype( @{$group} );
- if ($tt) {
- for my $wagon ( @{$group} ) {
- $wagon->set_traintype( $i, $tt );
- }
- }
- }
-
- $self->{wagongroups} = [@wagon_groups];
-
+sub carriages {
+ my ($self) = @_;
return @{ $self->{wagons} // [] };
}
-sub get_with_cache {
- my ( $self, $cache, $url ) = @_;
-
- if ( $self->{developer_mode} ) {
- say "GET $url";
- }
-
- if ($cache) {
- my $content = $cache->thaw($url);
- if ($content) {
- if ( $self->{developer_mode} ) {
- say ' cache hit';
- }
- return ( ${$content}, undef );
- }
- }
+sub wagons {
+ my ($self) = @_;
+ return @{ $self->{wagons} // [] };
+}
- if ( $self->{developer_mode} ) {
- say ' cache miss';
- }
+sub TO_JSON {
+ my ($self) = @_;
- my $ua = $self->{user_agent};
- my $res = $ua->get($url);
+ # ensure that all objects are available
+ $self->train_numbers;
+ $self->sections;
- if ( $res->is_error ) {
- return ( undef, $res->status_line );
- }
- my $content = $res->decoded_content;
+ my %copy = %{$self};
- if ($cache) {
- $cache->freeze( $url, \$content );
- }
+ delete $copy{from_json};
- return ( $content, undef );
+ return {%copy};
}
+# }}}
+
1;
__END__
=head1 NAME
-Travel::Status::DE::DBWagenreihung - Interface to Deutsche Bahn Wagon Order API.
+Travel::Status::DE::DBWagenreihung - Interface to Deutsche Bahn carriage formation API.
=head1 SYNOPSIS
@@ -764,32 +776,31 @@ Travel::Status::DE::DBWagenreihung - Interface to Deutsche Bahn Wagon Order API.
train_number => 1234,
);
- for my $wagon ( $wr->wagons ) {
- printf("Wagen %s: Abschnitt %s\n", $wagon->number // '?', $wagon->section);
+ for my $carriage ( $wr->carriages ) {
+ printf("Wagen %s: Abschnitt %s\n", $carriage->number // '?', $carriage->section);
}
=head1 VERSION
-version 0.11
+version 0.14
This is beta software. The API may change without notice.
=head1 DESCRIPTION
Travel:Status:DE::DBWagenreihung is an unofficial interface to the Deutsche
-Bahn Wagon Order API at L<https://www.apps-bahn.de/wr/wagenreihung/1.0>. It
-returns station-specific wagon orders for long-distance trains operated by
-Deutsche Bahn. Data includes wagon positions on the platform, the ICE series,
-wagon-specific attributes such as first/second class or family coaches, and the
-internal type and number of each wagon.
-
-Positions on the platform are given both in meters and per cent (relative to
+Bahn carriage formation (API at L<https://ist-wr.noncd.db.de/wagenreihung/1.0>.
+It returns station-specific carriage formations (also kwnown as coach
+sequences) for a variety of trains in the rail network associated with Deutsche
+Bahn. Data includes carriage positions on the platform, train type (e.g. ICE
+series), carriage-specific attributes such as first/second class, and the
+internal type and number of each carriage.
+
+Positions on the platform are given both in meters and percent (relative to
platform length).
-At the time of this writing, only ICE trains are officially supported by the
-backend, and even then glitches may occur. IC/EC trains are not officially
-supported; reported wagon orders may be correct, may lack unscheduled changes,
-or may be completely bogus.
+Note that carriage formation data reported by the API is known to be bogus
+from time to time. This module does not perform thorough sanity checking.
=head1 METHODS
@@ -797,10 +808,10 @@ or may be completely bogus.
=item my $wr = Travel::Status::DE::DBWagenreihung->new(I<%opts>)
-Requests wagon order for a specific train at a specific scheduled departure
-time and date, which implicitly encodes the requested station. Use
-L<Travel::Status::DE::IRIS> or similar to map station name and train number
-to scheduled departure.
+Requests carriage formation for a specific train at a specific scheduled
+departure time and date, which implicitly encodes the requested station. Use
+L<Travel::Status::DE::IRIS> or similar to map station name and train number to
+scheduled departure.
Arguments:
@@ -808,8 +819,8 @@ Arguments:
=item B<departure> => I<datetime-obj> | I<YYYYMMDDhhmm>
-Scheduled departure at the station of interested. Must be either a
-L<DateTime> object or a string in YYYYMMDDhhmm format. Mandatory.
+Scheduled departure at the station of interest. Must be either a
+L<DateTime> object or a string in I<YYYYMMDDhhmm> format. Mandatory.
=item B<train_number> => I<number>
@@ -818,17 +829,22 @@ Train number. Do not include the train type: Use "8" for "EC 8" or
=back
-=item $wr->destinations
+=item $wr->errstr
+
+In case of a fatal HTTP or backend error, returns a string describing it.
+Returns undef otherwise.
-Returns a list describing all final destinations of this train. In most
-cases, it contains one element, however, for trains consisting of multiple
-wings, it contains one element for each wing.
+=item $wr->groups
-Each destination is a hash ref containing the destination B<name> and the
-corresponding platform I<sections> (at the moment, this is a list of section
-identifiers).
+Returns a list of Travel::Status::DE::DBWagenreihung::Group(3pm) objects
+which describe the groups making up the carriage formation. Typically, each
+group has a distinct origin, destination, or train number. Each group contains
+a set of carriages.
-This function is subject to change.
+=item $wr->carriages
+
+Describes the individual carriages the train consists of. Returns a list of
+L<Travel::Status::DE::DBWagenreihung::Wagon> objects.
=item $wr->direction
@@ -836,20 +852,19 @@ Gives the train's direction of travel. Returns 0 if the train will depart
towards position 0 and 100 if the train will depart towards the other platform
end (mnemonic: towards the 100% position).
-=item $wr->errstr
-
-In case of a fatal HTTP or backend error, returns a string describing it.
-Returns undef otherwise.
-
=item $wr->origins
-Returns a list of stations this train originates from. In most cases, this is
-just one element; however, for trains consisting of multiple wings, it gives
-the origin of each wing unless they are identical.
+Returns a list describing the unique origins of this train's carriage groups.
+Each origin is a hashref that contains its B<name>, a B<groups> arrayref to the
+corresponding Travel::Status::DE::DBWagenreihung::Group(3pm) objects, and
+a B<sections> arrayref to section identifiers (subject to change).
-Each origin is a station name.
+=item $wr->destinations
-This function is subject to change.
+Returns a list describing the unique destinations of this train's carriage
+groups. Each origin is a hashref that contains its B<name>, a B<groups>
+arrayref to the corresponding Travel::Status::DE::DBWagenreihung::Group(3pm)
+objects, and a B<sections> arrayref to section identifiers (subject to change).
=item $wr->platform
@@ -860,36 +875,11 @@ Returns the platform name.
Describes the sections of the platform this train will depart from.
Returns a list of L<Travel::Status::DE::DBWagenreihung::Section> objects.
-=item $wr->station_ds100
-
-Returns the DS100 identifier of the requested station.
-
-=item $wr->station_name
-
-Returns the name of the requested station.
-
-=item $wr->station_uic
-
-Returns the international id (UIC ID / IBNR) of the requested station.
-
-=item $wr->train_descriptions
-
-Returns a list of hashes describing the rolling stock used for this train based
-on model and locomotive (if present). Each hash contains the keys B<text>
-(textual representation, see C<< $wr->train_desc >>) and B<sections>
-(arrayref of corresponding sections).
+=item $wr->station
-=item $wr->wagongroup_description
-
-Returns two strings describing the rolling stock used for this train based on
-model and locomotive (if present). The first one tries to be conscise (e.g.
-"ICE 4"). The second is more detailed, e.g. "ICE 4 Hochgeschwindigkeitszug",
-"IC 2 Twindexx mit elektrischer Lokomotive", or "Diesel-Triebzug".
-
-=item $wr->wagongroup_model
-
-Returns a string describing the rolling stock used for this train, e.g. "ICE 4"
-or "IC2 KISS".
+Returns a hashref describing the requested station. The hashref contains three
+entries: B<ds100> (DS100 / Ril100 identifier), B<eva> (EVA ID, related to but
+not necessarily identical with UIC station ID), and B<name> (station name).
=item $wr->train_numbers
@@ -897,19 +887,17 @@ Returns the list of train numbers for this departure. In most cases, this is
just one element. For trains consisting of multiple wings (which typically have
different numbers), it contains one element for each wing.
-=item $wr->train_type
-
-Returns a string describing the train type, e.g. "ICE" or "IC".
-
-=item $wr->wagongroup_subtype
+=item $wr->train_nos
-Returns a string describing the rolling stock model used for this train, e.g.
-"412" (model 412 aka ICE 4) or "411.S2" (model 411 aka ICE T, series 2).
+Returns a list describing the unique train numbers associated with this train's
+carriage groups. Each train number is a hashref that contains its B<name>
+(i.e., number), a B<groups> arrayref to the corresponding
+Travel::Status::DE::DBWagenreihung::Group(3pm) objects, and a B<sections>
+arrayref to section identifiers (subject to change).
-=item $wr->wagons
+=item $wr->train_type
-Describes the individual wagons the train consists of. Returns a list of
-L<Travel::Status::DE::DBWagenreihung::Wagon> objects.
+Returns a string describing the train type, e.g. "ICE" or "IC".
=back
@@ -933,7 +921,7 @@ L<https://github.com/derf/Travel-Status-DE-DBWagenreihung>
=head1 AUTHOR
-Copyright (C) 2018-2019 by Birte Kristina Friesel E<lt>derf@finalrewind.orgE<gt>
+Copyright (C) 2018-2024 by Birte Kristina Friesel E<lt>derf@finalrewind.orgE<gt>
=head1 LICENSE
diff --git a/lib/Travel/Status/DE/DBWagenreihung/Group.pm b/lib/Travel/Status/DE/DBWagenreihung/Group.pm
new file mode 100644
index 0000000..dd98550
--- /dev/null
+++ b/lib/Travel/Status/DE/DBWagenreihung/Group.pm
@@ -0,0 +1,74 @@
+package Travel::Status::DE::DBWagenreihung::Group;
+
+use strict;
+use warnings;
+use 5.020;
+use utf8;
+
+use parent 'Class::Accessor';
+
+our $VERSION = '0.14';
+
+Travel::Status::DE::DBWagenreihung::Group->mk_ro_accessors(
+ qw(id train_no type description desc_short origin destination has_sections)
+);
+
+sub new {
+ my ( $obj, %opt ) = @_;
+ my $ref = \%opt;
+
+ return bless( $ref, $obj );
+}
+
+sub set_description {
+ my ( $self, $desc, $short ) = @_;
+
+ $self->{description} = $desc;
+ $self->{desc_short} = $short;
+}
+
+sub set_sections {
+ my ( $self, @sections ) = @_;
+
+ $self->{sections} = [@sections];
+
+ $self->{has_sections} = 1;
+}
+
+sub set_traintype {
+ my ( $self, $i, $tt ) = @_;
+ $self->{type} = $tt;
+ for my $wagon ( $self->wagons ) {
+ $wagon->set_traintype( $i, $tt );
+ }
+}
+
+sub sort_wagons {
+ my ($self) = @_;
+
+ @{ $self->{wagons} }
+ = sort { $a->{position}{start_percent} <=> $b->{position}{start_percent} }
+ @{ $self->{wagons} };
+}
+
+sub sections {
+ my ($self) = @_;
+
+ return @{ $self->{sections} // [] };
+}
+
+sub wagons {
+ my ($self) = @_;
+
+ return @{ $self->{wagons} // [] };
+}
+
+sub TO_JSON {
+ my ($self) = @_;
+
+ my %copy = %{$self};
+
+ return {%copy};
+}
+
+1;
diff --git a/lib/Travel/Status/DE/DBWagenreihung/Section.pm b/lib/Travel/Status/DE/DBWagenreihung/Section.pm
index c93f2dd..5bbf1c9 100644
--- a/lib/Travel/Status/DE/DBWagenreihung/Section.pm
+++ b/lib/Travel/Status/DE/DBWagenreihung/Section.pm
@@ -7,7 +7,7 @@ use utf8;
use parent 'Class::Accessor';
-our $VERSION = '0.11';
+our $VERSION = '0.14';
Travel::Status::DE::DBWagenreihung::Section->mk_ro_accessors(
qw(name start_percent end_percent length_percent start_meters end_meters length_meters)
diff --git a/lib/Travel/Status/DE/DBWagenreihung/Wagon.pm b/lib/Travel/Status/DE/DBWagenreihung/Wagon.pm
index ffc3e58..549a5ff 100644
--- a/lib/Travel/Status/DE/DBWagenreihung/Wagon.pm
+++ b/lib/Travel/Status/DE/DBWagenreihung/Wagon.pm
@@ -8,7 +8,7 @@ use utf8;
use parent 'Class::Accessor';
use Carp qw(cluck);
-our $VERSION = '0.11';
+our $VERSION = '0.14';
Travel::Status::DE::DBWagenreihung::Wagon->mk_ro_accessors(
qw(attributes class_type group_index has_ac has_accessibility
has_bahn_comfort has_bike_storage has_bistro has_compartments
@@ -203,7 +203,12 @@ sub parse_type {
sub set_traintype {
my ( $self, $group_index, $tt ) = @_;
- $self->{group_index} = $group_index;
+ $self->{group_index} = $group_index;
+
+ if ( not $tt ) {
+ return;
+ }
+
$self->{train_subtype} = $tt;
if ( not $self->{number} or not exists( $type_attributes{$tt} ) ) {