path: root/bin/efa

#!/usr/bin/env perl
## Copyright © 2009,2010 by Daniel Friesel <derf@derf.homelinux.org>
## License: WTFPL <http://sam.zoy.org/wtfpl>
##   0. You just DO WHAT THE FUCK YOU WANT TO.
use strict;
use warnings;
use 5.010;

use Getopt::Long qw/:config no_ignore_case/;
use XML::LibXML;
use WWW::Mechanize;

my $firsturl = 'http://efa.vrr.de/vrr/XSLT_TRIP_REQUEST2?language=de&itdLPxx_transpCompany=vrr';
my $posturl = 'http://efa.vrr.de/vrr/XSLT_TRIP_REQUEST2';

my $version = '1.3+git';
my $content;
my $connections;
my %post;
my $www = WWW::Mechanize->new(
	autocheck => 1,
);
my (@from, @to, @via);
my ($from_type, $to_type, $via_type) = ('stop') x 3;
my $ignore_info = 'Fahrradmitnahme';
my ($test_dump, $test_parse);

binmode(STDOUT, ':utf8');
binmode(STDERR, ':utf8');

sub check_ambiguous {
	my ($full_tree) = @_;
	my $ambiguous = 0;

	my $xp_select = XML::LibXML::XPathExpression->new('//select');
	my $xp_option = XML::LibXML::XPathExpression->new('./option');

	foreach my $select (@{$full_tree->findnodes($xp_select)}) {
		$ambiguous = 1;
		printf {*STDERR} (
			"Ambiguous input for %s\n",
			$select->getAttribute('name'),
		);
		foreach my $val ($select->findnodes($xp_option)) {
			print {*STDERR} "\t";
			say {*STDERR} $val->textContent();
		}
	}
	if ($ambiguous) {
		exit 1;
	}
}

sub check_no_connections {
	my ($full_tree) = @_;

	my $xp_err_img = XML::LibXML::XPathExpression->new(
		'//td/img[@src="images/ausrufezeichen.jpg"]');

	my $err_node = $full_tree->findnodes($xp_err_img)->[0];

	if ($err_node) {
		say {*STDERR} 'Looks like efa.vrr.de showed an error.';
		say {*STDERR} 'I will now try to dump the error message:';

		say {*STDERR} $err_node->parentNode()->parentNode()->textContent();

		exit 2;
	}
}

sub display_connection {
	my ($con_parts) = @_;

	for my $con (@{$con_parts}) {

		# Note: Changes @{$con} elements
		foreach my $str (@{$con}) {
			$str =~ s/[\s\n\t]+/ /gs;
			$str =~ s/^ //;
			$str =~ s/ $//;
		}

		if (@{$con} < 5) {
			foreach my $str (@{$con}) {
				say "# $str";
			}
			next;
		}

		if ($con->[0] !~ / \d{2} : \d{2} /ox) {
			splice(@{$con}, 0, 0, q{});
			splice(@{$con}, 4, 0, q{});
			$con->[7] = q{};
		}
		elsif ($con->[4] =~ / Plan: \s ab /ox) {
			printf(
				"# %s\n",
				splice(@{$con}, 4, 1),
			);
		}

		foreach my $extra (splice(@{$con}, 8, -1)) {
			if (not (length($ignore_info) and $extra =~ /$ignore_info/i)) {
				say "# $extra";
			}
		}

		printf(
			"%-5s %-2s  %-30s %-20s %s\n%-5s %-2s  %-30s\n\n",
			@{$con}[0, 1, 2, 3, 7, 4, 5, 6],
		)
	}
}

sub opt_time_arr {
	$post{itdTripDateTimeDepArr} = 'arr';
	opt_time(@_);
}

sub opt_time_dep {
	$post{itdTripDateTimeDepArr} = 'dep';
	opt_time(@_);
}

