summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
authorDaniel Friesel <derf@finalrewind.org>2014-01-17 09:19:35 +0100
committerDaniel Friesel <derf@finalrewind.org>2014-01-17 09:19:35 +0100
commitb19328aecd79a91ea4535edd8dddc2e4908d615f (patch)
tree1199462136ecbb4b222368000b5f3b4568e01f11 /lib
parent7a927e34c281defd5b60cf432a18a7405ba4d453 (diff)
implement -oq (qos_messages in Result.pm)
Diffstat (limited to 'lib')
-rw-r--r--lib/Travel/Status/DE/IRIS/Result.pm44
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 ) = @_;