path: root/bin/dbris

#!perl
use strict;
use warnings;
use 5.020;

our $VERSION = '0.02';

use utf8;
use DateTime;
use Encode qw(decode);
use JSON;
use Getopt::Long qw(:config no_ignore_case);
use List::Util   qw(max);
use Travel::Status::DE::DBRIS;
use Travel::Routing::DE::DBRIS;

my ( $date, $time, $from, $to, $language );
my $mots;
my ( $first_class, $passengers );
my $developer_mode;
my $show_jid;
my ( $json_output, $raw_json_output );
my $verbose;
my $use_cache = 1;
my $show_full_route;
my $cache;

my %known_mot = map { $_ => 1 }
  (qw(ICE EC_IC IR REGIONAL SBAHN BUS SCHIFF UBAHN TRAM ANRUFPFLICHTIG));

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{};

my $output_fyi      = -t STDOUT ? "\033[40;36m" : q{};
my $output_unknown  = -t STDOUT ? "\033[40;35m" : q{};
my $output_good     = -t STDOUT ? "\033[40;32m" : q{};
my $output_warning  = -t STDOUT ? "\033[40;33m" : q{};
my $output_critical = -t STDOUT ? "\033[40;31m" : q{};

my $output_bold_fyi      = -t STDOUT ? "\033[1;40;36m" : q{};
my $output_bold_unknown  = -t STDOUT ? "\033[1;40;35m" : q{};
my $output_bold_good     = -t STDOUT ? "\033[1;40;32m" : q{};
my $output_bold_warning  = -t STDOUT ? "\033[1;40;33m" : q{};
my $output_bold_critical = -t STDOUT ? "\033[1;40;31m" : q{};

GetOptions(
	'd|date=s'             => \$date,
	'h|help'               => sub { show_help(0) },
	'f|full-route'         => \$show_full_route,
	'first-class!'         => \$first_class,
	'j|with-jid'           => \$show_jid,
	'm|modes-of-transit=s' => \$mots,
	'l|language=s'         => \$language,
	'p|passengers=s'       => \$passengers,
	't|time=s'             => \$time,
	'v|verbose'            => \$verbose,
	'V|version'            => \&show_version,
	'cache!'               => \$use_cache,
	'devmode'              => \$developer_mode,
	'json'                 => \$json_output,
	'raw-json'             => \$raw_json_output,

) or show_help(1);

if ($use_cache) {
	my $cache_path = ( $ENV{XDG_CACHE_HOME} // "$ENV{HOME}/.cache" )
	  . '/Travel-Routing-DE-DBRIS';
	eval {
		require Cache::File;
		$cache = Cache::File->new(
			cache_root      => $cache_path,
			default_expires => '90 seconds',
			lock_level      => Cache::File::LOCK_LOCAL(),
		);
	};
	if ($@) {
		$cache = undef;
	}
}

my ( $from_raw, @via_raw, $to_raw );
if ( @ARGV < 2 ) {
	show_help(1);
}
elsif ( @ARGV == 2 ) {
	( $from_raw, $to_raw ) = @ARGV;
}
elsif ( @ARGV <= 4 ) {
	( $from_raw, @via_raw ) = @ARGV;
	$to_raw = pop(@via_raw);
}

sub get_stop {
	my ( $stop, $is_via ) = @_;
	my $stopover_duration;

	if ( $is_via and $stop =~ s{ : (?<duration> \d+ ) $ }{}x ) {
		$stopover_duration = $+{duration};
	}

	my $ris = Travel::Status::DE::DBRIS->new(
		cache          => $cache,
		locationSearch => $stop,
		developer_mode => $developer_mode,
	);
	if ( my $err = $ris->errstr ) {
		say STDERR "Request error while looking up '${stop}': ${err}";
		exit 2;
	}
	my $found;
	for my $result ( $ris->results ) {
		if ( defined $result->eva ) {
			if ($is_via) {
				return {
					stop     => $result,
					duration => $stopover_duration,
				};
			}
			return $result;
		}
	}
	say "Could not find stop '${stop}'";
	exit 1;
}

my %opt = (
	from           => get_stop( $from_raw, 0 ),
	to             => get_stop( $to_raw,   0 ),
	via            => [ map { get_stop( $_, 1 ) } @via_raw ],
	language       => $language,
	first_class    => $first_class,
	cache          => $cache,
	developer_mode => $developer_mode,
);

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;
}

if ( $mots and $mots eq 'help' ) {
	say "Supported modes of transmit (-m / --modes-of-transit):";
	for my $mot ( sort keys %known_mot ) {
		say $mot;
	}
	exit 0;
}

if ($mots) {

	# Passing unknown MOTs to the backend results in HTTP 422 Unprocessable Entity
	my @mots = split( qr{, *}, $mots );
	my $found_unknown;
	for my $mot (@mots) {
		if ( not $known_mot{$mot} ) {
			$found_unknown = 1;
			say STDERR
"-m / --modes-of-transit: skipping unknown mode of transit '$mot'";
		}
	}
	if ($found_unknown) {
		say STDERR 'supported modes of transit are: '
		  . join( q{, }, sort keys %known_mot );
	}
	$opt{modes_of_transit} = [ grep { $known_mot{$_} } @mots ];
}