sub opt_time {
	my (undef, $time) = @_;

	if ($time !~ /^ [0-2]? \d : [0-5]? \d $/x) {
		die("time: Invalid argument. Use HH:MM\n");
	}
	@post{'itdTimeHour', 'itdTimeMinute'} = split(/:/, $time);
}

sub opt_date {
	my (undef, $date) = @_;

	if ($date !~ /^ [0-3]? \d \. [01]? \d \. (?: \d{4} )? $/x) {
		die("date: Invalid argument: Use DD.MM.[YYYY]\n");
	}
	@post{'itdDateDay', 'itdDateMonth', 'itdDateYear'} = split(/\./, $date);
	$post{itdDateYear} //= (localtime(time))[5] + 1900;
}

sub opt_exclude {
	my @mapping = qw/
		zug s-bahn u-bahn stadtbahn tram stadtbus regionalbus
		schnellbus seilbahn schiff ast sonstige
	/;
	my (undef, $str) = @_;
	my @exclude = split(/,/, $str);

	foreach my $exclude_type (@exclude) {
		my $ok = 0;
		for my $map_id (0 .. $#mapping) {
			if ($exclude_type eq $mapping[$map_id]) {
				$post{"inclMOT_$map_id"} = undef;
				$ok = 1;
			}
		}
		if (not $ok) {
			die("exclude: Invalid argument: $exclude_type\n");
		}
	}
}

sub opt_maxinter {
	my (undef, $opt) = @_;
	$post{maxChanges} = $opt;
}

sub opt_prefer {
	my (undef, $prefer) = @_;

	given ($prefer) {
		when ('speed')  { $post{routeType} = 'LEASTTIME' }
		when ('nowait') { $post{routeType} = 'LEASTINTERCHANGE' }
		when ('nowalk') { $post{routeType} = 'LEASTWALKING' }
		default {
			die("prefer: Invalid argument. Use speed|nowait|nowalk\n");
		}
	}
}

sub opt_proximity {
	$post{useProxFootSearch} = 1;
}

sub opt_include {
	my (undef, $include) = @_;

	given ($include) {
		when ('local') { $post{lineRestriction} = 403 }
		when ('ic')    { $post{lineRestriction} = 401 }
		when ('ice')   { $post{lineRestriction} = 400 }
		when (/\d+/)   { $post{lineRestriction} = $include }
		default {
			die("include: Invalid argument. Use local|ic|ice\n");
		}
	}
}

sub opt_walk_speed {
	my (undef, $walk_speed) = @_;

	if ($walk_speed ~~ ['normal', 'fast', 'slow']) {
		$post{changeSpeed} = $walk_speed;
	}
	else {
		die("walk-speed: Invalid argument. Use normal|fast|slow\n");
	}
}

sub opt_bike {
	$ignore_info = undef;
	$post{bikeTakeAlong} = 1;
}

sub opt_timeout {
	my (undef, $timeout) = @_;
	$www->timeout($timeout);
}

sub parse_tree {
	my ($full_tree) = @_;
	my $con_part = 0;
	my $con_no;
	my $cons;

	my $xp_td = XML::LibXML::XPathExpression->new('//table//table/tr/td');
	my $xp_img = XML::LibXML::XPathExpression->new('./img');

	foreach my $td (@{$full_tree->findnodes($xp_td)}) {

		my $colspan = $td->getAttribute('colspan') // 0;
		my $class   = $td->getAttribute('class')   // q{};

		if ( $colspan != 8 and $class !~ /^bgColor2?$/ ) {
			next;
		}

		if ($colspan == 8) {
			if ($td->textContent() =~ / (?<no> \d+ ) \. .+ Fahrt /x) {
				$con_no = $+{'no'} - 1;
				$con_part = 0;
				next;
			}
		}

		if ($class =~ /^bgColor2?$/) {
			if ($class eq 'bgColor' and ($con_part % 2) == 1) {
				$con_part++;
			}
			elsif ($class eq 'bgColor2' and ($con_part % 2) == 0) {
				$con_part++;
			}
		}

		if (
			defined $con_no and not $td->exists($xp_img)
			and $td->textContent() !~ /^\s*$/
			)
		{
			push(@{$cons->[$con_no]->[$con_part]}, $td->textContent());
		}
	}

	if (defined $con_no) {
		return $cons;
	}
	else {
		say {*STDERR}
			'efa.vrr.de returned no connections, check your input data.';
		exit 3;
	}
}

