summaryrefslogtreecommitdiff
path: root/bin/hafas
diff options
context:
space:
mode:
authorBirte Kristina Friesel <derf@finalrewind.org>2023-10-31 22:39:22 +0100
committerBirte Kristina Friesel <derf@finalrewind.org>2023-10-31 22:39:47 +0100
commitfd1ff5ad10e530661f59e3218dbf8ea97cfe4112 (patch)
tree23eee67b061188858a6da705a43b3a186e992400 /bin/hafas
initial commit
Diffstat (limited to 'bin/hafas')
-rwxr-xr-xbin/hafas357
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.