initial commit (fd1ff5ad) · Commits · derf / Travel-Routing-DE-HAFAS

.gitignore

0 → 100644

+6 −0

Original line number	Diff line number	Diff line
		/_build
		/Build
		/blib
		/cover_db
		/MANIFEST*
		/MYMETA.*

bin/hafas

0 → 100755

+357 −0

Original line number	Diff line number	Diff line
		#!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.

lib/Travel/Routing/DE/HAFAS.pm

0 → 100644

+626 −0

Original line number	Diff line number	Diff line
		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} };
		}

		# }}}

lib/Travel/Routing/DE/HAFAS/Connection.pm

0 → 100644

+0 −0

File added.

Preview size limit exceeded, changes collapsed.

lib/Travel/Routing/DE/HAFAS/Connection/Section.pm

0 → 100644

+115 −0

Original line number	Diff line number	Diff line
		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;

Admin message