GetOptions(
	'a|arrive=s'     => \&opt_time_arr,
	'b|bike'         => \&opt_bike,
	'd|date=s'       => \&opt_date,
	'depart=s'       => \&opt_time_dep,
	'e|exclude=s'    => \&opt_exclude,
	'from=s{2}'      => \@from,
	'h|help'         => sub {exec('perldoc', '-F', $0)},
	'I|ignore-info=s{0,1}' => \$ignore_info,
	'm|max-change=i' => \&opt_maxinter,
	'post=s'         => \%post,
	'P|prefer=s'     => \&opt_prefer,
	'p|proximity'    => \&opt_proximity,
	'i|include=s'    => \&opt_include,
	'test-dump'      => \$test_dump,
	'test-parse'     => \$test_parse,
	't|time=s'       => \&opt_time,
	'timeout=i'      => \&opt_timeout,
	'to=s{2}'        => \@to,
	'v|version'      => sub {print "efa version $version\n"; exit 0},
	'via=s{2}'       => \@via,
	'w|walk-speed=s' => \&opt_walk_speed,

) or die("Please see $0 --help\n");

if (not (@from and @to)) {
	if (@ARGV == 4) {
		(@from[0,1], @to[0,1]) = @ARGV;
	}
	elsif (@ARGV == 6) {
		(@from[0,1], @via[0,1], @to[0,1]) = @ARGV;
	}
}

if (@to != 2 or @from != 2) {
	die("Insufficient to/from arguments, see $0 --help for usage\n");
}

for my $pair (
	[$from[1], \$from_type],
	[$via[1] , \$via_type ],
	[$to[1]  , \$to_type  ],
) {
	next if (not defined $pair->[0]);

	if ($pair->[0] =~ s{ ^ (?<type> [^:]+ ) : \s* (?<target> .+ ) $ }
		{$+{target}}x)
	{
		given($+{type}) {
			when('addr') { ${$pair->[1]} = 'address' }
			default      { ${$pair->[1]} = $+{type}  }
		}
	}
}

@post{'place_origin', 'name_origin'} = @from;
@post{'place_destination', 'name_destination'} = @to;
if (@via == 2) {
	@post{'place_via', 'name_via'} = @via;
}

foreach my $type ($from_type, $to_type, $via_type) {
	if (not ($type ~~ ['stop', 'address', 'poi'])) {
		die("from/to/via type: Must be stop, addr or poi, not '$type'\n");
	}
}

$post{type_origin} = $from_type;
$post{type_destination} = $to_type;
$post{type_via} = $via_type;

if ($test_parse) {
	local $/ = undef;
	$content = <STDIN>;
}
else {
	$www->get($firsturl);
	$www->submit_form(
		form_name => 'jp',
		fields => \%post,
	);

	# XXX (workaround)
	# The content actually is iso-8859-1. But HTML::Message doesn't actually
	# decode character strings when they have that encoding. However, it
	# doesn't check for latin-1, which is an alias for iso-8859-1.
	$content = $www->response()->decoded_content(charset => 'latin-1');
}

if ($test_dump) {
	print $content;
	exit 0
}

my $tree = XML::LibXML->load_html(string => $content);

check_ambiguous($tree);
check_no_connections($tree);

$connections = parse_tree($tree);

for my $i (0 .. $#{$connections}) {
	display_connection($connections->[$i]);
	if ($i != $#{$connections}) {
		print "------\n\n";
	}
}

