summaryrefslogtreecommitdiff
path: root/lib/Travel/Status/DE/DBWagenreihung.pm
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Travel/Status/DE/DBWagenreihung.pm')
-rw-r--r--lib/Travel/Status/DE/DBWagenreihung.pm102
1 files changed, 76 insertions, 26 deletions
diff --git a/lib/Travel/Status/DE/DBWagenreihung.pm b/lib/Travel/Status/DE/DBWagenreihung.pm
index dcf1e8b..dd263a4 100644
--- a/lib/Travel/Status/DE/DBWagenreihung.pm
+++ b/lib/Travel/Status/DE/DBWagenreihung.pm
@@ -226,7 +226,6 @@ sub destinations {
for my $group ( @{ $self->{data}{istformation}{allFahrzeuggruppe} } ) {
my $destination = $group->{zielbetriebsstellename};
my @sections = map { $_->{fahrzeugsektor} } @{ $group->{allFahrzeug} };
- @sections = uniq @sections;
push( @{ $section{$destination} }, @sections );
push( @destinations, $destination );
}
@@ -234,7 +233,8 @@ sub destinations {
@destinations = uniq @destinations;
@destinations
- = map { { name => $_, sections => $section{$_} } } @destinations;
+ = map { { name => $_, sections => [ uniq @{ $section{$_} } ] } }
+ @destinations;
$self->{destinations} = \@destinations;
@@ -324,15 +324,15 @@ sub train_no {
return $self->{data}{istformation}{zugnummer};
}
+# TODO rename to wagongrop_powertype
sub train_powertype {
- my ($self) = @_;
+ my ( $self, @wagons ) = @_;
- if ( exists $self->{train_powertype} ) {
- return $self->{train_powertype};
+ if ( not @wagons ) {
+ @wagons = $self->wagons;
}
- my @wagons = $self->wagons;
- my %ml = map { $_ => 0 } ( 90 .. 99 );
+ my %ml = map { $_ => 0 } ( 90 .. 99 );
for my $wagon (@wagons) {
@@ -351,12 +351,51 @@ sub train_powertype {
my @likelihood = reverse sort { $ml{$a} <=> $ml{$b} } keys %ml;
if ( $ml{ $likelihood[0] } == 0 ) {
- return $self->{train_powertype} = undef;
+ return undef;
}
- return $self->{train_powertype} = $likelihood[0];
+ return $likelihood[0];
}
+sub train_descriptions {
+ my ($self) = @_;
+
+ my @ret;
+
+ for my $wagons ( @{ $self->{wagongroups} } ) {
+ my $powertype = $self->train_powertype( @{$wagons} );
+ my @model = $self->train_model( @{$wagons} );
+ my $desc = q{};
+
+ my @sections = uniq map { $_->section } @{$wagons};
+
+ if (@model) {
+ $desc .= $model[0];
+ }
+
+ if ( $powertype and $power_desc{$powertype} ) {
+ if ( not $desc and $power_desc{$powertype} =~ m{^mit} ) {
+ $desc = "Zug";
+ }
+ $desc .= " $power_desc{$powertype}";
+ }
+
+ if ( @model > 1 ) {
+ $desc .= " ($model[1])";
+ }
+ push(
+ @ret,
+ {
+ sections => [@sections],
+ text => $desc,
+ }
+ );
+ }
+
+ return @ret;
+}
+
+# TODO rename to wagongroup_desc
sub train_desc {
my ($self) = @_;
@@ -383,10 +422,11 @@ sub train_desc {
return $ret;
}
+# TODO rename to wagongroup_model
sub train_model {
- my ($self) = @_;
+ my ( $self, @wagons ) = @_;
- my $subtype = $self->train_subtype;
+ my $subtype = $self->train_subtype(@wagons);
if ( $subtype and $model_name{$subtype} ) {
return @{ $model_name{$subtype} };
@@ -397,15 +437,14 @@ sub train_model {
return;
}
+# TODO rename to wagongroup_subtype
sub train_subtype {
- my ($self) = @_;
+ my ( $self, @wagons ) = @_;
- if ( exists $self->{train_subtype} ) {
- return $self->{train_subtype};
+ if ( not @wagons ) {
+ @wagons = $self->wagons;
}
- my @wagons = $self->wagons;
-
my %ml = (
'401' => 0,
'402' => 0,
@@ -487,9 +526,7 @@ sub train_subtype {
return undef;
}
- $self->{train_subtype} = $likelihood[0];
-
- return $self->{train_subtype};
+ return $likelihood[0];
}
sub wagons {
@@ -499,16 +536,21 @@ sub 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}
@@ -526,16 +568,17 @@ sub wagons {
} @{ $self->{wagons} };
}
- # ->train_subtype calls ->wagons, so this call must not be made before
- # $self->{wagons} has beet set.
- my $tt = $self->train_subtype;
-
- if ($tt) {
- for my $wagon ( @{ $self->{wagons} } ) {
- $wagon->set_traintype($tt);
+ for my $group (@wagon_groups) {
+ my $tt = $self->train_subtype( @{$group} );
+ if ($tt) {
+ for my $wagon ( @{$group} ) {
+ $wagon->set_traintype($tt);
+ }
}
}
+ $self->{wagongroups} = [@wagon_groups];
+
return @{ $self->{wagons} // [] };
}
@@ -700,6 +743,13 @@ Returns the name of the requested station.
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->train_desc
Returns a string describing the rolling stock used for this train based on