db-ris

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

our $VERSION = '0.0';

use Getopt::Long qw(:config no_ignore_case);
use List::Util qw(first max);
use Travel::Status::DE::DeutscheBahn;

my ( $date, $time );
my $types = q{};
my %train_type;
my $filter_via;
my @output;

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

GetOptions(
	'd|date=s'  => \$date,
	'h|help'    => sub { show_help(0) },
	'm|mot=s'   => \$types,
	't|time=s'  => \$time,
	'v|via=s'   => \$filter_via,
	'V|version' => \&show_version,

) or show_help(1);

for my $type ( split( qr{,}, $types ) ) {
	if ( substr( $type, 0, 1 ) eq q{!} ) {
		$train_type{ substr( $type, 1 ) } = 0;
	}
	else {
		$train_type{$type} = 1;
	}
}

my $status = Travel::Status::DE::DeutscheBahn->new(
	date    => $date,
	mot     => \%train_type,
	station => shift,
	time    => $time,
);

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

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

	exit $code;
}

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

	exit 0;
}

sub display_result {
	my (@lines) = @_;

	my @line_length;

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

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

	for my $line (@lines) {
		printf( join( q{  }, ( map { "%-${_}s" } @line_length ) ) . "\n",
			@{$line}, );
	}

	return;
}

sub filter_via {
	my (@via) = @_;

	my ( @via_main, @via_show, $last_stop );

	for my $stop (@via) {
		if ( $stop =~ m{ ?Hbf} ) {
			push( @via_main, $stop );
		}
	}
	$last_stop = pop(@via);

	if ( @via_main and @via and $via[0] eq $via_main[0] ) {
		shift(@via_main);
	}

	if ( @via < 3 ) {
		@via_show = @via;
	}
	else {
		@via_show = splice( @via, 0, ( @via_main > 2 ? 1 : 3 - @via_main ) );

		while ( @via_show < 3 and @via_main ) {
			my $stop = shift(@via_main);
			if ( $stop ~~ \@via_show or $stop eq $last_stop ) {
				next;
			}
			push( @via_show, $stop );
		}
	}

	for my $stop (@via_show) {
		$stop =~ s{ ?Hbf}{};
	}

	return @via_show;
}

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

	my ( @via, @via_main, @via_show );

	@via = $d->route;

	if ( $filter_via and not( first { $_ =~ m{$filter_via}io } @via ) ) {
		next;
	}

	push(
		@output,
		[
			$d->time, $d->train,
			join( q{  }, filter_via(@via) ), $d->destination,
			$d->platform, $d->info
		]
	);
}

display_result(@output);

__END__

=head1 NAME

db-ris - Interface to the DeutscheBahn online departure monitor

=head1 SYNOPSIS

B<db-ris> [B<-d> I<date>] [B<-m> I<motlist>] [B<-t> I<time>] [B<-v> I<via>]
I<station>

=head1 VERSION

version 0.0

=head1 DESCRIPTION

db-ris is an interface to the DeutscheBahn departure monitor
available at L<http://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, similar to the big
departure screens installed on most main stations.

=head1 OPTIONS

=over

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

Date to list departures for.  Default: today

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

Comma-separated list of modes of transport to show/hide. Accepts the following
argements:

	ice    InterCity Express trains
	ic_ec  InterCity / EuroCity trains
	d      InterRegio and similar
	nv     "Nahverkehr", RegionalExpress and such
	s      S-Bahn
	bus
	ferry
	u      U-Bahn
	tram

You can prefix an argument with "!" to hide it. The default is C<<
ice,ic_ec,d,nv,s >>. Note that B<-m> does not replace the default, so if you
only want to see S-Bahn und U-Bahn departures, you'd have to use C<< -m
!ice,!ic_ec,!d,!nv,u >>.

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

Time to list departures for. Default: now.

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

Only display trains whose route (all stations between the current stop and the
destination) matches the perl regular expression I<regex>.  The match is not
case-sensitive.  Use '^regex$' to match a full string, but be aware that this
may not work as expected.

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

=item * XML::LibXML(3pm)

=back

=head1 BUGS AND LIMITATIONS

There are a few character encoding problems (most notably, B<--via> does not
understand UTF-8 umlauts).

=head1 AUTHOR

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

=head1 LICENSE

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