hafas

#!perl
use strict;
use warnings;
use 5.014;

our $VERSION = '0.08';

use utf8;
use DateTime;
use Encode qw(decode);
use JSON;
use Getopt::Long    qw(:config no_ignore_case bundling);
use List::MoreUtils qw(uniq);
use List::Util      qw(first max);
use Travel::Routing::DE::HAFAS;
use Travel::Status::DE::HAFAS;

my ( $date, $time, $arrival, $language );
my $types = q{};
my $developer_mode;
my ( $json_output, $raw_json_output );
my $show_full_route;
my $show_jid;
my $exclude_infeasible;
my ( $list_services, $service );
my ( @excluded_mots, @exclusive_mots );
my $max_change      = undef;
my $min_change_time = undef;
my $verbosity       = 0;

my @output;
my %min_verbosity = (
	A => 3,
	C => 0,
	G => 2,
	H => 1,
	L => 0,
	M => 1,
	P => 0,
);

binmode( STDOUT, ':encoding(utf-8)' );
for my $arg (@ARGV) {
	$arg = decode( 'UTF-8', $arg );
}

my $output_bold  = -t STDOUT ? "\033[1m" : q{};
my $output_reset = -t STDOUT ? "\033[0m" : q{};

GetOptions(
	'a|arrive=s'           => sub { $arrival = 1; $time = $_[1] },
	'c|max-change=s'       => \$max_change,
	'C|change-time=s'      => \$min_change_time,
	'd|date=s'             => \$date,
	'f|full-route'         => \$show_full_route,
	'h|help'               => sub { show_help(0) },
	'j|with-jid'           => \$show_jid,
	'l|language=s'         => \$language,
	'm|mot=s'              => \$types,
	's|service=s'          => \$service,
	't|time|depart=s'      => \$time,
	'x|exclude-infeasible' => \$exclude_infeasible,
	'v|verbose+'           => \$verbosity,
	'V|version'            => \&show_version,
	'devmode'              => \$developer_mode,
	'json'                 => \$json_output,
	'raw-json'             => \$raw_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, @via_stops ) = @ARGV;
my $to_stop = pop @via_stops;

if ( not( $from_stop and $to_stop ) ) {
	show_help(1);
}

my %opt = (
	service         => $service,
	from_stop       => $from_stop,
	via_stops       => \@via_stops,
	to_stop         => $to_stop,
	excluded_mots   => \@excluded_mots,
	exclusive_mots  => \@exclusive_mots,
	max_change      => $max_change,
	min_change_time => $min_change_time,
	developer_mode  => $developer_mode,
	arrival         => $arrival,
	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::Routing::DE::HAFAS::get_service($service);
			if ($desc) {
				my @mots = @{ $desc->{productbits} };
				for my $mot ( @{ $desc->{productbits} } ) {
					if ( ref($mot) eq 'ARRAY' ) {
						if ( $mot->[0] ne '_' ) {
							printf( "%-10s %s\n", @{$mot} );
						}
					}
					else {
						say $mot;
					}
				}
				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 $hafas_from = Travel::Status::DE::HAFAS->new(
		service        => $service,
		language       => $language,
		developer_mode => $developer_mode,
		locationSearch => $from_stop,
	);
	my $hafas_to = Travel::Status::DE::HAFAS->new(
		service        => $service,
		language       => $language,
		developer_mode => $developer_mode,
		locationSearch => $to_stop,
	);

	if (    $hafas_from->results
		and ( $hafas_from->results )[0]->eva ne $from_stop
		and ( $hafas_from->results )[0]->name ne $from_stop )
	{
		say q{};
		say 'You might want to try one of the following departure stops:';
		for my $result ( $hafas_from->results ) {
			printf( "%8d  %s\n", $result->eva, $result->name );
		}
	}

	if (    $hafas_to->results
		and ( $hafas_to->results )[0]->eva ne $to_stop
		and ( $hafas_to->results )[0]->name ne $to_stop )
	{
		say q{};
		say 'You might want to try one of the following arrival stops:';
		for my $result ( $hafas_to->results ) {
			printf( "%8d  %s\n", $result->eva, $result->name );
		}
	}
}

sub display_occupancy {
	my ($occupancy) = @_;

	if ( not defined $occupancy ) {
		return q{?};
	}
	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, $len ) = @_;
	if ( $delay and $len ) {
		return sprintf( "(%+${len}d)", $delay );
	}
	return q{};
}

