diff options
Diffstat (limited to 'lib/Travel/Status/DE/DBWagenreihung.pm')
| -rw-r--r-- | lib/Travel/Status/DE/DBWagenreihung.pm | 347 |
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; |