summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rwxr-xr-xbin/db-wagenreihung32
-rw-r--r--lib/Travel/Status/DE/DBWagenreihung.pm45
-rw-r--r--lib/Travel/Status/DE/DBWagenreihung/Group.pm24
3 files changed, 68 insertions, 33 deletions
diff --git a/bin/db-wagenreihung b/bin/db-wagenreihung
index c1daac1..0f13c54 100755
--- a/bin/db-wagenreihung
+++ b/bin/db-wagenreihung
@@ -149,22 +149,30 @@ 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->number || '?' ),
+ $wagon->model || '???',
+ $wagon->type, join( q{ }, $wagon->attributes )
+ );
+ }
+ say "";
}
__END__
diff --git a/lib/Travel/Status/DE/DBWagenreihung.pm b/lib/Travel/Status/DE/DBWagenreihung.pm
index ea14ec9..6c33971 100644
--- a/lib/Travel/Status/DE/DBWagenreihung.pm
+++ b/lib/Travel/Status/DE/DBWagenreihung.pm
@@ -261,6 +261,29 @@ sub wagongroup_powertype {
return $likelihood[0];
}
+sub parse_train_descriptions {
+ my ($self) = @_;
+
+ for my $group ( @{ $self->{wagongroups} } ) {
+ my ( $short, $desc ) = $self->wagongroup_description( $group->wagons );
+ my @sections = uniq map { $_->section } $group->wagons;
+
+ if ( @sections and length( join( q{}, @sections ) ) ) {
+ $group->set_sections(@sections);
+ }
+ $group->set_description( $desc, $short );
+
+ push(
+ @{ $self->{train_descriptions} },
+ {
+ sections => [@sections],
+ short => $short,
+ text => $desc,
+ }
+ );
+ }
+}
+
sub parse_wagonorder {
my ($self) = @_;
@@ -276,6 +299,7 @@ sub parse_wagonorder {
$self->{train_no} = $self->{data}{istformation}{zugnummer};
$self->parse_wagons;
+ $self->parse_train_descriptions;
$self->{origins} = $self->parse_wings('startbetriebsstellename');
$self->{destinations} = $self->parse_wings('zielbetriebsstellename');
}
@@ -406,26 +430,7 @@ sub sections {
sub train_descriptions {
my ($self) = @_;
-
- if ( exists $self->{train_descriptions} ) {
- return @{ $self->{train_descriptions} };
- }
-
- for my $group ( @{ $self->{wagongroups} } ) {
- my ( $short, $desc ) = $self->wagongroup_description( $group->wagons );
- my @sections = uniq map { $_->section } $group->wagons;
-
- push(
- @{ $self->{train_descriptions} },
- {
- sections => [@sections],
- short => $short,
- text => $desc,
- }
- );
- }
-
- return @{ $self->{train_descriptions} };
+ return @{ $self->{train_descriptions} // [] };
}
sub train_numbers {
diff --git a/lib/Travel/Status/DE/DBWagenreihung/Group.pm b/lib/Travel/Status/DE/DBWagenreihung/Group.pm
index 76fc159..a627b6e 100644
--- a/lib/Travel/Status/DE/DBWagenreihung/Group.pm
+++ b/lib/Travel/Status/DE/DBWagenreihung/Group.pm
@@ -10,7 +10,8 @@ use parent 'Class::Accessor';
our $VERSION = '0.13';
Travel::Status::DE::DBWagenreihung::Group->mk_ro_accessors(
- qw(id train_no type origin destination));
+ qw(id train_no type description desc_short origin destination has_sections)
+);
sub new {
my ( $obj, %opt ) = @_;
@@ -19,6 +20,21 @@ sub new {
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;
@@ -35,6 +51,12 @@ sub sort_wagons {
@{ $self->{wagons} };
}
+sub sections {
+ my ($self) = @_;
+
+ return @{ $self->{sections} // [] };
+}
+
sub wagons {
my ($self) = @_;