diff options
author | Daniel Friesel <derf@finalrewind.org> | 2014-01-17 09:19:35 +0100 |
---|---|---|
committer | Daniel Friesel <derf@finalrewind.org> | 2014-01-17 09:19:35 +0100 |
commit | b19328aecd79a91ea4535edd8dddc2e4908d615f (patch) | |
tree | 1199462136ecbb4b222368000b5f3b4568e01f11 /lib | |
parent | 7a927e34c281defd5b60cf432a18a7405ba4d453 (diff) |
implement -oq (qos_messages in Result.pm)
Diffstat (limited to 'lib')
-rw-r--r-- | lib/Travel/Status/DE/IRIS/Result.pm | 44 |
1 files changed, 43 insertions, 1 deletions
diff --git a/lib/Travel/Status/DE/IRIS/Result.pm b/lib/Travel/Status/DE/IRIS/Result.pm index d3fd0f5..0438722 100644 --- a/lib/Travel/Status/DE/IRIS/Result.pm +++ b/lib/Travel/Status/DE/IRIS/Result.pm @@ -11,7 +11,7 @@ use parent 'Class::Accessor'; use Carp qw(cluck); use DateTime; use DateTime::Format::Strptime; -use List::MoreUtils qw(uniq); +use List::MoreUtils qw(none uniq); our $VERSION = '0.00'; @@ -192,6 +192,37 @@ sub delay_messages { return @ret; } +sub qos_messages { + my ($self) = @_; + + my $strp = DateTime::Format::Strptime->new( + pattern => '%y%m%d%H%M', + time_zone => 'Europe/Berlin', + ); + + my @keys = sort keys %{ $self->{messages} }; + my @msgs = grep { $_->[1] eq 'q' } map { $self->{messages}{$_} } @keys; + my @ret; + + for my $msg (@msgs) { + if ( my @superseded = $self->superseded_messages( $msg->[2] ) ) { + @ret = grep { not( $_->[2] ~~ \@superseded ) } @ret; + } + + # 88 is "no qos shortcomings" and only required to filter previous + # qos messages + if ( $msg->[2] != 88 and ( none { $_->[2] == $msg->[2] } @ret ) ) { + push( @ret, $msg ); + } + } + + @ret = map { + [ $strp->parse_datetime( $_->[0] ), $self->translate_msg( $_->[2] ) ] + } @ret; + + return @ret; +} + sub messages { my ($self) = @_; @@ -323,6 +354,17 @@ sub sched_route { $self->sched_route_post ); } +sub superseded_messages { + my ( $self, $msg ) = @_; + + my %superseded = ( + 84 => [ 80, 82, 83, 85 ], + 88 => [ 80, 82, 83, 85, 86, 87, 90, 91, 92, 93, 96, 97, 98 ], + ); + + return @{ $superseded{$msg} // [] }; +} + sub translate_msg { my ( $self, $msg ) = @_; |