#!perl use strict; use warnings; use 5.014; our $VERSION = '3.01'; use DateTime; use Encode qw(decode); 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 $types = q{}; my $developer_mode; my ( $list_services, $service, $hafas_url ); my ( @excluded_mots, @exclusive_mots ); my @output; binmode( STDOUT, ':encoding(utf-8)' ); for my $arg (@ARGV) { $arg = decode( 'UTF-8', $arg ); } GetOptions( 'a|arrivals' => \$arrivals, 'd|date=s' => \$date, 'h|help' => sub { show_help(0) }, '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 %opt = ( excluded_mots => \@excluded_mots, exclusive_mots => \@exclusive_mots, station => shift || show_help(1), arrivals => $arrivals, developer_mode => $developer_mode, service => $service, url => $hafas_url, ); 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} ); } else { say "--time must be specified as HH:MM"; exit 1; } } $opt{datetime} = $dt; } my $status = Travel::Status::DE::HAFAS->new(%opt); 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; if ( $types and $hafas_url ) { say STDERR 'The options -u and -m cannot be combined. Discarding -m'; return; } for my $type ( split( qr{,}, $types ) ) { if ( $type eq 'help' or $type eq 'list' or $type eq q{?} ) { if ( not $hafas_url ) { $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 = $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} ); } } return; } 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]; my $first_message = 1; for my $msg ( $d->messages ) { if ( $msg->ref_count == 1 ) { if ($first_message) { print "\n"; $first_message = 0; } if ( $msg->short ) { printf( "# %s\n", $msg->short ); } printf( "# %s\n", $msg->text ); } } printf( join( q{ }, ( map { "%-${_}s" } @line_length ) ), @{$line}[ 0 .. 4 ] ); if ( $line->[5] ) { print q{ } . $line->[5]; } print "\n"; } return; } if ( my $err = $status->errstr ) { say STDERR "Request error: ${err}"; if ( $status->errcode and ( $status->errcode eq 'H730' or $status->errcode eq 'LOCATION' ) ) { show_similar_stops(); } exit 2; } my $message_id = 1; for my $m ( $status->messages ) { if ( $m->ref_count > 1 ) { $m->{id} = $message_id++; if ( $m->short ) { printf( "# (%d) %s\n# %s\n\n", $m->{id}, $m->short, $m->text ); } else { printf( "# (%d) %s\n\n", $m->{id}, $m->text ); } } } for my $d ( $status->results ) { my $info_line = $d->info // q{}; for my $message ( $d->messages ) { if ( $message->ref_count > 1 ) { $info_line = sprintf( '(%d) %s', $message->{id}, $info_line ); } } push( @output, [ $d->sched_datetime->strftime('%H:%M'), $d->is_cancelled ? 'CANCELED' : ( $d->delay ? sprintf( '%+d', $d->delay ) : q{} ), $d->train, $d->route_end, ( $d->platform // q{} ) . ( $d->is_changed_platform ? ' !' : q{} ), $info_line, $d ] ); } display_result(@output); __END__ =head1 NAME hafas-m - Interface to the DeutscheBahn/HAFAS online departure monitor =head1 SYNOPSIS B<hafas-m> [B<-d> I<date>] [B<-t> I<time>] [B<-m> I<motlist>] [B<-s> I<service> | B<-u> I<url>] I<station> =head1 VERSION version 3.01 =head1 DESCRIPTION hafas-m is an interface to HAFAS-based departure monitors such as the one available at L<https://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. =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<--list> List known HAFAS installations. A HAFAS service from this list can be querie using B<--service>. Use B<--url> for HAFAS entrypoints not included in the list (and consider notifying me so I can include them in the next release). =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. This option is not available when the HAFAS entrypoint has been specified via B<--url>. =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>. 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 The non-default services (anything other than DB) are not well tested. =head1 AUTHOR Copyright (C) 2015-2020 by Daniel Friesel E<lt>derf@finalrewind.orgE<gt> =head1 LICENSE This program is licensed under the same terms as Perl itself.