From 239820ffbaf2eab648bd278508db02440e2ff1f4 Mon Sep 17 00:00:00 2001 From: Daniel Friesel Date: Mon, 10 Oct 2022 21:50:09 +0200 Subject: HAFAS->new: support 'journey' requests. polylines and route still WiP --- lib/Travel/Status/DE/HAFAS.pm | 164 +++++++++++++++++++++++---------- lib/Travel/Status/DE/HAFAS/Journey.pm | 83 +++++++++-------- lib/Travel/Status/DE/HAFAS/Polyline.pm | 96 +++++++++++++++++++ 3 files changed, 257 insertions(+), 86 deletions(-) create mode 100644 lib/Travel/Status/DE/HAFAS/Polyline.pm (limited to 'lib') diff --git a/lib/Travel/Status/DE/HAFAS.pm b/lib/Travel/Status/DE/HAFAS.pm index 769ff39..9270d2a 100644 --- a/lib/Travel/Status/DE/HAFAS.pm +++ b/lib/Travel/Status/DE/HAFAS.pm @@ -17,6 +17,7 @@ use List::Util qw(any); use LWP::UserAgent; use POSIX qw(strftime); use Travel::Status::DE::HAFAS::Message; +use Travel::Status::DE::HAFAS::Polyline qw(decode_polyline); use Travel::Status::DE::HAFAS::Journey; use Travel::Status::DE::HAFAS::StopFinder; @@ -186,7 +187,7 @@ sub new { $ua->env_proxy; } - if ( not $conf{station} ) { + if ( not $conf{station} and not $conf{journey} ) { confess('You need to specify a station'); } @@ -215,56 +216,80 @@ sub new { bless( $self, $obj ); - my $date = ( $conf{datetime} // $now )->strftime('%Y%m%d'); - my $time = ( $conf{datetime} // $now )->strftime('%H%M%S'); - - my $lid; - if ( $self->{station} =~ m{ ^ [0-9]+ $ }x ) { - $lid = 'A=1@L=' . $self->{station} . '@'; + my $req; + + if ( $conf{journey} ) { + $req = { + svcReqL => [ + { + meth => 'JourneyDetails', + req => { + jid => $conf{journey}{id}, + name => $conf{journey}{name} // '0', + getPolyline => $conf{with_polyline} ? \1 : \0, + }, + } + ], + %{ $hafas_instance{$service}{request} } + }; } else { - $lid = 'A=1@O=' . $self->{station} . '@'; - } + my $date = ( $conf{datetime} // $now )->strftime('%Y%m%d'); + my $time = ( $conf{datetime} // $now )->strftime('%H%M%S'); - my $mot_mask = 2**@{ $hafas_instance{$service}{productbits} } - 1; + my $lid; + if ( $self->{station} =~ m{ ^ [0-9]+ $ }x ) { + $lid = 'A=1@L=' . $self->{station} . '@'; + } + else { + $lid = 'A=1@O=' . $self->{station} . '@'; + } - my %mot_pos; - for my $i ( 0 .. $#{ $hafas_instance{$service}{productbits} } ) { - $mot_pos{ $hafas_instance{$service}{productbits}[$i] } = $i; - } + my $mot_mask = 2**@{ $hafas_instance{$service}{productbits} } - 1; - if ( my @mots = @{ $self->{exclusive_mots} // [] } ) { - $mot_mask = 0; - for my $mot (@mots) { - $mot_mask |= 1 << $mot_pos{$mot}; + my %mot_pos; + for my $i ( 0 .. $#{ $hafas_instance{$service}{productbits} } ) { + $mot_pos{ $hafas_instance{$service}{productbits}[$i] } = $i; } - } - if ( my @mots = @{ $self->{excluded_mots} // [] } ) { - for my $mot (@mots) { - $mot_mask &= ~( 1 << $mot_pos{$mot} ); + if ( my @mots = @{ $self->{exclusive_mots} // [] } ) { + $mot_mask = 0; + for my $mot (@mots) { + $mot_mask |= 1 << $mot_pos{$mot}; + } } - } - my $req = { - svcReqL => [ - { - req => { - type => ( $conf{arrivals} ? 'ARR' : 'DEP' ), - stbLoc => { lid => $lid }, - dirLoc => undef, - maxJny => 30, - date => $date, - time => $time, - dur => -1, - jnyFltrL => - [ { type => "PROD", mode => "INC", value => $mot_mask } ] - }, - meth => 'StationBoard' + if ( my @mots = @{ $self->{excluded_mots} // [] } ) { + for my $mot (@mots) { + $mot_mask &= ~( 1 << $mot_pos{$mot} ); } - ], - %{ $hafas_instance{$service}{request} } - }; + } + + $req = { + svcReqL => [ + { + meth => 'StationBoard', + req => { + type => ( $conf{arrivals} ? 'ARR' : 'DEP' ), + stbLoc => { lid => $lid }, + dirLoc => undef, + maxJny => 30, + date => $date, + time => $time, + dur => -1, + jnyFltrL => [ + { + type => "PROD", + mode => "INC", + value => $mot_mask + } + ] + }, + }, + ], + %{ $hafas_instance{$service}{request} } + }; + } my $json = $self->{json} = JSON->new->utf8; @@ -318,7 +343,18 @@ sub new { } $self->check_mgate; - $self->parse_mgate; + + $self->{strptime_obj} //= DateTime::Format::Strptime->new( + pattern => '%Y%m%dT%H%M%S', + time_zone => 'Europe/Berlin', + ); + + if ( $conf{journey} ) { + $self->parse_journey; + } + else { + $self->parse_board; + } return $self; } @@ -339,7 +375,7 @@ sub new_p { my ($content) = @_; $self->{raw_json} = $self->{json}->decode($content); $self->check_mgate; - $self->parse_mgate; + $self->parse_board; $promise->resolve($self); return; } @@ -549,19 +585,44 @@ sub messages { return @{ $self->{messages} }; } -sub parse_mgate { +sub parse_journey { my ($self) = @_; - $self->{results} = []; - if ( $self->{errstr} ) { return $self; } - $self->{strptime_obj} //= DateTime::Format::Strptime->new( - pattern => '%Y%m%dT%H%M%S', - time_zone => 'Europe/Berlin', + my @locL = @{ $self->{raw_json}{svcResL}[0]{res}{common}{locL} // [] }; + my $journey = $self->{raw_json}{svcResL}[0]{res}{journey}; + my @polyline; + + if ( $journey->{poly} ) { + @polyline = decode_polyline( $journey->{poly}{crdEncYX} ); + for my $ref ( @{ $journey->{poly}{ppLocRefL} // [] } ) { + my $poly = $polyline[ $ref->{ppIdx} ]; + my $loc = $locL[ $ref->{locX} ]; + + $poly->{name} = $loc->{name}; + $poly->{eva} = $loc->{extId} + 0; + } + } + + $self->{result} = Travel::Status::DE::HAFAS::Journey->new( + common => $self->{raw_json}{svcResL}[0]{res}{common}, + journey => $journey, + polyline => \@polyline, + hafas => $self, ); +} + +sub parse_board { + my ($self) = @_; + + $self->{results} = []; + + if ( $self->{errstr} ) { + return $self; + } my @jnyL = @{ $self->{raw_json}{svcResL}[0]{res}{jnyL} // [] }; @@ -583,6 +644,11 @@ sub results { return @{ $self->{results} }; } +sub result { + my ($self) = @_; + return $self->{result}; +} + # static sub get_services { my @services; diff --git a/lib/Travel/Status/DE/HAFAS/Journey.pm b/lib/Travel/Status/DE/HAFAS/Journey.pm index 31675ba..da29804 100644 --- a/lib/Travel/Status/DE/HAFAS/Journey.pm +++ b/lib/Travel/Status/DE/HAFAS/Journey.pm @@ -29,26 +29,10 @@ sub new { my $journey = $opt{journey}; my $date = $journey->{date}; - my $time_s - = $journey->{stbStop}{ $hafas->{arrivals} ? 'aTimeS' : 'dTimeS' }; - my $time_r - = $journey->{stbStop}{ $hafas->{arrivals} ? 'aTimeR' : 'dTimeR' }; - my $datetime_s - = $hafas->{strptime_obj}->parse_datetime("${date}T${time_s}"); - my $datetime_r - = $time_r - ? $hafas->{strptime_obj}->parse_datetime("${date}T${time_r}") - : undef; - my $delay - = $datetime_r - ? ( $datetime_r->epoch - $datetime_s->epoch ) / 60 - : undef; my $destination = $journey->{dirTxt}; my $is_cancelled = $journey->{isCncl}; my $jid = $journey->{jid}; - my $platform = $journey->{stbStop}{dPlatfS}; - my $new_platform = $journey->{stbStop}{dPlatfR}; my $product = $prodL[ $journey->{prodX} ]; my $train = $product->{prodCtx}{name}; @@ -108,33 +92,58 @@ sub new { shift @stops; my $ref = { - sched_datetime => $datetime_s, - rt_datetime => $datetime_r, - datetime => $datetime_r // $datetime_s, - datetime_now => $hafas->{now}, - delay => $delay, - is_cancelled => $is_cancelled, - train => $train, - operator => $operator, - route_end => $destination, - platform => $platform, - new_platform => $new_platform, - messages => \@messages, - route => \@stops, + datetime_now => $hafas->{now}, + is_cancelled => $is_cancelled, + train => $train, + operator => $operator, + route_end => $destination, + messages => \@messages, + route => \@stops, }; bless( $ref, $obj ); - if ( $ref->{delay} ) { - $ref->{datetime} = $ref->{rt_datetime}; + if ( $journey->{stbStop} ) { + $ref->{platform} = $journey->{stbStop}{dPlatfS}; + $ref->{new_platform} = $journey->{stbStop}{dPlatfR}; + + my $time_s + = $journey->{stbStop}{ $hafas->{arrivals} ? 'aTimeS' : 'dTimeS' }; + my $time_r + = $journey->{stbStop}{ $hafas->{arrivals} ? 'aTimeR' : 'dTimeR' }; + + my $datetime_s + = $hafas->{strptime_obj}->parse_datetime("${date}T${time_s}"); + my $datetime_r + = $time_r + ? $hafas->{strptime_obj}->parse_datetime("${date}T${time_r}") + : undef; + + my $delay + = $datetime_r + ? ( $datetime_r->epoch - $datetime_s->epoch ) / 60 + : undef; + + $ref->{sched_datetime} = $datetime_s; + $ref->{rt_datetime} = $datetime_r; + $ref->{datetime} = $datetime_r // $datetime_s; + $ref->{delay} = $delay; + + if ( $ref->{delay} ) { + $ref->{datetime} = $ref->{rt_datetime}; + } + else { + $ref->{datetime} = $ref->{sched_datetime}; + } + + $ref->{date} = $ref->{datetime}->strftime('%d.%m.%Y'); + $ref->{time} = $ref->{datetime}->strftime('%H:%M'); + $ref->{sched_date} = $ref->{sched_datetime}->strftime('%d.%m.%Y'); + $ref->{sched_time} = $ref->{sched_datetime}->strftime('%H:%M'); } - else { - $ref->{datetime} = $ref->{sched_datetime}; + if ( $opt{polyline} ) { + $ref->{polyline} = $opt{polyline}; } - $ref->{date} = $ref->{datetime}->strftime('%d.%m.%Y'); - $ref->{time} = $ref->{datetime}->strftime('%H:%M'); - $ref->{sched_date} = $ref->{sched_datetime}->strftime('%d.%m.%Y'); - $ref->{sched_time} = $ref->{sched_datetime}->strftime('%H:%M'); return $ref; } diff --git a/lib/Travel/Status/DE/HAFAS/Polyline.pm b/lib/Travel/Status/DE/HAFAS/Polyline.pm new file mode 100644 index 0000000..2d82912 --- /dev/null +++ b/lib/Travel/Status/DE/HAFAS/Polyline.pm @@ -0,0 +1,96 @@ +package Travel::Status::DE::HAFAS::Polyline; + +use strict; +use warnings; +use 5.014; + +# Adapted from code by Slaven Rezic +# +# Copyright (C) 2009,2010,2012,2017,2018 Slaven Rezic. All rights reserved. +# This package is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +# Mail: slaven@rezic.de +# WWW: http://www.rezic.de/eserte/ + +use parent 'Exporter'; +our @EXPORT_OK = qw(decode_polyline); +our $VERSION = '0.06'; + +# Translated this php script +# +# to perl +sub decode_polyline { + my ($encoded) = @_; + + my $length = length $encoded; + my $index = 0; + my @points; + my $lat = 0; + my $lng = 0; + + while ( $index < $length ) { + + # The encoded polyline consists of a latitude value followed + # by a longitude value. They should always come in pairs. Read + # the latitude value first. + for my $val ( \$lat, \$lng ) { + my $shift = 0; + my $result = 0; + + # Temporary variable to hold each ASCII byte. + my $b; + do { + # The `ord(substr($encoded, $index++))` statement returns + # the ASCII code for the character at $index. Subtract 63 + # to get the original value. (63 was added to ensure + # proper ASCII characters are displayed in the encoded + # polyline string, which is `human` readable) + $b = ord( substr( $encoded, $index++, 1 ) ) - 63; + + # AND the bits of the byte with 0x1f to get the original + # 5-bit `chunk. Then left shift the bits by the required + # amount, which increases by 5 bits each time. OR the + # value into $results, which sums up the individual 5-bit + # chunks into the original value. Since the 5-bit chunks + # were reversed in order during encoding, reading them in + # this way ensures proper summation. + $result |= ( $b & 0x1f ) << $shift; + $shift += 5; + } + + # Continue while the read byte is >= 0x20 since the last + # `chunk` was not OR'd with 0x20 during the conversion + # process. (Signals the end) + while ( $b >= 0x20 ); + + # see last paragraph of "Integer Arithmetic" in perlop.pod + use integer; + + # Check if negative, and convert. (All negative values have the last bit + # set) + my $dtmp + = ( ( $result & 1 ) ? ~( $result >> 1 ) : ( $result >> 1 ) ); + + # Compute actual latitude (resp. longitude) since value is + # offset from previous value. + $$val += $dtmp; + } + + # The actual latitude and longitude values were multiplied by + # 1e5 before encoding so that they could be converted to a 32-bit + # integer representation. (With a decimal accuracy of 5 places) + # Convert back to original values. + push( + @points, + { + lat => $lat * 1e-5, + lon => $lng * 1e-5 + } + ); + } + + return @points; +} + +1; -- cgit v1.2.3