path: root/bin/db-iris

#!/usr/bin/env perl
use strict;
use warnings;
use 5.018;

no if $] >= 5.018, warnings => 'experimental::smartmatch';

our $VERSION = '0.00';

use DateTime;
use DateTime::Format::Strptime;
use Encode qw(decode);
use Getopt::Long qw(:config no_ignore_case);
use List::Util qw(first max);
use Travel::Status::DE::IRIS;
use Travel::Status::DE::IRIS::Stations;

my ( $date, $time );
my $datetime = DateTime->now( time_zone => 'Europe/Berlin' );
my $arrivals = 0;
my $filter_via;
my $show_full_route = 0;
my ( @grep_traintypes, @grep_platforms );

my @output;

binmode( STDOUT, ':encoding(utf-8)' );

@ARGV = map { decode( 'UTF-8', $_ ) } @ARGV;

GetOptions(
	'd|date=s'       => \$date,
	'f|full-route'   => \$show_full_route,
	'h|help'         => sub { show_help(0) },
	'm|mot=s'        => \@grep_traintypes,
	'p|platforms=s@' => \@grep_platforms,
	't|time=s'       => \$time,
	'v|via=s'        => \$filter_via,
	'V|version'      => \&show_version,

) or show_help(1);

if ( @ARGV != 1 ) {
	show_help(1);
}

# opt=foo,bar support
@grep_platforms  = split( qr{,}, join( q{,}, @grep_platforms ) );
@grep_traintypes = split( qr{,}, join( q{,}, @grep_traintypes ) );

my ($station) = @ARGV;
$station = get_station($station);

if ($date) {
	my ( $day, $month, $year ) = split( /\./, $date );
	$datetime->set(
		day   => $day,
		month => $month,
		year  => $year || $datetime->year,
	);
}
if ($time) {
	my ( $hour, $minute, $second ) = split( /:/, $time );
	$datetime->set(
		hour   => $hour,
		minute => $minute,
		second => $second || $datetime->second,
	);
}

my $status = Travel::Status::DE::IRIS->new(
	datetime => $datetime,
	station  => $station,
);

sub get_station {
	my ($input_name) = @_;

	my @stations
	  = Travel::Status::DE::IRIS::Stations::get_station_by_name($input_name);

	if ( @stations == 0 ) {
		say STDERR "No station matches '$input_name'";
		exit(1);
	}
	elsif ( @stations == 1 ) {
		return $stations[0][0];
	}
	else {
		say STDERR "The input '$input_name' is ambiguous. Please choose one "
		  . 'of the following:';
		say STDERR join( "\n", map { $_->[1] } @stations );
		exit(1);
	}
}

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

	print 'Usage: db-iris [-f] '
	  . "[-v <via>] <station>\n"
	  . "See also: man db-iris\n";

	exit $code;
}

sub show_version {
	say "db-iris version ${VERSION}";

	exit 0;
}

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) {
		printf(
			join( q{  }, ( map { "%-${_}s" } @line_length ) ) . "\n",
			@{$line}[ 0 .. 4 ]
		);

		if ($show_full_route) {
			print "\n" . join( "\n", $line->[5]->route ) . "\n\n\n";
		}
	}

	return;
}

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

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

	my @via;

	@via = $d->route_post;

	if (   ( $filter_via and not( first { $_ =~ m{$filter_via}io } @via ) )
		or ( @grep_platforms and not( $d->platform ~~ \@grep_platforms ) )
		or ( @grep_traintypes and not( $d->type ~~ \@grep_traintypes ) ) )
	{
		next;
	}

	my $delay = q{};

	if ( $d->delay ) {
		$delay = ( $d->delay > 0 ? ' +' : q{ } ) . $d->delay;
	}
	if ( $d->is_cancelled ) {
		$delay = ' CANCELED';
	}

	push(
		@output,
		[
			$d->time . $delay,
			$d->train, $arrivals ? q{} : join( q{  }, $d->route_interesting ),
			$d->route_end, $d->platform, $d
		]
	);
}

display_result(@output);

__END__

=head1 NAME

db-iris - Interface to the DeutscheBahn online departure monitor

=head1 SYNOPSIS

B<db-iris> [B<-fV>] [B<-d> I<date>] [B<-t> I<time>] [B<-v> I<station>]
I<station>

=head1 VERSION

version 0.00

=head1 DESCRIPTION

db-iris is an interface to the DeutscheBahn departure monitor
available at L<https://iris.noncd.db.de/wbt/js/index.html>.

It requests all departures at I<station> and lists them on stdout, similar to
the big departure screens installed at most main stations.

=head1 OPTIONS

=over

=item B<-d>, B<--date> I<date>

Request results for I<date> in dd.mm. oder dd.mm.YYYY format. Note that only
slight (a few hours max) deviations from the current time are supported by the
IRIS backend, larger ones will not return data.

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

Show the entire route of all trains (both before and after I<station>).

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

Comma-separated list of modes of transport to filter by. Using this option
causes all arrivals/departures whose mot not in I<motlist> to be discarded.

The mot is based on the train type and accepts a superset of the following
values:

    local transport:
    IR   Inter-Regio (rare in Germany, mostly used in Switzerland)
    IRE  Inter-Regio Express (rare)
    RB   Regionalbahn (slower than RE)
    RE   Regional-Express
    S    S-Bahn

    regional/interregional transport:
    D    "Schnellzug" (generic fast train, rare)
    EC   Eurocity
    IC   Intercity
    ICE  Intercity-Express
    THA  Thalys

Depending on the city and country, other types may be used as well. Examples
include "ABR" / "NWB" (private trains included in the local transport tariff
system), "HKX" (private train not included in any DB tariffs) and
"SBB" (unknown swiss train class)

=item B<-p>, B<--platforms> I<platforms>

Only show arrivals/departures at I<platforms> (comma-separated list, option may
be repeated).

=item B<-t>, B<--time> I<time>

Request results for I<time> in HH:MM oder HH:MM:SS format. Note that only
slight deviations (a few hours max) from the current time are supported by the
IRIS backend, larger ones will not return data.

=item B<-v>, B<--via> I<viastation>

Only show trains serving I<viastation> after I<station>.

=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 * DateTime(3pm)

=item * LWP::UserAgent(3pm)

=item * XML::LibXML(3pm)

=back

=head1 BUGS AND LIMITATIONS

Todo.

=head1 AUTHOR

Copyright (C) 2013-2014 by Daniel Friesel E<lt>derf@finalrewind.orgE<gt>

=head1 LICENSE

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