if ($passengers) {
	for my $passenger ( split( qr{; *}, $passengers ) ) {
		my ( $type, $discounts ) = split( qr{ *: *}, $passenger );
		$discounts = $discounts ? [ split( qr{, *}, $discounts ) ] : [];
		push(
			@{ $opt{passengers} },
			{
				type      => $type,
				discounts => $discounts,
			}
		);
	}
}

sub show_help {
	my ($code) = @_;

	print "Usage: dbris [-d dd.mm.yyyy] [-t hh:mm] <from> <to>\n"
	  . "See also: man dbris-m\n";

	exit $code;
}

sub show_version {
	say "dbris version ${VERSION}";

	exit 0;
}

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

	if ( not $occupancy ) {
		return q{ };
	}
	if ( $occupancy == 1 ) {
		return q{.};
	}
	if ( $occupancy == 2 ) {
		return q{o};
	}
	if ( $occupancy == 3 ) {
		return q{*};
	}
	if ( $occupancy == 4 or $occupancy == 99 ) {
		return q{!};
	}
	return q{?};
}

sub format_occupancy {
	my ($stop) = @_;

	return display_occupancy( $stop->occupancy_first )
	  . display_occupancy( $stop->occupancy_second );
}

sub format_delay {
	my ( $delay, $len ) = @_;
	$len += 1;
	if ( $delay and $len ) {
		return sprintf( "(%+${len}d)", $delay );
	}
	elsif ($len) {
		return q{ } x ( $len + 2 );
	}
	return q{};
}

my $ris = Travel::Routing::DE::DBRIS->new(%opt);

if ( my $err = $ris->errstr ) {
	say STDERR "Request error: ${err}";
	exit 2;
}

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

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

for my $connection ( $ris->connections ) {

	my $header = q{};
	my $format = $output_bold;

	if ( $connection->is_unlikely ) {
		if ( $connection->feasibility >= 4 ) {
			$header .= "  ${output_critical}XX${output_reset}";
			$format = $output_bold_critical;
		}
		else {
			$header .= "  ${output_warning}X?${output_reset}";
			$format = $output_bold_warning;
		}
	}
	if ( $connection->is_cancelled ) {
		$format = $output_bold_critical;
	}

	if ( defined $passengers and defined $connection->price ) {
		$header .= sprintf( '  %.2f %s', $connection->price,
			$connection->price_unit );
	}

	for my $segment ( $connection->segments ) {
		if ( defined $segment->transfer_duration ) {
			if ( $segment->transfer_duration->in_units('minutes') >= 0 ) {
				$header .= sprintf( '  (%01d:%02d)',
					$segment->transfer_duration->in_units( 'hours', 'minutes' )
				);
			}
			else {
				$header .= sprintf( "  ${output_critical}(%02d)${output_reset}",
					$segment->transfer_duration->in_units('minutes') );
			}
		}
		if ( $segment->train_short ) {
			$header .= sprintf( '  %s', $segment->train_short );
		}
		elsif ( $segment->is_transfer ) {
			$header .= sprintf( '  %.1fkm', $segment->distance_m / 1e3 );
		}
		elsif ( $segment->is_walk ) {

			# not shown in header
		}
		else {
			$header .= q{  ??};
		}
	}

	my $max_delay_digits = max
	  map { length( $_->dep_delay || q{} ), length( $_->arr_delay || q{} ) }
	  $connection->segments;
	if ($show_full_route) {
		my $max_route_delay_digits = max map {
			map { length( $_->arr_delay || q{} ) }
			  $_->route
		} $connection->segments;
		if ( $max_route_delay_digits > $max_delay_digits ) {
			$max_delay_digits = $max_route_delay_digits;
		}
	}

	say q{};
	printf(
		"%s %s%s%s  (%02d:%02d)  %s%s%s  %s%s\n",
		$connection->dep ? $connection->dep->strftime('%d.%m.')
		: q{??.??.},
		$format,
		$connection->dep ? $connection->dep->strftime('%H:%M')
		: q{??:??},
		$output_reset,
		$connection->duration->in_units( 'hours', 'minutes' ),
		$format,
		$connection->arr ? $connection->arr->strftime('%H:%M') : q{??:??},
		$output_reset,
		$connection->is_cancelled ? "${output_critical}XX${output_reset}"
		: format_occupancy($connection),
		$header,
	);

	if ($verbose) {
		for my $note ( $connection->notes ) {
			printf( "| %s (%s)\n", $note->{value}, $note->{key} );
		}

		for my $msg ( $connection->messages ) {
			printf( "| %s\n", $msg->{text} );
		}
	}

	say q{};

	for my $segment ( $connection->segments ) {
		if ( $segment->is_transfer ) {
			for my $note ( $segment->transfer_notes ) {
				say $note;
			}
		}
		elsif ( $segment->is_walk ) {
			if ( $segment->distance_m ) {
				printf( "${output_bold}%s${output_reset} %dm  (≈ %d min.)\n",
					$segment->walk_name, $segment->distance_m,
					$segment->duration->in_units('minutes') );
			}
			elsif ( $segment->duration->in_units('minutes') ) {
				printf( "${output_bold}%s${output_reset} ≈ %d min.\n",
					$segment->walk_name,
					$segment->duration->in_units('minutes') );
			}
			else {
				printf( "${output_bold}%s${output_reset}\n",
					$segment->walk_name );
			}
			next;
		}
		elsif ( $segment->direction ) {
			printf( "${output_bold}%s${output_reset} → %s  %s\n",
				$segment->train_mid, $segment->direction,
				format_occupancy($segment) );
		}
		else {
			printf( "${output_bold}%s${output_reset}\n", $segment->train_long );
		}

		printf(
			"%s%s  ab  %s%s\n",
			$segment->dep->strftime('%H:%M'),
			$max_delay_digits
			? q{ } . format_delay( $segment->dep_delay, $max_delay_digits )
			: q{},
			$segment->dep_name,
			$segment->dep_platform ? q{  } . $segment->dep_platform : q{},
		);

		if ($show_full_route) {
			for my $stop ( $segment->route ) {
				printf(
					"%s%s  %s  %s%s\n",
					$stop->arr ? $stop->arr->strftime('%H:%M') : q{     },
					$max_delay_digits
					? q{ } . format_delay( $stop->arr_delay, $max_delay_digits )
					: q{},
					format_occupancy($stop),
					$stop->name,
					$stop->platform ? q{  } . $stop->platform : q{},
				);
			}
		}

		printf(
			"%s%s%s%s  an  %s%s\n",
			$segment->is_unlikely ? $output_critical : q{},
			$segment->arr->strftime('%H:%M'),
			$segment->is_unlikely ? $output_reset : q{},
			$max_delay_digits
			? q{ } . format_delay( $segment->arr_delay, $max_delay_digits )
			: q{},
			$segment->arr_name,
			$segment->arr_platform ? q{  } . $segment->arr_platform : q{},
		);

		if ($show_jid) {
			say $segment->journey_id =~ s{ }{}gr;
		}

		if ($verbose) {
			for my $msg ( $segment->messages_ris ) {
				printf( "| %s (%s)\n", $msg->{value}, $msg->{key} );
			}
			for my $msg ( $segment->messages_him ) {
				printf( "| %s\n", $msg->{text} );
			}
			for my $msg ( $segment->messages_prio ) {
				printf( "| %s\n", $msg->{text} );
			}
		}

		say q{};
	}
	say q{---------------------------------------};
}

