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.pm347
1 files changed, 180 insertions, 167 deletions
diff --git a/lib/Travel/Status/DE/DBWagenreihung.pm b/lib/Travel/Status/DE/DBWagenreihung.pm
index ae65f22..03c0466 100644
--- a/lib/Travel/Status/DE/DBWagenreihung.pm
+++ b/lib/Travel/Status/DE/DBWagenreihung.pm
@@ -19,6 +19,8 @@ our $VERSION = '0.12';
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,
@@ -103,6 +105,9 @@ my %power_desc = (
99 => 'Sonderfahrzeug',
);
+# }}}
+# {{{ Constructors
+
sub new {
my ( $class, %opt ) = @_;
@@ -184,69 +189,94 @@ sub get_wagonorder {
return $self->parse_wagonorder;
}
-sub parse_wagonorder {
- my ($self) = @_;
+# }}}
+# {{{ Internal Helpers
- $self->{platform} = $self->{data}{istformation}{halt}{gleisbezeichnung};
+sub get_with_cache {
+ my ( $self, $cache, $url ) = @_;
- $self->{station} = {
- ds100 => $self->{data}{istformation}{halt}{rl100},
- eva => $self->{data}{istformation}{halt}{evanummer},
- name => $self->{data}{istformation}{halt}{bahnhofsname},
- };
+ if ( $self->{developer_mode} ) {
+ say "GET $url";
+ }
- $self->{train_type} = $self->{data}{istformation}{zuggattung};
- $self->{train_no} = $self->{data}{istformation}{zugnummer};
+ if ($cache) {
+ my $content = $cache->thaw($url);
+ if ($content) {
+ if ( $self->{developer_mode} ) {
+ say ' cache hit';
+ }
+ return ( ${$content}, undef );
+ }
+ }
- $self->parse_wagons;
- $self->{origins} = $self->parse_wings('startbetriebsstellename');
- $self->{destinations} = $self->parse_wings('zielbetriebsstellename');
-}
+ if ( $self->{developer_mode} ) {
+ say ' cache miss';
+ }
-sub errstr {
- my ($self) = @_;
+ my $ua = $self->{user_agent};
+ my $res = $ua->get($url);
- return $self->{errstr};
+ if ( $res->is_error ) {
+ return ( undef, $res->status_line );
+ }
+ my $content = $res->decoded_content;
+
+ if ($cache) {
+ $cache->freeze( $url, \$content );
+ }
+
+ return ( $content, undef );
}
-sub TO_JSON {
- my ($self) = @_;
+sub wagongroup_powertype {
+ my ( $self, @wagons ) = @_;
- # ensure that all objects are available
- $self->origins;
- $self->destinations;
- $self->train_numbers;
- $self->train_descriptions;
- $self->sections;
+ if ( not @wagons ) {
+ @wagons = $self->wagons;
+ }
- my %copy = %{$self};
+ my %ml = map { $_ => 0 } ( 90 .. 99 );
- delete $copy{from_json};
+ for my $wagon (@wagons) {
- return {%copy};
-}
+ if ( not $wagon->uic_id or length( $wagon->uic_id ) != 12 ) {
+ next;
+ }
-sub has_bad_wagons {
- my ($self) = @_;
+ my $wagon_type = substr( $wagon->uic_id, 0, 2 );
+ if ( $wagon_type < 90 ) {
+ next;
+ }
- if ( defined $self->{has_bad_wagons} ) {
- return $self->{has_bad_wagons};
+ $ml{$wagon_type}++;
}
- 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;
- }
- }
+ my @likelihood = reverse sort { $ml{$a} <=> $ml{$b} } keys %ml;
+
+ if ( $ml{ $likelihood[0] } == 0 ) {
+ return undef;
}
- return $self->{has_bad_wagons} = 0;
+ return $likelihood[0];
+}
+
+sub parse_wagonorder {
+ my ($self) = @_;
+
+ $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->parse_wings('startbetriebsstellename');
+ $self->{destinations} = $self->parse_wings('zielbetriebsstellename');
}
sub parse_wings {
@@ -270,6 +300,63 @@ sub parse_wings {
return \@names;
}
+sub parse_wagons {
+ my ($self) = @_;
+
+ 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];
+}
+
+# }}}
+# {{{ Public Functions
+
+sub errstr {
+ my ($self) = @_;
+
+ return $self->{errstr};
+}
+
sub destinations {
my ($self) = @_;
@@ -309,6 +396,30 @@ sub sections {
return @{ $self->{sections} // [] };
}
+sub train_descriptions {
+ my ($self) = @_;
+
+ if ( exists $self->{train_descriptions} ) {
+ return @{ $self->{train_descriptions} };
+ }
+
+ for my $wagons ( @{ $self->{wagongroups} } ) {
+ my ( $short, $desc ) = $self->wagongroup_description( @{$wagons} );
+ my @sections = uniq map { $_->section } @{$wagons};
+
+ push(
+ @{ $self->{train_descriptions} },
+ {
+ sections => [@sections],
+ short => $short,
+ text => $desc,
+ }
+ );
+ }
+
+ return @{ $self->{train_descriptions} };
+}
+
sub train_numbers {
my ($self) = @_;
@@ -329,60 +440,27 @@ sub train_numbers {
return @numbers;
}
-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 ( 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 {
@@ -635,89 +713,24 @@ sub wagons {
return @{ $self->{wagons} // [] };
}
-sub parse_wagons {
+sub TO_JSON {
my ($self) = @_;
- my @wagon_groups;
+ # ensure that all objects are available
+ $self->origins;
+ $self->destinations;
+ $self->train_numbers;
+ $self->train_descriptions;
+ $self->sections;
- 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} };
- }
+ my %copy = %{$self};
- 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 );
- }
- }
- }
+ delete $copy{from_json};
- $self->{wagongroups} = [@wagon_groups];
+ return {%copy};
}
-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 );
- }
- }
-
- if ( $self->{developer_mode} ) {
- say ' cache miss';
- }
-
- my $ua = $self->{user_agent};
- my $res = $ua->get($url);
-
- if ( $res->is_error ) {
- return ( undef, $res->status_line );
- }
- my $content = $res->decoded_content;
-
- if ($cache) {
- $cache->freeze( $url, \$content );
- }
-
- return ( $content, undef );
-}
+# }}}
1;