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

our $VERSION = '0.07';

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, $arrival, $from, $to, $language );
my $mots;
my ( $show_jid,       $show_full_route );
my ( $show_offers,    $show_upsell_offers, $show_cross_offers );
my ( $first_class,    $passengers );
my ( $developer_mode, $verbose );
my ( $json_output,    $raw_json_output );
my $use_cache  = 1;
my $use_colour = 'auto';
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  = "\033[1m";
my $output_reset = "\033[0m";

my $output_fyi      = "\033[40;36m";
my $output_unknown  = "\033[40;35m";
my $output_good     = "\033[40;32m";
my $output_warning  = "\033[40;33m";
my $output_critical = "\033[40;31m";

my $output_bold_fyi      = "\033[1;40;36m";
my $output_bold_unknown  = "\033[1;40;35m";
my $output_bold_good     = "\033[1;40;32m";
my $output_bold_warning  = "\033[1;40;33m";
my $output_bold_critical = "\033[1;40;31m";

GetOptions(
	'a|arrive=s'           => sub { $arrival = 1; $time = $_[1] },
	'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,
	'o|with-offers'        => \$show_offers,
	'with-upsell-offers'   => \$show_upsell_offers,
	'with-cross-offers'    => \$show_cross_offers,
	'p|passengers=s'       => \$passengers,
	't|time=s'             => \$time,
	'v|verbose'            => \$verbose,
	'V|version'            => \&show_version,
	'cache!'               => \$use_cache,
	'color=s'              => \$use_colour,
	'colour=s'             => \$use_colour,
	'devmode'              => \$developer_mode,
	'json'                 => \$json_output,
	'raw-json'             => \$raw_json_output,

) or show_help(1);

if ( $use_colour eq 'auto'
	and ( not -t STDOUT or ( defined $ENV{TERM} and $ENV{TERM} eq 'dumb' ) )
	or $use_colour eq 'never' )
{
	$output_bold = $output_reset   = q{};
	$output_fyi  = $output_unknown = $output_good = $output_warning
	  = $output_critical = q{};
	$output_bold_fyi = $output_bold_unknown = $output_bold_good
	  = $output_bold_warning = $output_bold_critical = q{};
}

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{arrival}  = $arrival;
	$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
		) // 0;
		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 ($show_offers) {
		my $offers_req = Travel::Routing::DE::DBRIS->new(
			developer_mode => $developer_mode,
			offers         => {
				recon => $connection->recon,
			},
			passengers  => $opt{passengers},
			first_class => $opt{first_class},
		);
		if ( my $err = $offers_req->errstr ) {
			say STDERR "Request error while looking up offers: ${err}";
		}
		for my $offer ( $offers_req->offers ) {
			if ( $offer->needs_context ) {

				# offers that are only valid when also bying, e.g., a BC25 or BC50
				# Note that this automatically skips cross-sell offers.
				next;
			}
			if ( $offer->is_upsell and not $show_upsell_offers ) {
				next;
			}
			if ( $offer->is_cross_sell and not $show_cross_offers ) {
				next;
			}
			printf( '- %5.2f %s %s',
				$offer->price, $offer->price_unit =~ s{EUR}{€}r,
				$offer->name );
			if ( $first_class and $offer->class == 2
				or not $first_class and $offer->class == 1 )
			{
				printf( " %d. Klasse", $offer->class );
			}
			if ( scalar $offer->conditions ) {
				printf( ' (%s)',
					join( q{ · }, map { $_->{textKurz} } $offer->conditions ) );
			}
			say q{};
		}
	}

	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 and $segment->duration ) {
				printf( "${output_bold}%s${output_reset} %dm  (≈ %d min.)\n",
					$segment->walk_name, $segment->distance_m,
					$segment->duration->in_units('minutes') );
			}
			elsif ( $segment->distance_m ) {
				printf( "${output_bold}%s${output_reset} %dm\n",
					$segment->walk_name, $segment->distance_m );
			}
			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<-a>|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.07

=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<-a>, B<--arrive> I<HH:MM>

Request connections that arrive on or after I<HH:MM>.
Overrides B<--time>.

=item B<--colour>, B<--color> B<always>|B<auto>|B<never>

By default, B<dbris-m> uses ANSI escape codes for output formatting whenever
the output is connected to a terminal and the TERM environment variable is not
set to C<< dumb >>. B<--colour=always> causes it to always use output
formatting regardless of terminal setup, and B<--colour=never> disables any
formatting. B<--colour=auto> restores the default behaviour.

=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<--first-class>

Request first class offers.
Only useful when combined with B<--passengers>.

=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<-o>, B<--with-offers>

(EXPERIMENTAL)
Request offers (e.g. local transit tickets, super saver tickets, flex tickets)
and list their prices, terms, and conditions for each connection.
Note that this option is still work-in-progress and may miss important details.
Offers consisting of multiple components (e.g. "buy a BahnCard 25 and then buy
a cheaper ticket for this connection") are not supported yet.
See also B<--with-upsell-offers>.

=item B<-p>, B<--passengers> I<type>[:I<discounts>,...][B<;>I<type>[:I<discounts>,...]B<;>...]

Use the specified passenger information to request ticket offers and show the
corresponding price for each connection. I<type> must be adult, junior, or
senior. I<discounts> can be one or more of bc25, bc50, bc100, bc25-first,
bc50-first, bc100-first. See also B<--first-class>.

Note that B<dbris> only has access to a single offer per connection. It is
typically the cheapest, but there is no information about what kind of ticket
it is. Lack of a listed price either means that ticket offers are not available
or (for bc100) that the connection does not require a ticket. There is no way
to distinguish between these two cases. B<dbris> does not guarantee accuracy of
the provided information and must not be relied upon to determine whether a
given connection is free or not.

=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 that depart on or after I<HH:MM>.
Default: now.

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

Include free-text messages related to delays, platform changes, and other
quality of service issues or announcements.

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

Show version information and exit.

=item B<--with-upsell-offers>

Include upsell offers such as "travel first class instead of second class".
Must be used with B<-o> / B<--with-offers>.

=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.
