hafas-m

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

our $VERSION = '1.05';

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 $ignore_late = 0;
my $types       = q{};
my $language;
my $developer_mode;
my ( $list_services, $service, $hafas_url );
my ( @excluded_mots, @exclusive_mots );

my @output;

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

GetOptions(
	'a|arrivals'    => \$arrivals,
	'd|date=s'      => \$date,
	'h|help'        => sub { show_help(0) },
	'l|lang=s'      => \$language,
	'L|ignore-late' => \$ignore_late,
	'm|mot=s'       => \$types,
	's|service=s'   => \$service,
	't|time=s'      => \$time,
	'u|url=s'       => \$hafas_url,
	'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 $status = Travel::Status::DE::HAFAS->new(
	date           => $date,
	language       => $language,
	excluded_mots  => \@excluded_mots,
	exclusive_mots => \@exclusive_mots,
	station        => shift || show_help(1),
	time           => $time,
	mode           => $arrivals ? 'arr' : 'dep',
	developer_mode => $developer_mode,
	service        => $service,
	url            => $hafas_url,
);

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;
	my $help;

	for my $type ( split( qr{,}, $types ) ) {
		if ( $type eq 'help' or $type eq 'list' or $type eq '?' ) {
			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 );
		}
	}
}

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

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];
		if ( $d->messages ) {
			print "\n";
			for my $msg ( $d->messages ) {
				printf( "# %s\n", $msg );
			}
		}

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

	return;
}

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

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

	if ( $ignore_late and $d->delay ) {
		next;
	}

	push(
		@output,
		[
			$d->time,
			$d->is_cancelled
			? 'CANCELED'
			: ( $d->delay ? sprintf( '%+d', $d->delay ) : q{} ),
			$d->train,
			$d->route_end,
			( $d->platform // q{} ) . ( $d->is_changed_platform ? ' !' : q{} ),
			$d->info,
			$d
		]
	);
}

display_result(@output);

__END__

=head1 NAME

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

=head1 SYNOPSIS

B<hafas-m> [B<-a>] [B<-d> I<date>] [B<-L>] [B<-m> I<motlist>] [B<-t> I<time>]
I<station>

=head1 VERSION

version 1.05

=head1 DESCRIPTION

hafas-m is an interface to HAFAS-based departure monitors, for instance the
one 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 at most main stations.

=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<-l>, B<--lang> B<d>|B<e>|B<i>|B<n>

Set language used for additional information. Supports B<d>eutsch (default),
B<e>nglish, B<i>talian and dutch (B<n>), depending on the used service.

=item B<-L>, B<--ignore-late>

Do not display delayed trains.

=item B<--list>

List known HAFAS installations. See also B<--service> and B<--url>.

=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<-u>, B<--url> I<url>

Request arrivals/departures using the API entry point at I<url>, defaults to
C<< http://reiseauskunft.bahn.de/bin/bhftafel.exe >>. Note that the language
and output selection suffix (e.g. "/dn") must not be included here.

Again, see B<--list> for a list of known URLs. Unknown URLs are also
supported, though note that B<--mot> will not work when using this opton.

=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

Unknown.

=head1 AUTHOR

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

=head1 LICENSE

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