path: root/bin/efa-m

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

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

our $VERSION = '1.09';

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

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

my $efa_url = 'http://efa.vrr.de/vrr/XSLT_DM_REQUEST';
my ( $date, $time, $input_type, $list_lines, $offset, $relative_times );
my ($full_routes);
my ($filter_via);
my ( $timeout,    $developer_mode );
my ( @grep_lines, @grep_platforms );
my ( %edata,      @edata_pre );

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

GetOptions(
	'd|date=s'      => \$date,
	'h|help'        => sub { show_help(0) },
	'l|line=s@'     => \@grep_lines,
	'L|linelist'    => \$list_lines,
	'o|offset=i'    => \$offset,
	'O|output=s@'   => \@edata_pre,
	'p|platform=s@' => \@grep_platforms,
	'r|relative'    => \$relative_times,
	't|time=s'      => \$time,
	'timeout=i'     => \$timeout,
	'u|efa-url=s'   => \$efa_url,
	'v|via=s'       => \$filter_via,
	'V|version'     => \&show_version,
	'devmode'       => \$developer_mode,

) or show_help(1);

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

# --line=foo,bar support
@edata_pre      = split( qr{,}, join( q{,}, @edata_pre ) );
@grep_lines     = split( qr{,}, join( q{,}, @grep_lines ) );
@grep_platforms = split( qr{,}, join( q{,}, @grep_platforms ) );

my ( $place, $input ) = @ARGV;

if ( $input =~ s{ ^ (?<type> address|poi|stop) : }{}x ) {
	$input_type = $+{type};
}

for my $efield (@edata_pre) {
	given ($efield) {
		when ('f') { $edata{fullroute} = 1; $full_routes = 1 }
		when ('r') { $edata{route}     = 1; $full_routes = 1 }
		default    { $edata{$efield}   = 1 }
	}
}
if ($filter_via) {
	$full_routes = 1;
}

my $status = Travel::Status::DE::EFA->new(
	date           => $date,
	developer_mode => $developer_mode,
	efa_url        => $efa_url,
	full_routes    => $full_routes,
	place          => $place,
	name           => $input,
	time           => $time,
	type           => $input_type,
	timeout        => $timeout,
);

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

	print "Usage: efa-m [-d <dd.mm.yyyy>] [-t <hh:mm>] <city> <station>\n"
	  . "See also: man efa-m\n";

	exit $code;
}

sub show_version {
	say "efa-m version ${VERSION}";

	exit 0;
}

sub format_route {
	my (@route) = @_;

	my $output = q{};

	for my $stop (@route) {
		if ( not $stop ) {
			say "BUG";
			next;
		}
		if ( not defined $stop->arr_time ) {
			$output .= sprintf( "        %5s  %40s %s\n",
				$stop->dep_time, $stop->name, $stop->platform, );
		}
		elsif ( not defined $stop->dep_time ) {
			$output .= sprintf( "%5s          %40s %s\n",
				$stop->arr_time, $stop->name, $stop->platform, );
		}
		elsif ( $stop->arr_time eq $stop->dep_time ) {
			$output .= sprintf( "    %5s      %40s %s\n",
				$stop->dep_time, $stop->name, $stop->platform, );
		}
		else {
			$output .= sprintf(
				"%5s → %5s  %40s %s\n",
				$stop->arr_time, $stop->dep_time,
				$stop->name,     $stop->platform,
			);
		}
	}
	return $output;
}

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

		if ( length( $line->[5] ) ) {
			$line->[5] =~ tr{\n\x0d}{ }s;
			chomp $line->[5];
			print "\n";
			for my $info_line ( split( qr{\n}, $line->[5] ) ) {
				say "# ${info_line}";
			}
		}

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

		if ( $line->[6] and $edata{fullroute} ) {
			say $line->[6];
		}
	}

	return;
}

