diff options
| -rw-r--r-- | .gitignore | 6 | ||||
| -rwxr-xr-x | bin/hafas | 357 | ||||
| -rw-r--r-- | lib/Travel/Routing/DE/HAFAS.pm | 626 | ||||
| -rw-r--r-- | lib/Travel/Routing/DE/HAFAS/Connection.pm | 147 | ||||
| -rw-r--r-- | lib/Travel/Routing/DE/HAFAS/Connection/Section.pm | 115 | ||||
| -rw-r--r-- | lib/Travel/Routing/DE/HAFAS/Location.pm | 33 | ||||
| -rw-r--r-- | lib/Travel/Routing/DE/HAFAS/Utils.pm | 32 |
7 files changed, 1316 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..697aac5 --- /dev/null +++ b/.gitignore @@ -0,0 +1,6 @@ +/_build +/Build +/blib +/cover_db +/MANIFEST* +/MYMETA.* diff --git a/bin/hafas b/bin/hafas new file mode 100755 index 0000000..f77ddd6 --- /dev/null +++ b/bin/hafas @@ -0,0 +1,357 @@ +#!perl +use strict; +use warnings; +use 5.014; + +our $VERSION = '0.00'; + +use utf8; +use DateTime; +use Encode qw(decode); +use JSON; +use Getopt::Long qw(:config no_ignore_case); +use List::MoreUtils qw(uniq); +use List::Util qw(first max); +use Travel::Routing::DE::HAFAS; + +my ( $date, $time, $language ); +my $types = q{}; +my $developer_mode; +my $json_output; +my ( $list_services, $service ); +my ( @excluded_mots, @exclusive_mots ); + +my @output; + +binmode( STDOUT, ':encoding(utf-8)' ); +for my $arg (@ARGV) { + $arg = decode( 'UTF-8', $arg ); +} + +GetOptions( + 'd|date=s' => \$date, + 'h|help' => sub { show_help(0) }, + 'l|language=s' => \$language, + 'm|mot=s' => \$types, + 's|service=s' => \$service, + 't|time=s' => \$time, + 'V|version' => \&show_version, + 'devmode' => \$developer_mode, + 'json' => \$json_output, + 'list' => \$list_services, + +) or show_help(1); + +if ($list_services) { + printf( "%-40s %-14s %s\n\n", 'operator', 'abbr. (-s)', 'languages (-l)' ); + for my $service ( Travel::Routing::DE::HAFAS::get_services() ) { + printf( + "%-40s %-14s %s\n", + @{$service}{qw(name shortname)}, + join( q{ }, @{ $service->{languages} // [] } ) + ); + } + exit 0; +} + +parse_mot_options(); + +my ($from_stop, $to_stop) = @ARGV; + +if (not $from_stop and $to_stop) { + show_help(1); +} + +my %opt = ( + excluded_mots => \@excluded_mots, + exclusive_mots => \@exclusive_mots, + from_stop => $from_stop, + to_stop => $to_stop, + developer_mode => $developer_mode, + service => $service, + language => $language, +); + +if ( $date or $time ) { + my $dt = DateTime->now( time_zone => 'Europe/Berlin' ); + if ($date) { + if ( $date + =~ m{ ^ (?<day> \d{1,2} ) [.] (?<month> \d{1,2} ) [.] (?<year> \d{4})? $ }x + ) + { + $dt->set( + day => $+{day}, + month => $+{month} + ); + if ( $+{year} ) { + $dt->set( year => $+{year} ); + } + } + else { + say "--date must be specified as DD.MM.[YYYY]"; + exit 1; + } + } + if ($time) { + if ( $time =~ m{ ^ (?<hour> \d{1,2} ) : (?<minute> \d{1,2} ) $ }x ) { + $dt->set( + hour => $+{hour}, + minute => $+{minute}, + second => 0, + ); + } + else { + say "--time must be specified as HH:MM"; + exit 1; + } + } + $opt{datetime} = $dt; +} + +my $hafas = Travel::Routing::DE::HAFAS->new(%opt); + +sub show_help { + my ($code) = @_; + + print 'Usage: hafas [-d <dd.mm.yyyy>] [-m <motlist>] [-t <time>] ' + . "<from> <to>\n" + . "See also: man hafas\n"; + + exit $code; +} + +sub show_version { + say "hafas version ${VERSION}"; + + exit 0; +} + +sub parse_mot_options { + + my $default_yes = 1; + + for my $type ( split( qr{,}, $types ) ) { + if ( $type eq 'help' or $type eq 'list' or $type eq q{?} ) { + $service //= 'DB'; + my $desc = Travel::Status::DE::HAFAS::get_service($service); + if ($desc) { + my @mots = @{ $desc->{productbits} }; + @mots = grep { $_ ne 'x' } @mots; + @mots = uniq @mots; + @mots = sort @mots; + say join( "\n", @mots ); + exit 0; + } + else { + say STDERR 'no modes of transport known for this service'; + exit 1; + } + } + elsif ( substr( $type, 0, 1 ) eq q{!} ) { + push( @excluded_mots, substr( $type, 1 ) ); + } + else { + push( @exclusive_mots, $type ); + } + } + return; +} + +sub show_similar_stops { + my @candidates = $hafas->similar_stops; + if (@candidates) { + say 'You might want to try one of the following stops:'; + for my $c (@candidates) { + printf( "%s (%s)\n", $c->{name}, $c->{id} ); + } + } + return; +} + +sub display_occupancy { + my ($occupancy) = @_; + + if ( $occupancy == 1 ) { + return q{.}; + } + if ( $occupancy == 2 ) { + return q{o}; + } + if ( $occupancy == 3 ) { + return q{*}; + } + if ( $occupancy == 4 ) { + return q{!}; + } + return q{?}; +} + +sub display_occupancies { + my ($load) = @_; + + if ($load and ($load->{FIRST} or $load->{SECOND})) { + return sprintf("[%1s%1s]", display_occupancy($load->{FIRST}), display_occupancy($load->{SECOND})); + } + + return q{ }; +} + +sub format_delay { + my ($delay) = @_; + if ($delay) { + return sprintf('(%+4d)', $delay); + } + return q{}; +} + +if ( my $err = $hafas->errstr ) { + say STDERR "Request error: ${err}"; + if ( $hafas->errcode + and ( $hafas->errcode eq 'H730' or $hafas->errcode eq 'LOCATION' ) ) + { + show_similar_stops(); + } + exit 2; +} + +if ($json_output) { + say JSON->new->convert_blessed->encode( [ $hafas->results ] ); + exit 0; +} + +for my $res (@{$hafas->{results}}) { + printf("# %02d:%02d %s\n", $res->duration->in_units('hours', 'minutes'), display_occupancies($res->load)); + for my $msg ( $res->messages ) { + if ( $msg->short ) { + printf( "# %s\n", $msg->short ); + } + printf( "# %s\n", $msg->text ); + } + + my $have_delay = 0; + + for my $sec ($res->sections) { + if ($sec->dep_delay or $sec->arr_delay) { + $have_delay = 7; + } + } + + for my $sec ($res->sections) { + if ($sec->type eq 'JNY') { + printf("%-5s %-${have_delay}s ab %s\n", $sec->dep_datetime->strftime('%H:%M'), format_delay($sec->dep_delay), $sec->dep_loc->name); + printf("%10s%${have_delay}s %s → %s\n", q{}, q{}, $sec->name, $sec->direction); + printf("%-5s %-${have_delay}s an %s\n", $sec->arr_datetime->strftime('%H:%M'), format_delay($sec->arr_delay), $sec->arr_loc->name); + } + elsif ($sec->type eq 'WALK') { + printf("%-5s %-${have_delay}s ab %s\n", $sec->dep_datetime->strftime('%H:%M'), q{}, $sec->dep_loc->name); + printf("%10s%${have_delay}s Fußweg %dm (%02d:%02d)\n", q{}, q{}, $sec->distance, $sec->duration->in_units('hours', 'minutes')); + printf("%-5s %-${have_delay}s an %s\n", $sec->arr_datetime->strftime('%H:%M'), q{}, $sec->arr_loc->name); + } + else { + printf("\n???\n"); + } + say q{}; + } + printf("\n%s\n\n", q{-} x 40); +} + +__END__ + +=head1 NAME + +hafas - Interface to the HAFAS (e.g. Deutsche Bahn) trip search + +=head1 SYNOPSIS + +B<hafas> [B<-d> I<date>] [B<-t> I<time>] [B<-m> I<motlist>] +[B<-s> I<service>] [B<-l> I<language>] I<from> I<to> + +=head1 VERSION + +version 0.00 + +=head1 DESCRIPTION + +tbd + +=head1 OPTIONS + +=over + +=item B<-d>, B<--date> I<dd>.I<mm>.[I<yyyy>] + +Planned departure (or arrival) date. Default: today. + +=item B<--json> + +Print result(s) as JSON. This is a dump of internal data structures and not +guaranteed to remain stable between minor versions. Please use the +Travel::Routing::DE::HAFAS(3pm) module if you need a proper API. + +=item B<-l>, B<--language> I<language> + +Request free-text messages to be provided in I<language>. +See B<--list> for a list of languages supported by individual HAFAS instances. +Note that requesting an invalid/unsupported language may lead to garbage output. + +=item B<--list> + +List known HAFAS installations and exit. Use B<-s>|B<--service> to select an +operator from this list for a HAFAS request. + +=item B<-m>, B<--mot> I<motlist> + +By default, B<hafas> considers all modes of transport for routing. With +I<motlist>, it is possible to either exclude a list of modes, or exclusively +show only a select list of modes. + +To exclude modes, set I<motlist> to B<!>I<mot1>,B<!>I<mot2>,... + +To show them exclusively, set I<motlist> to I<mot1>,I<mot2>,... + +The I<mot> types depend on the used service. Use C<< -m help >> to list them. + +=item B<-s>, B<--service> I<service> + +Use the API provided by I<service> for routing; defaults to DB (Deutsche Bahn). +See B<--list> for a list of known services. + +=item B<-t>, B<--time> I<hh>:I<mm> + +Planned departure (or arrival) time. Default: now. + +=item B<-V>, B<--version> + +Show version information and exit. + +=back + +=head1 EXIT STATUS + +0 upon success, 1 upon internal error, 2 upon backend error. + +=head1 CONFIGURATION + +None. + +=head1 DEPENDENCIES + +=over + +=item * Class::Accessor(3pm) + +=item * LWP::UserAgent(3pm) + +=back + +=head1 BUGS AND LIMITATIONS + +The non-default services (anything other than DB) are not well-tested. + +=head1 AUTHOR + +Copyright (C) 2023 by Birte Kristina Friesel E<lt>derf@finalrewind.orgE<gt> + +=head1 LICENSE + +This program is licensed under the same terms as Perl itself. diff --git a/lib/Travel/Routing/DE/HAFAS.pm b/lib/Travel/Routing/DE/HAFAS.pm new file mode 100644 index 0000000..aab45b3 --- /dev/null +++ b/lib/Travel/Routing/DE/HAFAS.pm @@ -0,0 +1,626 @@ +package Travel::Routing::DE::HAFAS; + +# vim:foldmethod=marker + +use strict; +use warnings; +use 5.014; +use utf8; + +use Carp qw(confess); +use DateTime; +use DateTime::Format::Strptime; +use Digest::MD5 qw(md5_hex); +use Encode qw(decode encode); +use JSON; +use LWP::UserAgent; +use Travel::Routing::DE::HAFAS::Connection; +use Travel::Routing::DE::HAFAS::Location; +use Travel::Status::DE::HAFAS::Message; + +our $VERSION = '0.00'; + +# {{{ Endpoint Definition + +my %hafas_instance = ( + DB => { + stopfinder => 'https://reiseauskunft.bahn.de/bin/ajax-getstop.exe', + mgate => 'https://reiseauskunft.bahn.de/bin/mgate.exe', + name => 'Deutsche Bahn', + productbits => [qw[ice ic_ec d regio s bus ferry u tram ondemand]], + salt => 'bdI8UVj4' . '0K5fvxwf', + languages => [qw[de en fr es]], + request => { + client => { + id => 'DB', + v => '20100000', + type => 'IPH', + name => 'DB Navigator', + }, + ext => 'DB.R21.12.a', + ver => '1.15', + auth => { + type => 'AID', + aid => 'n91dB8Z77' . 'MLdoR0K' + }, + }, + }, + NAHSH => { + mgate => 'https://nah.sh.hafas.de/bin/mgate.exe', + stopfinder => 'https://nah.sh.hafas.de/bin/ajax-getstop.exe', + name => 'Nahverkehrsverbund Schleswig-Holstein', + productbits => [qw[ice ice ice regio s bus ferry u tram ondemand]], + request => { + client => { + id => 'NAHSH', + v => '3000700', + type => 'IPH', + name => 'NAHSHPROD', + }, + ver => '1.16', + auth => { + type => 'AID', + aid => 'r0Ot9FLF' . 'NAFxijLW' + }, + }, + }, + NASA => { + mgate => 'https://reiseauskunft.insa.de/bin/mgate.exe', + stopfinder => 'https://reiseauskunft.insa.de/bin/ajax-getstop.exe', + name => 'Nahverkehrsservice Sachsen-Anhalt', + productbits => [qw[ice ice regio regio regio tram bus ondemand]], + languages => [qw[de en]], + request => { + client => { + id => 'NASA', + v => '4000200', + type => 'IPH', + name => 'nasaPROD', + os => 'iPhone OS 13.1.2', + }, + ver => '1.18', + auth => { + type => 'AID', + aid => 'nasa-' . 'apps', + }, + lang => 'deu', + }, + }, + NVV => { + mgate => 'https://auskunft.nvv.de/auskunft/bin/app/mgate.exe', + stopfinder => + 'https://auskunft.nvv.de/auskunft/bin/jp/ajax-getstop.exe', + name => 'Nordhessischer VerkehrsVerbund', + productbits => + [qw[ice ic_ec regio s u tram bus bus ferry ondemand regio regio]], + request => { + client => { + id => 'NVV', + v => '5000300', + type => 'IPH', + name => 'NVVMobilPROD_APPSTORE', + os => 'iOS 13.1.2', + }, + ext => 'NVV.6.0', + ver => '1.18', + auth => { + type => 'AID', + aid => 'Kt8eNOH7' . 'qjVeSxNA', + }, + lang => 'deu', + }, + }, + 'ÖBB' => { + mgate => 'https://fahrplan.oebb.at/bin/mgate.exe', + stopfinder => 'https://fahrplan.oebb.at/bin/ajax-getstop.exe', + name => 'Österreichische Bundesbahnen', + productbits => + [qw[ice ice ice regio regio s bus ferry u tram ice ondemand ice]], + request => { + client => { + id => 'OEBB', + v => '6030600', + type => 'IPH', + name => 'oebbPROD-ADHOC', + }, + ver => '1.41', + auth => { + type => 'AID', + aid => 'OWDL4fE4' . 'ixNiPBBm', + }, + lang => 'deu', + }, + }, + VBB => { + mgate => 'https://fahrinfo.vbb.de/bin/mgate.exe', + stopfinder => 'https://fahrinfo.vbb.de/bin/ajax-getstop.exe', + name => 'Verkehrsverbund Berlin-Brandenburg', + productbits => [qw[s u tram bus ferry ice regio]], + languages => [qw[de en]], + request => { + client => { + id => 'VBB', + type => 'WEB', + name => 'VBB WebApp', + l => 'vs_webapp_vbb', + }, + ext => 'VBB.1', + ver => '1.33', + auth => { + type => 'AID', + aid => 'hafas-vb' . 'b-webapp', + }, + lang => 'deu', + }, + }, + VBN => { + mgate => 'https://fahrplaner.vbn.de/bin/mgate.exe', + stopfinder => 'https://fahrplaner.vbn.de/hafas/ajax-getstop.exe', + name => 'Verkehrsverbund Bremen/Niedersachsen', + productbits => [qw[ice ice regio regio s bus ferry u tram ondemand]], + salt => 'SP31mBu' . 'fSyCLmNxp', + micmac => 1, + languages => [qw[de en]], + request => { + client => { + id => 'VBN', + v => '6000000', + type => 'IPH', + name => 'vbn', + }, + ver => '1.42', + auth => { + type => 'AID', + aid => 'kaoxIXLn' . '03zCr2KR', + }, + lang => 'deu', + }, + }, +); + +# }}} +# {{{ Constructors + +sub new { + my ( $obj, %conf ) = @_; + my $service = $conf{service}; + + my $ua = $conf{user_agent}; + + if ( not $ua ) { + my %lwp_options = %{ $conf{lwp_options} // { timeout => 10 } }; + $ua = LWP::UserAgent->new(%lwp_options); + $ua->env_proxy; + } + + if ( not( $conf{from_stop} and $conf{to_stop} ) ) { + confess('from_stop and to_stop must be specified'); + } + + if ( not defined $service ) { + $service = $conf{service} = 'DB'; + } + + if ( defined $service and not exists $hafas_instance{$service} ) { + confess("The service '$service' is not supported"); + } + + my $now = DateTime->now( time_zone => 'Europe/Berlin' ); + my $self = { + active_service => $service, + cache => $conf{cache}, + developer_mode => $conf{developer_mode}, + exclusive_mots => $conf{exclusive_mots}, + excluded_mots => $conf{excluded_mots}, + messages => [], + results => [], + from_stop => $conf{from_stop}, + to_stop => $conf{to_stop}, + ua => $ua, + now => $now, + }; + + bless( $self, $obj ); + + my $req; + + if (0) { + } + else { + my $date = ( $conf{datetime} // $now )->strftime('%Y%m%d'); + my $time = ( $conf{datetime} // $now )->strftime('%H%M%S'); + + my ( $from_lid, $to_lid ); + if ( $self->{from_stop} =~ m{ ^ [0-9]+ $ }x ) { + $from_lid = 'A=1@L=' . $self->{from_stop} . '@'; + } + else { + $from_lid = 'A=1@O=' . $self->{from_stop} . '@'; + } + if ( $self->{to_stop} =~ m{ ^ [0-9]+ $ }x ) { + $to_lid = 'A=1@L=' . $self->{to_stop} . '@'; + } + else { + $to_lid = 'A=1@O=' . $self->{to_stop} . '@'; + } + + $req = { + svcReqL => [ + { + meth => 'TripSearch', + req => { + depLocL => [ { lid => $from_lid } ], + arrLocL => [ { lid => $to_lid } ], + numF => 6, + maxChg => undef, + minChgTime => undef, + outFrwd => undef, + viaLocL => undef, + trfReq => { + cType => 'PK', + tvlrProf => [ { type => 'E' } ], + }, + outDate => $date, + outTime => $time, + jnyFltrL => [ + { + type => "PROD", + mode => "INC", + value => $self->mot_mask + } + ] + }, + }, + ], + %{ $hafas_instance{$service}{request} } + }; + } + + if ( $conf{language} ) { + $req->{lang} = $conf{language}; + } + + $self->{strptime_obj} //= DateTime::Format::Strptime->new( + pattern => '%Y%m%dT%H%M%S', + time_zone => 'Europe/Berlin', + ); + + my $json = $self->{json} = JSON->new->utf8; + + # The JSON request is the cache key, so if we have a cache we must ensure + # that JSON serialization is deterministic. + if ( $self->{cache} ) { + $json->canonical; + } + + $req = $json->encode($req); + $self->{post} = $req; + + my $url = $conf{url} // $hafas_instance{$service}{mgate}; + + if ( my $salt = $hafas_instance{$service}{salt} ) { + if ( $hafas_instance{$service}{micmac} ) { + my $mic = md5_hex( $self->{post} ); + my $mac = md5_hex( $mic . $salt ); + $url .= "?mic=$mic&mac=$mac"; + } + else { + $url .= '?checksum=' . md5_hex( $self->{post} . $salt ); + } + } + + if ( $conf{async} ) { + $self->{url} = $url; + return $self; + } + + if ( $conf{json} ) { + $self->{raw_json} = $conf{json}; + } + else { + if ( $self->{developer_mode} ) { + say "requesting $req from $url"; + } + + my ( $content, $error ) = $self->post_with_cache($url); + + if ($error) { + $self->{errstr} = $error; + return $self; + } + + if ( $self->{developer_mode} ) { + say decode( 'utf-8', $content ); + } + + $self->{raw_json} = $json->decode($content); + } + + $self->check_mgate; + $self->parse_trips; + + return $self; +} + +sub new_p { + my ( $obj, %conf ) = @_; + my $promise = $conf{promise}->new; + + if ( + not( $conf{station} + or $conf{journey} + or $conf{geoSearch} + or $conf{locationSearch} ) + ) + { + return $promise->reject('station or journey flag must be passed'); + } + + my $self = $obj->new( %conf, async => 1 ); + $self->{promise} = $conf{promise}; + + $self->post_with_cache_p( $self->{url} )->then( + sub { + my ($content) = @_; + $self->{raw_json} = $self->{json}->decode($content); + $self->check_mgate; + if ( $conf{journey} ) { + $self->parse_journey; + } + elsif ( $conf{geoSearch} or $conf{locationSearch} ) { + $self->parse_search; + } + else { + $self->parse_board; + } + if ( $self->errstr ) { + $promise->reject( $self->errstr, $self ); + } + else { + $promise->resolve($self); + } + return; + } + )->catch( + sub { + my ($err) = @_; + $promise->reject($err); + return; + } + )->wait; + + return $promise; +} + +# }}} +# {{{ Internal Helpers + +sub mot_mask { + my ($self) = @_; + + my $service = $self->{active_service}; + my $mot_mask = 2**@{ $hafas_instance{$service}{productbits} } - 1; + + my %mot_pos; + for my $i ( 0 .. $#{ $hafas_instance{$service}{productbits} } ) { + $mot_pos{ $hafas_instance{$service}{productbits}[$i] } = $i; + } + + if ( my @mots = @{ $self->{exclusive_mots} // [] } ) { + $mot_mask = 0; + for my $mot (@mots) { + $mot_mask |= 1 << $mot_pos{$mot}; + } + } + + if ( my @mots = @{ $self->{excluded_mots} // [] } ) { + for my $mot (@mots) { + $mot_mask &= ~( 1 << $mot_pos{$mot} ); + } + } + + return $mot_mask; +} + +sub post_with_cache { + my ( $self, $url ) = @_; + my $cache = $self->{cache}; + + if ( $self->{developer_mode} ) { + say "POST $url"; + } + + if ($cache) { + my $content = $cache->thaw( $self->{post} ); + if ($content) { + if ( $self->{developer_mode} ) { + say ' cache hit'; + } + return ( ${$content}, undef ); + } + } + + if ( $self->{developer_mode} ) { + say ' cache miss'; + } + + my $reply = $self->{ua}->post( + $url, + 'Content-Type' => 'application/json', + Content => $self->{post} + ); + + if ( $reply->is_error ) { + return ( undef, $reply->status_line ); + } + my $content = $reply->content; + + if ($cache) { + say "freeeez"; + $cache->freeze( $self->{post}, \$content ); + } + + return ( $content, undef ); +} + +sub post_with_cache_p { + my ( $self, $url ) = @_; + my $cache = $self->{cache}; + + if ( $self->{developer_mode} ) { + say "POST $url"; + } + + my $promise = $self->{promise}->new; + + if ($cache) { + my $content = $cache->thaw( $self->{post} ); + if ($content) { + if ( $self->{developer_mode} ) { + say ' cache hit'; + } + return $promise->resolve( ${$content} ); + } + } + + if ( $self->{developer_mode} ) { + say ' cache miss'; + } + + $self->{ua}->post_p( $url, $self->{post} )->then( + sub { + my ($tx) = @_; + if ( my $err = $tx->error ) { + $promise->reject( + "POST $url returned HTTP $err->{code} $err->{message}"); + return; + } + my $content = $tx->res->body; + if ($cache) { + $cache->freeze( $self->{post}, \$content ); + } + $promise->resolve($content); + return; + } + )->catch( + sub { + my ($err) = @_; + $promise->reject($err); + return; + } + )->wait; + + return $promise; +} + +sub check_mgate { + my ($self) = @_; + + if ( $self->{raw_json}{err} and $self->{raw_json}{err} ne 'OK' ) { + $self->{errstr} = $self->{raw_json}{errTxt} + // 'error code is ' . $self->{raw_json}{err}; + $self->{errcode} = $self->{raw_json}{err}; + } + elsif ( defined $self->{raw_json}{cInfo}{code} + and $self->{raw_json}{cInfo}{code} ne 'OK' + and $self->{raw_json}{cInfo}{code} ne 'VH' ) + { + $self->{errstr} = 'cInfo code is ' . $self->{raw_json}{cInfo}{code}; + $self->{errcode} = $self->{raw_json}{cInfo}{code}; + } + elsif ( @{ $self->{raw_json}{svcResL} // [] } == 0 ) { + $self->{errstr} = 'svcResL is empty'; + } + elsif ( $self->{raw_json}{svcResL}[0]{err} ne 'OK' ) { + $self->{errstr} + = 'svcResL[0].err is ' . $self->{raw_json}{svcResL}[0]{err}; + $self->{errcode} = $self->{raw_json}{svcResL}[0]{err}; + } + + return $self; +} + +sub parse_trips { + my ($self) = @_; + + my @locL = map { Travel::Routing::DE::HAFAS::Location->new( loc => $_ ) } + @{ $self->{raw_json}{svcResL}[0]{res}{common}{locL} // [] }; + + my @conL = @{ $self->{raw_json}{svcResL}[0]{res}{outConL} // [] }; + for my $con (@conL) { + push( + @{ $self->{results} }, + Travel::Routing::DE::HAFAS::Connection->new( + common => $self->{raw_json}{svcResL}[0]{res}{common}, + locL => \@locL, + connection => $con, + hafas => $self, + ) + ); + } +} + +sub add_message { + my ( $self, $json, $is_him ) = @_; + + my $short = $json->{txtS}; + my $text = $json->{txtN}; + my $code = $json->{code}; + my $prio = $json->{prio}; + + if ($is_him) { + $short = $json->{head}; + $text = $json->{text}; + $code = $json->{hid}; + } + + # Some backends use remL for operator information. We don't want that. + if ( $code eq 'OPERATOR' ) { + return; + } + + for my $message ( @{ $self->{messages} } ) { + if ( $code eq $message->{code} and $text eq $message->{text} ) { + $message->{ref_count}++; + return $message; + } + } + + my $message = Travel::Status::DE::HAFAS::Message->new( + short => $short, + text => $text, + code => $code, + prio => $prio, + is_him => $is_him, + ref_count => 1, + ); + push( @{ $self->{messages} }, $message ); + return $message; +} + +# }}} +# {{{ Public Functions + +sub errcode { + my ($self) = @_; + + return $self->{errcode}; +} + +sub errstr { + my ($self) = @_; + + return $self->{errstr}; +} + +sub messages { + my ($self) = @_; + return @{ $self->{messages} }; +} + +sub connections { + my ($self) = @_; + return @{ $self->{results} }; +} + +# }}} diff --git a/lib/Travel/Routing/DE/HAFAS/Connection.pm b/lib/Travel/Routing/DE/HAFAS/Connection.pm new file mode 100644 index 0000000..51e6f3e --- /dev/null +++ b/lib/Travel/Routing/DE/HAFAS/Connection.pm @@ -0,0 +1,147 @@ +package Travel::Routing::DE::HAFAS::Connection; + +# vim:foldmethod=marker + +use strict; +use warnings; +use 5.014; + +use parent 'Class::Accessor'; +use DateTime::Duration; +use Travel::Routing::DE::HAFAS::Utils; +use Travel::Routing::DE::HAFAS::Connection::Section; + +our $VERSION = '0.00'; + +Travel::Routing::DE::HAFAS::Connection->mk_ro_accessors( + qw(changes duration sched_dep rt_dep sched_arr rt_arr dep_datetime arr_datetime dep_platform arr_platform dep_loc arr_loc load) +); + +# {{{ Constructor + +sub new { + my ( $obj, %opt ) = @_; + + my $hafas = $opt{hafas}; + my $connection = $opt{connection}; + my $locs = $opt{locL}; + + # himL may only be present in departure monitor mode + my @remL = @{ $opt{common}{remL} // [] }; + my @himL = @{ $opt{common}{himL} // [] }; + + my @msgL = @{ $connection->{msgL} // [] }; + my @secL = @{ $connection->{secL} // [] }; + + my $date = $connection->{date}; + my $duration = $connection->{dur}; + + $duration = DateTime::Duration->new( + hours => substr( $duration, 0, 2 ), + minutes => substr( $duration, 2, 2 ), + seconds => substr( $duration, 4, 2 ), + ); + + my @messages; + for my $msg (@msgL) { + if ( $msg->{type} eq 'REM' and defined $msg->{remX} ) { + push( @messages, $hafas->add_message( $remL[ $msg->{remX} ] ) ); + } + elsif ( $msg->{type} eq 'HIM' and defined $msg->{himX} ) { + push( @messages, $hafas->add_message( $himL[ $msg->{himX} ], 1 ) ); + } + else { + say "Unknown message type $msg->{type}"; + } + } + + my $strptime = DateTime::Format::Strptime->new( + pattern => '%Y%m%dT%H%M%S', + time_zone => 'Europe/Berlin' + ); + + my $sched_dep = $connection->{dep}{dTimeS}; + my $rt_dep = $connection->{dep}{dTimeR}; + my $sched_arr = $connection->{arr}{aTimeS}; + my $rt_arr = $connection->{arr}{aTimeR}; + + for my $ts ( $sched_dep, $rt_dep, $sched_arr, $rt_arr ) { + if ($ts) { + $ts = handle_day_change( + date => $date, + time => $ts, + strp_obj => $strptime, + ); + } + } + + my @sections; + for my $sec (@secL) { + push( + @sections, + Travel::Routing::DE::HAFAS::Connection::Section->new( + common => $opt{common}, + date => $date, + locL => $locs, + sec => $sec, + hafas => $hafas, + ) + ); + } + + my $tco = {}; + for my $tco_id ( @{ $connection->{dTrnCmpSX}{tcocX} // [] } ) { + my $tco_kv = $opt{common}{tcocL}[$tco_id]; + $tco->{ $tco_kv->{c} } = $tco_kv->{r}; + } + + my $ref = { + duration => $duration, + changes => $connection->{chg}, + sched_dep => $sched_dep, + rt_dep => $rt_dep, + sched_arr => $sched_arr, + rt_arr => $rt_arr, + dep_datetime => $rt_dep // $sched_dep, + arr_datetime => $rt_arr // $sched_arr, + dep_platform => $connection->{dep}{dPlatfR} + // $connection->{dep}{dPlatfS}, + arr_platform => $connection->{arr}{aPlatfR} + // $connection->{arr}{aPlatfS}, + dep_loc => $locs->[ $connection->{dep}{locX} ], + arr_loc => $locs->[ $connection->{arr}{locX} ], + load => $tco, + messages => \@messages, + sections => \@sections, + }; + + bless( $ref, $obj ); + + return $ref; +} + +# }}} + +# {{{ Accessors + +sub messages { + my ($self) = @_; + + if ( $self->{messages} ) { + return @{ $self->{messages} }; + } + return; +} + +sub sections { + my ($self) = @_; + + if ( $self->{sections} ) { + return @{ $self->{sections} }; + } + return; +} + +# }}} + +1; diff --git a/lib/Travel/Routing/DE/HAFAS/Connection/Section.pm b/lib/Travel/Routing/DE/HAFAS/Connection/Section.pm new file mode 100644 index 0000000..6b85f1a --- /dev/null +++ b/lib/Travel/Routing/DE/HAFAS/Connection/Section.pm @@ -0,0 +1,115 @@ +package Travel::Routing::DE::HAFAS::Connection::Section; + +# vim:foldmethod=marker + +use strict; +use warnings; +use 5.014; + +use parent 'Class::Accessor'; +use DateTime::Duration; +use Travel::Routing::DE::HAFAS::Utils; + +our $VERSION = '0.00'; + +Travel::Routing::DE::HAFAS::Connection::Section->mk_ro_accessors( + qw(type schep_dep rt_dep sched_arr rt_arr dep_datetime arr_datetime arr_delay dep_delay journey distance duration dep_loc arr_loc + operator id name category category_long class number line line_no load delay direction) +); + +# {{{ Constructor + +sub new { + my ( $obj, %opt ) = @_; + + my $hafas = $opt{hafas}; + my $sec = $opt{sec}; + my $date = $opt{date}; + my $locs = $opt{locL}; + my @prodL = @{ $opt{common}{prodL} // [] }; + + my $strptime = DateTime::Format::Strptime->new( + pattern => '%Y%m%dT%H%M%S', + time_zone => 'Europe/Berlin' + ); + + my $sched_dep = $sec->{dep}{dTimeS}; + my $rt_dep = $sec->{dep}{dTimeR}; + my $sched_arr = $sec->{arr}{aTimeS}; + my $rt_arr = $sec->{arr}{aTimeR}; + + for my $ts ( $sched_dep, $rt_dep, $sched_arr, $rt_arr ) { + if ($ts) { + $ts = handle_day_change( + date => $date, + time => $ts, + strp_obj => $strptime, + ); + } + } + + my $ref = { + type => $sec->{type}, + sched_dep => $sched_dep, + rt_dep => $rt_dep, + sched_arr => $sched_arr, + rt_arr => $rt_arr, + dep_datetime => $rt_dep // $sched_dep, + arr_datetime => $rt_arr // $sched_arr, + dep_loc => $locs->[ $sec->{dep}{locX} ], + arr_loc => $locs->[ $sec->{arr}{locX} ], + }; + + if ( $sched_dep and $rt_dep ) { + $ref->{dep_delay} = ( $rt_dep->epoch - $sched_dep->epoch ) / 60; + } + + if ( $sched_arr and $rt_arr ) { + $ref->{arr_delay} = ( $rt_arr->epoch - $sched_arr->epoch ) / 60; + } + + if ( $sec->{type} eq 'JNY' ) { + + #operator id name type type_long class number line line_no load delay direction) + my $journey = $sec->{jny}; + my $product = $prodL[ $journey->{prodX} ]; + $ref->{id} = $journey->{jid}; + $ref->{direction} = $journey->{dirTxt}; + $ref->{name} = $product->{addName} // $product->{name}; + $ref->{category} = $product->{prodCtx}{catOut}; + $ref->{category_long} = $product->{prodCtx}{catOutL}; + $ref->{class} = $product->{cls}; + $ref->{number} = $product->{prodCtx}{num}; + $ref->{line} = $ref->{name}; + $ref->{line_no} = $product->{prodCtx}{line}; + + if ( $ref->{name} + and $ref->{category} + and $ref->{name} eq $ref->{category} + and $product->{nameS} ) + { + $ref->{name} .= ' ' . $product->{nameS}; + } + } + elsif ( $sec->{type} eq 'WALK' ) { + $ref->{distance} = $sec->{gis}{dist}; + my $duration = $sec->{gis}{durS}; + $ref->{duration} = DateTime::Duration->new( + hours => substr( $duration, 0, 2 ), + minutes => substr( $duration, 2, 2 ), + seconds => substr( $duration, 4, 2 ), + ); + } + + bless( $ref, $obj ); + + return $ref; +} + +# }}} + +# {{{ Accessors + +# }}} + +1; diff --git a/lib/Travel/Routing/DE/HAFAS/Location.pm b/lib/Travel/Routing/DE/HAFAS/Location.pm new file mode 100644 index 0000000..170522c --- /dev/null +++ b/lib/Travel/Routing/DE/HAFAS/Location.pm @@ -0,0 +1,33 @@ +package Travel::Routing::DE::HAFAS::Location; + +use strict; +use warnings; +use 5.014; + +use parent 'Class::Accessor'; + +our $VERSION = '0.00'; + +Travel::Routing::DE::HAFAS::Location->mk_ro_accessors( + qw(lid type name eva state coordinate)); + +sub new { + my ( $obj, %opt ) = @_; + + my $loc = $opt{loc}; + + my $ref = { + lid => $loc->{lid}, + type => $loc->{type}, + name => $loc->{name}, + eva => 0 + $loc->{extId}, + state => $loc->{state}, + coordinate => $loc->{crd} + }; + + bless( $ref, $obj ); + + return $ref; +} + +1; diff --git a/lib/Travel/Routing/DE/HAFAS/Utils.pm b/lib/Travel/Routing/DE/HAFAS/Utils.pm new file mode 100644 index 0000000..4b5bdb7 --- /dev/null +++ b/lib/Travel/Routing/DE/HAFAS/Utils.pm @@ -0,0 +1,32 @@ +package Travel::Routing::DE::HAFAS::Utils; + +# vim:foldmethod=marker + +use strict; +use warnings; +use 5.014; + +use parent 'Exporter'; +our @EXPORT = qw(handle_day_change); + +sub handle_day_change { + my (%opt) = @_; + my $datestr = $opt{date}; + my $timestr = $opt{time}; + my $offset_days = 0; + + # timestr may include a day offset, resulting in DDHHMMSS + if ( length($timestr) == 8 ) { + $offset_days = substr( $timestr, 0, 2, q{} ); + } + + my $ts = $opt{strp_obj}->parse_datetime("${datestr}T${timestr}"); + + if ($offset_days) { + $ts->add( days => $offset_days ); + } + + return $ts; +} + +1; |