path: root/bin/hafas

#!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;
use Travel::Status::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 $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 ( $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( "%s → %s\n", $sec->name, $sec->direction );
			printf(
				"%-5s %-${have_delay}s ab  %s\n",
				$sec->dep_datetime->strftime('%H:%M'),
				format_delay( $sec->dep_delay ),
				$sec->dep_loc->name
			);
			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( "# Walk %dm  (approx. %d minutes)\n",
				$sec->distance, $sec->duration->in_units('minutes') );
		}
		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.