sub show_message {
	my ($msg) = @_;
	if (
		$msg->text
		and ( not $msg->type
			or $verbosity >= ( $min_verbosity{ $msg->type } // 0 ) )
	  )
	{
		if ( $msg->short ) {
			printf( "| %s\n", $msg->short );
		}
		printf( "| %s\n", $msg->text );
		return 1;
	}
	return;
}

if ( my $err = $hafas->errstr ) {
	say STDERR "Request error: ${err}";
	if ( $hafas->errcode ) {
		if ( $hafas->errcode eq 'H730' or $hafas->errcode eq 'LOCATION' ) {
			show_similar_stops();
		}
		elsif ( $hafas->errcode eq 'H890' ) {
			say q{};
			say 'HAFAS was unable to find suitable connections.';
			say
'Maybe your mode of transport (-m) or change (-c / -C) filters are too restrictive?';
		}
		elsif ( $hafas->errcode eq 'H9380' ) {
			say q{};
			say 'Arrival / departure / intermediate stops must not overlap.';
		}
	}
	exit 2;
}

if ($raw_json_output) {
	say JSON->new->convert_blessed->encode( $hafas->{raw_json} );
	exit 0;
}

if ($json_output) {
	say JSON->new->convert_blessed->encode( [ $hafas->connections ] );
	exit 0;
}

for my $res ( $hafas->connections ) {

	my $cancelled;
	for my $msg ( $res->messages ) {
		if ( $msg->type eq 'C' and $msg->text =~ m{Fahrt fällt aus} ) {
			$cancelled = 1;
		}
	}

	my $negative_transfer;
	my $part_cancelled;

	my $glance = q{};
	for my $sec ( $res->sections ) {
		if ( $sec->type ne 'JNY' ) {
			next;
		}
		if ( $sec->dep_cancelled or $sec->arr_cancelled ) {
			$part_cancelled = 1;
		}
		if ( defined $sec->transfer_duration ) {
			if ( $sec->transfer_duration->in_units('minutes') >= 0 ) {
				$glance .= sprintf(
					'  (%01d:%02d)  %s',
					$sec->transfer_duration->in_units( 'hours', 'minutes' ),
					$sec->journey->name
				);
			}
			else {
				$negative_transfer = 1;
				$glance .= sprintf( '  (--:--)  %s', $sec->journey->name );
			}
		}
		else {
			$glance .= $sec->journey->name;
		}
	}

	if ( $cancelled or $negative_transfer or $part_cancelled ) {
		if ($exclude_infeasible) {
			next;
		}
		printf(
			"%s  (%02d:%02d)  %s  %s  %s\n",
			$res->dep->strftime('XX.XX. %H:%M'),
			$res->duration->in_units( 'hours', 'minutes' ),
			$res->arr->strftime('%H:%M'),
			display_occupancies( $res->load ),
			$glance
		);
	}
	else {
		printf(
			"%s  (%02d:%02d)  %s  %s  %s\n",
			$res->dep->strftime('%d.%m. %H:%M'),
			$res->duration->in_units( 'hours', 'minutes' ),
			$res->arr->strftime('%H:%M'),
			display_occupancies( $res->load ),
			$glance
		);
	}

	for my $msg ( $res->messages ) {
		show_message($msg);
	}
	say q{};

	my $delay_len = 0;
	my $delay_fmt = 0;
	for my $sec ( $res->sections ) {
		if ( $sec->dep_delay ) {
			$delay_len = max( $delay_len, length( $sec->dep_delay ) + 1 );
		}
		if ( $sec->arr_delay ) {
			$delay_len = max( $delay_len, length( $sec->arr_delay ) + 1 );
		}
	}
	if ($delay_len) {
		$delay_fmt = $delay_len + 2;
	}

	for my $sec ( $res->sections ) {
		if ( $sec->type eq 'JNY' ) {
			printf(
				"${output_bold}%s${output_reset} → %s  %s\n",
				$sec->journey->name,
				$sec->journey->direction,
				$show_full_route ? q{} : display_occupancies( $sec->load ),
			);
			if ($show_full_route) {
				for my $stop ( $sec->journey->route ) {
					printf(
						"%-5s %-${delay_fmt}s %s  %s%s%s\n",
						$stop->arr ? $stop->arr->strftime('%H:%M') : q{},
						format_delay( $stop->arr_delay, $delay_len ),
						display_occupancies( $stop->load ),
						$stop->loc->name,
						$stop->platform ? q{: } : q{},
						$stop->platform // q{},
					);
				}
			}
			else {
				printf(
					"%-5s %-${delay_fmt}s ab  %s%s%s\n",
					$sec->dep_cancelled
					? '--:--'
					: $sec->dep->strftime('%H:%M'),
					format_delay( $sec->dep_delay, $delay_len ),
					$sec->dep_loc->name,
					$sec->dep_platform ? q{: } : q{},
					$sec->dep_platform // q{},
				);
				printf(
					"%-5s %-${delay_fmt}s an  %s%s%s\n",
					$sec->arr_cancelled
					? '--:--'
					: $sec->arr->strftime('%H:%M'),
					format_delay( $sec->arr_delay, $delay_len ),
					$sec->arr_loc->name,
					$sec->arr_platform ? q{: } : q{},
					$sec->arr_platform // q{},
				);
			}
			if ($show_jid) {
				say $sec->journey->id;
			}
		}
		elsif ( $sec->type eq 'WALK' ) {
			printf(
				"${output_bold}Walk %dm${output_reset}  (approx. %d minute%s)",
				$sec->distance,
				$sec->duration->in_units('minutes'),
				$sec->duration->in_units('minutes') == 1 ? q{} : 's'
			);
		}
		elsif ( $sec->type eq 'TRSF' ) {
			printf(
"${output_bold}Transfer %.1fkm${output_reset} with local transit  (approx. %d minute%s)",
				$sec->distance / 1000,
				$sec->duration->in_units('minutes'),
				$sec->duration->in_units('minutes') == 1 ? q{} : 's'
			);
		}
		else {
			printf("\n???\n");
		}
		for my $msg ( $sec->messages ) {
			if (
				$msg->code
				and ( $msg->code eq
					'text.connection.section.arrival.date.deviation'
					or $msg->code eq
					'text.connection.section.departure.date.deviation' )
			  )
			{
				next;
			}
			show_message($msg);
		}
		say q{};
	}
	printf( "\n%s\n\n", q{-} x 40 );
}

__END__

=head1 NAME

hafas - Interface to HAFAS (e.g. Deutsche Bahn) itinerary services

=head1 SYNOPSIS

B<hafas> [B<-d> I<date>] [B<-t> I<time>] [B<-m> I<motlist>]
[B<-s> I<service>] [B<-l> I<language>] [B<-v>] I<from> [I<via> ...] I<to>

=head1 VERSION

version 0.08

=head1 DESCRIPTION

B<hafas> is a command line client for HAFAS-based public transit itinerary
services, e.g. the one operated by Deutsche Bahn. It requests connections
between two stops and prints the results.

=head1 OPTIONS

=over

=item B<-a>, B<--arriva> I<hh>:I<mm>

Request connections that arrive at the destination before I<hh>:I<mm>.
Overrides B<--time> / B<--depart>.

=item B<-c>, B<--max-change> I<count>

Request connections with no more than I<count> changeovers.

=item B<-C>, B<--change-time> I<minutes>

Request connections with scheduled changeover durations of at least I<minutes>.
Note that this does not account for real-time data: the backend may return
delayed connections that violate the specified changeover duration.

=item B<-d>, B<--date> I<dd>.I<mm>.[I<yyyy>]

Planned departure (or arrival) date.  Default: today.

=item B<-f>, B<--full-route>

Show intermediate stops of each connection.

=item B<-j>, B<--with-jid>

Show journey IDs. These can be used to obtain details on individual journeys
via B<hafas-m>.

=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>, B<--depart> I<hh>:I<mm>

Request connections that depart from the origin after I<hh>:I<mm>.
Default: now.

=item B<-v>, B<--verbose>

Show more HAFAS messages, e.g. related to construction sites or Wi-Fi
availability. Repeating B<-v> increases the verbosity.  The level, and thus
number of different message types that B<hafas> displays, ranges from 0 (no
B<-v>) to 3 (B<-vvv>).

=item B<-V>, B<--version>

Show version information and exit.

=item B<-x>, B<--exclude-infeasible>

HAFAS responses include journeys that are infeasible e.g. due to delayed or
cancelled trips. By default, B<hafas> displays those with an XX.XX. departure
date. When this option is set, B<hafas> silently ignores them instead.

=back

=head1 EXIT STATUS

0 upon success, 1 upon internal error, 2 upon backend error.

=head1 CONFIGURATION

None.

=head1 DEPENDENCIES

=over

=item * DateTime(3pm)

=item * Encode(3pm)

=item * JSON(3pm)

=item * List::MoreUtils(3pm)

=item * Travel::Routing::DE::HAFAS(3pm)

=item * Travel::Status::DE::HAFAS(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.