sub show_lines {
	my @output;

	for my $l ( $status->lines ) {

		if ( @grep_lines and not( $l->name ~~ \@grep_lines ) ) {
			next;
		}

		push( @output,
			[ $l->type, $l->name, $l->direction // q{}, $l->route // q{} ] );
	}

	display_result(@output);

	return;
}

sub show_results {
	my @output;

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

		my @output_line;
		my $platform = $d->platform;
		my $dtime    = (
			$relative_times ? sprintf( '%2d min', $d->countdown ) : $d->time );

		if ( $d->platform_db ) {
			$platform .= ' (DB)';
		}

		if (
			( @grep_lines and not( $d->line ~~ \@grep_lines ) )
			or ( @grep_platforms
				and not( $platform ~~ \@grep_platforms ) )
			or ( $offset and $d->countdown < $offset )
			or ( $filter_via
				and
				not( first { $_->name =~ m{$filter_via}io } $d->route_post ) )
		  )
		{
			next;
		}

		if ( $d->is_cancelled ) {
			if ($relative_times) {
				next;
			}
			else {
				$dtime .= ' CANCELED';
			}
		}
		if ( $d->delay ) {
			$dtime .= ' (+' . $d->delay . ')';
		}

		@output_line
		  = ( $dtime, $platform, $d->line, q{}, $d->destination, $d->info );

		if ( $edata{route} ) {
			$output_line[3]
			  = join( q{  }, map { $_->{stop_suf} } $d->route_interesting );
		}

		if ( $edata{fullroute} ) {
			$output_line[6] = format_route( $d->route_post );
		}

		push( @output, \@output_line );
	}

	display_result(@output);

	return;
}

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

if ($list_lines) {
	show_lines();
}
else {
	show_results();
}

__END__

=head1 NAME

efa-m - Unofficial interface to the efa.vrr.de departure monitor

=head1 SYNOPSIS

B<efa-m> [B<-Lr>] [B<-d> I<dd.mm.yyyy>] [B<-t> I<hh:mm>]
[B<-l> I<lines>] [B<-p> I<platforms>] [B<-u> I<url>]
I<city> [I<type>B<:>]I<name>

=head1 VERSION

version 1.09

=head1 DESCRIPTION

B<efa-m> lists upcoming tram, bus and train departures at the location I<name>
in I<city>.

By default, I<name> refers to a stop, this can be changed by specifying
I<type>.  Supported types are B<address> and B<poi> (point of interest).

=head1 OPTIONS

=over

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

Show departures for I<date> instead of today.
May also be specified as I<dd.mm.>

=item B<-L>, B<--linelist>

Do not show departures. Instead, list all lines serving the specified place.
Note that this information may be incomplete -- only lines which are in
service either at the time of the B<efa-m> call or at the time specifed
using B<--date> and B<--time> are guaranteed to be included.

=item B<-l>, B<--line> I<lines>

Only show departures of I<lines> (comma-separatad list, option may be
repeated)

=item B<-o>, B<--offset> I<minutes>

Ignore departures which are less than I<minutes> from now.

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

Only show departures at I<platforms> (comma-separated list, option may be
repeated).  Note that the C<< Bstg. >> / C<< Gleis >> prefix must be omitted.

=item B<-r>, B<--relative>

Use relative departure times.

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

Show departures starting at I<time> instead of now.

=item B<-u>, B<--efa-url> I<url>

URL to the EFA entry point, defaults to L<http://efa.vrr.de/vrr/XSLT_DM_REQUEST>.
Depending on your location, some I<url>s may contain more specific data
than others.  See Travel::Status::DE::EFA(3pm) for alternatives.

=item B<--timeout> I<seconds>

Set timeout for HTTP requests. Default: 10 seconds. Set to 0 or a negative
value to disable it.

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

Only show trains serving I<station> after the requseted stop. I<station>
is matched against the "I<city> I<stop>" fields in each line's route.
Regular expressions are also supported.

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

Show version information.

=back

=head1 EXIT STATUS

Normally zero. B<1> means B<efa-m> was called with invalid options,
B<2> indicates a request error from Travel::Status::DE::EFA(3pm).

=head1 CONFIGURATION

None.

=head1 DEPENDENCIES

=over

=item * Class::Accessor(3pm)

=item * LWP::UserAgent(3pm)

=item * Travel::Status::DE::EFA(3pm)

=item * XML::LibXML(3pm)

=back

=head1 BUGS AND LIMITATIONS

B<efa-m> uses the VRR EFA service by default, which seems to contain the
greatest available set of information. However, some cities (e.g. Berlin
or parts of Hamburg) are incomplete. B<efa-m> is not yet able to choose the
appropriate EFA URL for these by itself, it needs to be done manually with
the B<-u>, B<--efa-url> option.

=head1 AUTHOR

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

=head1 LICENSE

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