path: root/bin/hafas-m

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

our $VERSION = '3.01';

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

my ( $date, $time );
my $arrivals = 0;
my $types    = q{};
my $developer_mode;
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(
	'a|arrivals'  => \$arrivals,
	'd|date=s'    => \$date,
	'h|help'      => sub { show_help(0) },
	'm|mot=s'     => \$types,
	's|service=s' => \$service,
	't|time=s'    => \$time,
	'V|version'   => \&show_version,
	'devmode'     => \$developer_mode,
	'list'        => \$list_services,

) or show_help(1);

if ($list_services) {
	printf( "%-40s %-14s %s\n\n", 'operator', 'abbr. (-s)', 'url (-u)' );
	for my $service ( Travel::Status::DE::HAFAS::get_services() ) {
		printf( "%-40s %-14s %s\n", @{$service}{qw(name shortname url)} );
	}
	exit 0;
}

parse_mot_options();

my %opt = (
	excluded_mots  => \@excluded_mots,
	exclusive_mots => \@exclusive_mots,
	station        => shift || show_help(1),
	arrivals       => $arrivals,
	developer_mode => $developer_mode,
	service        => $service,
);

if ( $opt{station} =~ m{[|]} ) {
	$opt{journey} = { id => $opt{station} };
	delete $opt{station};
}

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 $status = Travel::Status::DE::HAFAS->new(%opt);

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

	print 'Usage: hafas-m [-d <dd.mm.yyyy>] [-m <motlist>] [-t <time>] '
	  . "<station>\n"
	  . "See also: man hafas-m\n";

	exit $code;
}

sub show_version {
	say "hafas-m 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 = $status->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_result {
	my (@lines) = @_;

	my @line_length;

	if ( not @lines ) {
		die("Nothing to show\n");
	}

	for my $i ( 0 .. 4 ) {
		$line_length[$i] = max map { length( $_->[$i] ) } @lines;
	}

	for my $line (@lines) {

		my $d             = $line->[6];
		my $first_message = 1;
		for my $msg ( $d->messages ) {
			if ( $msg->ref_count == 1 ) {
				if ($first_message) {
					print "\n";
					$first_message = 0;
				}
				if ( $msg->short ) {
					printf( "# %s\n", $msg->short );
				}
				printf( "# %s\n", $msg->text );
			}
		}

		printf(
			join( q{  }, ( map { "%-${_}s" } @line_length ) ),
			@{$line}[ 0 .. 4 ]
		);
		if ( $line->[5] ) {
			print q{  } . $line->[5];
		}
		print "\n";
	}

	return;
}

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 ) {
		return q{!};
	}
	return q{?};
}

if ( my $err = $status->errstr ) {
	say STDERR "Request error: ${err}";
	if ( $status->errcode
		and ( $status->errcode eq 'H730' or $status->errcode eq 'LOCATION' ) )
	{
		show_similar_stops();
	}
	exit 2;
}

if ( $opt{journey} ) {
	my $result = $status->result;

	printf( "%s → %s", $result->name, $result->route_end );
	if ( $result->number ) {
		printf( "  |  Zug  %s", $result->number );
	}
	if ( $result->line ) {
		printf( "  |  Linie %s", $result->line );
	}
	say q{};

	for my $stop ( $result->route ) {
		printf(
			"%5s %s %5s %5s %1s%1s %s%s\n",
			$stop->{arr} ? $stop->{arr}->strftime('%H:%M')      : q{},
			( $stop->{arr} and $stop->{dep} ) ? '→'             : q{ },
			$stop->{dep}   ? $stop->{dep}->strftime('%H:%M')    : q{},
			$stop->{delay} ? sprintf( '(%+d)', $stop->{delay} ) : q{},
			display_occupancy( $stop->{load}{FIRST} ),
			display_occupancy( $stop->{load}{SECOND} ),
			$stop->{name},
			$stop->{direction} ? sprintf( '  → %s', $stop->{direction} ) : q{}
		);
	}

	for my $msg ( $result->messages ) {
		say '';
		if ( $msg->short ) {
			printf( "%s\n", $msg->short );
		}
		printf( "%s\n", $msg->text );
	}
	exit 0;
}

my $message_id = 1;
for my $m ( $status->messages ) {
	if ( $m->ref_count > 1 ) {
		$m->{id} = $message_id++;
		if ( $m->short ) {
			printf( "# (%d) %s\n# %s\n\n", $m->{id}, $m->short, $m->text );
		}
		else {
			printf( "# (%d) %s\n\n", $m->{id}, $m->text );
		}
	}
}

for my $d ( $status->results ) {

	my $info_line = q{};

	for my $message ( $d->messages ) {
		if ( $message->ref_count > 1 ) {
			$info_line = sprintf( '(%d) %s', $message->{id}, $info_line );
		}
	}

	push(
		@output,
		[
			$d->sched_datetime->strftime('%H:%M'),
			$d->is_cancelled
			? 'CANCELED'
			: ( $d->delay ? sprintf( '%+d', $d->delay ) : q{} ),
			$d->name,
			$d->route_end,
			( $d->platform // q{} ) . ( $d->is_changed_platform ? ' !' : q{} ),
			$info_line,
			$d
		]
	);
}

display_result(@output);

__END__

=head1 NAME

hafas-m - Interface to the DeutscheBahn/HAFAS online departure monitor

=head1 SYNOPSIS

B<hafas-m> [B<-d> I<date>] [B<-t> I<time>] [B<-m> I<motlist>]
[B<-s> I<service> | B<-u> I<url>] I<station>

=head1 VERSION

version 3.01

=head1 DESCRIPTION

hafas-m is an interface to HAFAS-based departure monitors such as the one
available at L<https://reiseauskunft.bahn.de//bin/bhftafel.exe/dn>.

It requests all departures at I<station> (optionally filtered by date, time,
route and means of transport) and lists them on stdout.

=head1 OPTIONS

=over

=item B<-a>, B<--arrivals>

Show arrivals instead of departures, including trains ending at the specified
station. Note that this causes the output to display the start instead of
the end station.

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

Date to list departures for.  Default: today.

=item B<--list>

List known HAFAS installations. A HAFAS service from this list can be querie
using B<--service>.

=item B<-m>, B<--mot> I<motlist>

By default, B<hafas-m> shows all modes of transport arriving/departing at the
specified station. 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>

Request arrivals/departures using the API provided by I<service>, defaults
to DB (Deutsche Bahn). See B<--list> for a list of known services.

=item B<-t>, B<--time> I<hh>:I<mm>

Time to list departures for.  Default: now.

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

Show version information.

=back

=head1 EXIT STATUS

Zero unless things went wrong.

=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) 2015-2020 by Daniel Friesel E<lt>derf@finalrewind.orgE<gt>

=head1 LICENSE

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