__END__

=head1 NAME

efa - unofficial efa.vrr.de command line client

=head1 SYNOPSIS

=over

=item B<efa> B<--from> I<city> I<stop> B<--to> I<city> I<stop> [ I<additional options> ]

=item B<efa> [ I<options> ] I<from-city> I<from-stop> [ I<via-city> I<via-stop> ] I<to-city> I<to-stop>

=back

=head1 DESCRIPTION

B<efa> is a command line client for the L<http://efa.vrr.de> web interface.
It sends the specified information to the online form and displays the results.

=head1 OPTIONS

=over

=item B<--from> I<city> I<stop>

Departure place

=item B<--to> I<city> I<stop>

Arrival place

=item B<--via> I<city> I<stop>

Travel via this place

In case you want I<stop> to be an address or "point of interest", you can set
it to 'addr:something' or 'poi:something'.

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

Journey start time

=item B<-a>|B<--arrive> I<hh>:I<mm>

Journey end time (overrides --time/--depart)

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

Journey date

=item B<-b>|B<--bike>

Choose connections allowing to carry a bike

=item B<-e>|B<--exclude> I<transports>

Exclude I<transports> (comma separated list).

Possible transports: zug, s-bahn, u-bahn, stadtbahn, tram, stadtbus, regionalbus,
schnellbus, seilbahn, schiff, ast, sonstige

=item B<-m>|B<--max-change> I<number>

Print connections with at most I<number> interchanges

=item B<-P>|B<--prefer> I<type>

Prefer connections of I<type>:

=over

=item * speed (default)

The faster, the better

=item * nowait

Prefer connections with less interchanges

=item * nowalk

Prefer connections with less walking (at interchanges)

=back

=item B<-p>|B<--proximity>

Take stops close to the stop/start into account and possibly use them instead

=item B<-i>|B<--include> I<type>

Include connections using trains of type I<type>, where I<type> may be:

=over

=item * local (default)

only take local trains ("Verbund-/Nahverkehrslinien"). Slow, but the cheapest
method if you're not travelling long distance

=item * ic

Local trains + IC

=item * ice

All trains (local + IC + ICE)

=back

=item B<-w>|B<--walk-speed> I<speed>

Set your walking speed to I<speed>.
Accepted values: normal (default), fast, slow

=item B<-I>|B<--ignore-info> [ I<regex> ]

Ignore additional information matching I<regex> (default: /Fahrradmitnahme/)

If I<regex> is not supplied, removes the default regex (-E<gt> nothing will be ignored)

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

Set timeout for HTTP requests. Default: 60 seconds.

=item B<--post> I<key>=I<value>

Add I<key> with I<value> to the HTTP POST request sent to the EFA server.
This can be used to use setting B<efa> does not yet cover, like
C<--post lineRestriction=400> to also show IC and ICE trains.
Note that B<--post> will be overridden by the standard efa options, such as
B<--time>

=item B<-v>|B<--version>

Print version information

=back

=head1 EXIT STATUS

    0    Everything went well
    1    Ambiguous input, re-run efa with different arguments
    2    efa.vrr.de error (i.e. unable to find matching connections)
    3    efa.vrr.de error (usually invalid input data)
    255  Any other kind of error

=head1 CONFIGURATION

None.

=head1 DEPENDENCIES

This script requires perl 5.10 (or higher) with the modules
WWW::Mechanize and XML::LibXML.

=head1 BUGS AND LIMITATIONS

B<efa> cannot handle Unicode in its arguments, so use plain ASCII.

The Parser is quite new and may not yet cover all corner cases, use with
caution.

=head1 AUTHOR

Copyright (C) 2009,2010 by Daniel Friesel E<lt>derf@derf.homelinux.orgE<gt>

=head1 LICENSE

  0. You just DO WHAT THE FUCK YOU WANT TO.