__END__

=head1 NAME

dbris - Interface to bahn.de public transit routing service

=head1 SYNOPSIS

B<dbris> [B<-d> I<DD.MM.YYYY>] [B<-t> I<HH:MM>] [...] I<from-stop>
[I<via-stop>[:I<duration>] [I<via-stop>[:I<duration>]]] I<to-stop>

=head1 VERSION

version 0.02

=head1 DESCRIPTION

B<dbris> is an interface to the public transport routing service available on
bahn.de. It requests connections between I<from-stop> and I<to-stop> and prints
the result. If one or two I<via-stop>s are specified, it only returns matching
connections, with an optional minimum stopover I<duration> given in minutes.

=head1 OPTIONS

=over

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

Request connections for a specific day.
Default: today.

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

Show intermediate stops rather than just start/end of connection legs.

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

Show JourneyID for each connection segment.
The JourneyID can be passed to dbris-m(1) to obtain details about the segment.

=item B<--json>

Print result(s) as JSON and exit. This is a dump of internal data structures
and not guaranteed to remain stable between minor versions. Please use the
Travel::Routing::DE::DBRIS(3pm) module if you need a proper API.

=item B<-l>, B<--language> I<lang>

Tell bahn.de to provide messages in I<lang> (ISO 639-1 language code).
Known supported languages are: cs da de en es fr it nl pl.
Default: de.

=item B<-m>, B<--modes-of-transit> I<mot1>[,I<mot2>,...]

Only show connections with the specified modes of transit.
Supported modes of transit are:
ICE, EC_IC, IR, REGIONAL, SBAHN, BUS, SCHIFF, UBAHN, TRAM, ANRUFPFLICHTIG.
Default: all modes.

=item B<--no-cache>

By default, if the Cache::File module is available, server replies are cached
for 90 seconds in F<~/.cache/Travel-Routing-DE-DBRIS> (or a path relative to
C<$XDG_CACHE_HOME>, if set). Use this option to disable caching. You can use
B<--cache> to re-enable it.

=item B<--raw-json>

Print unprocessed API response as JSON and exit.
Useful for debugging and development purposes.

=item B<-t>, B<--time> I<HH:MM>

Request connections on or after I<HH:MM>.
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 * DateTime(3pm)

=item * LWP::UserAgent(3pm)

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

=item * Travel::Status::DE::DBRIS(3pm)

=back

=head1 BUGS AND LIMITATIONS

=over

=item * This module is very much work-in-progress

=back

=head1 AUTHOR

Copyright (C) 2025 Birte Kristina Friesel E<lt>derf@finalrewind.orgE<gt>

=head1 LICENSE

This program is licensed under the same terms as Perl itself.