initial commit

1 files changed, 357 insertions, 0 deletions

diff --git a/bin/hafas b/bin/hafas
new file mode 100755
index 0000000..f77ddd6
--- /dev/null
+++ b/bin/hafas
@@ -0,0 +1,357 @@
+#!perl
+use strict;
+use warnings;
+use 5.014;
+
+our $VERSION = '0.00';
+
+use utf8;
+use DateTime;
+use Encode qw(decode);
+use JSON;
+use Getopt::Long    qw(:config no_ignore_case);
+use List::MoreUtils qw(uniq);
+use List::Util      qw(first max);
+use Travel::Routing::DE::HAFAS;
+
+my ( $date, $time, $language );
+my $types    = q{};
+my $developer_mode;
+my $json_output;
+my ( $list_services, $service );
+my ( @excluded_mots, @exclusive_mots );
+
+my @output;
+
+binmode( STDOUT, ':encoding(utf-8)' );
+for my $arg (@ARGV) {
+	$arg = decode( 'UTF-8', $arg );
+}
+
+GetOptions(
+	'd|date=s'     => \$date,
+	'h|help'       => sub { show_help(0) },
+	'l|language=s' => \$language,
+	'm|mot=s'      => \$types,
+	's|service=s'  => \$service,
+	't|time=s'     => \$time,
+	'V|version'    => \&show_version,
+	'devmode'      => \$developer_mode,
+	'json'         => \$json_output,
+	'list'         => \$list_services,
+
+) or show_help(1);
+
+if ($list_services) {
+	printf( "%-40s %-14s %s\n\n", 'operator', 'abbr. (-s)', 'languages (-l)' );
+	for my $service ( Travel::Routing::DE::HAFAS::get_services() ) {
+		printf(
+			"%-40s %-14s %s\n",
+			@{$service}{qw(name shortname)},
+			join( q{ }, @{ $service->{languages} // [] } )
+		);
+	}
+	exit 0;
+}
+
+parse_mot_options();
+
+my ($from_stop, $to_stop) = @ARGV;
+
+if (not $from_stop and $to_stop) {
+	show_help(1);
+}
+
+my %opt = (
+	excluded_mots  => \@excluded_mots,
+	exclusive_mots => \@exclusive_mots,
+	from_stop      => $from_stop,
+	to_stop        => $to_stop,
+	developer_mode => $developer_mode,
+	service        => $service,
+	language       => $language,
+);
+
+if ( $date or $time ) {
+	my $dt = DateTime->now( time_zone => 'Europe/Berlin' );
+	if ($date) {
+		if ( $date
+			=~ m{ ^ (?<day> \d{1,2} ) [.] (?<month> \d{1,2} ) [.] (?<year> \d{4})? $ }x
+		  )
+		{
+			$dt->set(
+				day   => $+{day},
+				month => $+{month}
+			);
+			if ( $+{year} ) {
+				$dt->set( year => $+{year} );
+			}
+		}
+		else {
+			say "--date must be specified as DD.MM.[YYYY]";
+			exit 1;
+		}
+	}
+	if ($time) {
+		if ( $time =~ m{ ^ (?<hour> \d{1,2} ) : (?<minute> \d{1,2} ) $ }x ) {
+			$dt->set(
+				hour   => $+{hour},
+				minute => $+{minute},
+				second => 0,
+			);
+		}
+		else {
+			say "--time must be specified as HH:MM";
+			exit 1;
+		}
+	}
+	$opt{datetime} = $dt;
+}
+
+my $hafas = Travel::Routing::DE::HAFAS->new(%opt);
+
+sub show_help {
+	my ($code) = @_;
+
+	print 'Usage: hafas [-d <dd.mm.yyyy>] [-m <motlist>] [-t <time>] '
+	  . "<from> <to>\n"
+	  . "See also: man hafas\n";
+
+	exit $code;
+}
+
+sub show_version {
+	say "hafas version ${VERSION}";
+
+	exit 0;
+}
+
+sub parse_mot_options {
+
+	my $default_yes = 1;
+
+	for my $type ( split( qr{,}, $types ) ) {
+		if ( $type eq 'help' or $type eq 'list' or $type eq q{?} ) {
+			$service //= 'DB';
+			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 );
+		}
+	}
+	return;
+}
+
+sub show_similar_stops {
+	my @candidates = $hafas->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} );
+		}
+	}
+	return;
+}
+
+sub display_occupancy {
+	my ($occupancy) = @_;
+
+	if ( $occupancy == 1 ) {
+		return q{.};
+	}
+	if ( $occupancy == 2 ) {
+		return q{o};
+	}
+	if ( $occupancy == 3 ) {
+		return q{*};
+	}
+	if ( $occupancy == 4 ) {
+		return q{!};
+	}
+	return q{?};
+}
+
+sub display_occupancies {
+	my ($load) = @_;
+
+	if ($load and ($load->{FIRST} or $load->{SECOND})) {
+		return sprintf("[%1s%1s]", display_occupancy($load->{FIRST}), display_occupancy($load->{SECOND}));
+	}
+
+	return q{    };
+}
+
+sub format_delay {
+	my ($delay) = @_;
+	if ($delay) {
+		return sprintf('(%+4d)', $delay);
+	}
+	return q{};
+}
+
+if ( my $err = $hafas->errstr ) {
+	say STDERR "Request error: ${err}";
+	if ( $hafas->errcode
+		and ( $hafas->errcode eq 'H730' or $hafas->errcode eq 'LOCATION' ) )
+	{
+		show_similar_stops();
+	}
+	exit 2;
+}
+
+if ($json_output) {
+	say JSON->new->convert_blessed->encode( [ $hafas->results ] );
+	exit 0;
+}
+
+for my $res (@{$hafas->{results}}) {
+	printf("# %02d:%02d  %s\n", $res->duration->in_units('hours', 'minutes'), display_occupancies($res->load));
+	for my $msg ( $res->messages ) {
+		if ( $msg->short ) {
+			printf( "# %s\n", $msg->short );
+		}
+		printf( "# %s\n", $msg->text );
+	}
+
+	my $have_delay = 0;
+
+	for my $sec ($res->sections) {
+		if ($sec->dep_delay or $sec->arr_delay) {
+			$have_delay = 7;
+		}
+	}
+
+	for my $sec ($res->sections) {
+		if ($sec->type eq 'JNY') {
+			printf("%-5s %-${have_delay}s ab  %s\n", $sec->dep_datetime->strftime('%H:%M'), format_delay($sec->dep_delay), $sec->dep_loc->name);
+			printf("%10s%${have_delay}s %s → %s\n", q{}, q{}, $sec->name, $sec->direction);
+			printf("%-5s %-${have_delay}s an  %s\n", $sec->arr_datetime->strftime('%H:%M'), format_delay($sec->arr_delay), $sec->arr_loc->name);
+		}
+		elsif ($sec->type eq 'WALK') {
+			printf("%-5s %-${have_delay}s ab  %s\n", $sec->dep_datetime->strftime('%H:%M'), q{}, $sec->dep_loc->name);
+			printf("%10s%${have_delay}s Fußweg %dm (%02d:%02d)\n", q{}, q{}, $sec->distance, $sec->duration->in_units('hours', 'minutes'));
+			printf("%-5s %-${have_delay}s an  %s\n", $sec->arr_datetime->strftime('%H:%M'), q{}, $sec->arr_loc->name);
+		}
+		else {
+			printf("\n???\n");
+		}
+		say q{};
+	}
+	printf("\n%s\n\n", q{-} x 40);
+}
+
+__END__
+
+=head1 NAME
+
+hafas - Interface to the HAFAS (e.g. Deutsche Bahn) trip search
+
+=head1 SYNOPSIS
+
+B<hafas> [B<-d> I<date>] [B<-t> I<time>] [B<-m> I<motlist>]
+[B<-s> I<service>] [B<-l> I<language>] I<from> I<to>
+
+=head1 VERSION
+
+version 0.00
+
+=head1 DESCRIPTION
+
+tbd
+
+=head1 OPTIONS
+
+=over
+
+=item B<-d>, B<--date> I<dd>.I<mm>.[I<yyyy>]
+
+Planned departure (or arrival) date.  Default: today.
+
+=item B<--json>
+
+Print result(s) as JSON. This is a dump of internal data structures and not
+guaranteed to remain stable between minor versions. Please use the
+Travel::Routing::DE::HAFAS(3pm) module if you need a proper API.
+
+=item B<-l>, B<--language> I<language>
+
+Request free-text messages to be provided in I<language>.
+See B<--list> for a list of languages supported by individual HAFAS instances.
+Note that requesting an invalid/unsupported language may lead to garbage output.
+
+=item B<--list>
+
+List known HAFAS installations and exit. Use B<-s>|B<--service> to select an
+operator from this list for a HAFAS request.
+
+=item B<-m>, B<--mot> I<motlist>
+
+By default, B<hafas> considers all modes of transport for routing. 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>
+
+Use the API provided by I<service> for routing; defaults to DB (Deutsche Bahn).
+See B<--list> for a list of known services.
+
+=item B<-t>, B<--time> I<hh>:I<mm>
+
+Planned departure (or arrival) time.  Default: now.
+
+=item B<-V>, B<--version>
+
+Show version information and exit.
+
+=back
+
+=head1 EXIT STATUS
+
+0 upon success, 1 upon internal error, 2 upon backend error.
+
+=head1 CONFIGURATION
+
+None.
+
+=head1 DEPENDENCIES
+
+=over
+
+=item * Class::Accessor(3pm)
+
+=item * LWP::UserAgent(3pm)
+
+=back
+
+=head1 BUGS AND LIMITATIONS
+
+The non-default services (anything other than DB) are not well-tested.
+
+=head1 AUTHOR
+
+Copyright (C) 2023 by Birte Kristina Friesel E<lt>derf@finalrewind.orgE<gt>
+
+=head1 LICENSE
+
+This program is licensed under the same terms as Perl itself.