Loading bin/dbris 0 → 100755 +367 −0 Original line number Diff line number Diff line #!perl use strict; use warnings; use 5.020; our $VERSION = '0.01'; use utf8; use DateTime; use Encode qw(decode); use JSON; use Getopt::Long qw(:config no_ignore_case); use List::Util qw(max); use Travel::Status::DE::DBRIS; use Travel::Routing::DE::DBRIS; my ( $date, $time, $from, $to ); my $mots; my $developer_mode; my ( $json_output, $raw_json_output ); my $use_cache = 1; my $cache; my @output; binmode( STDOUT, ':encoding(utf-8)' ); for my $arg (@ARGV) { $arg = decode( 'UTF-8', $arg ); } my $output_bold = -t STDOUT ? "\033[1m" : q{}; my $output_reset = -t STDOUT ? "\033[0m" : q{}; GetOptions( 'd|date=s' => \$date, 'h|help' => sub { show_help(0) }, 't|time=s' => \$time, 'V|version' => \&show_version, 'cache!' => \$use_cache, 'devmode' => \$developer_mode, 'json' => \$json_output, 'raw-json' => \$raw_json_output, ) or show_help(1); if ($use_cache) { my $cache_path = ( $ENV{XDG_CACHE_HOME} // "$ENV{HOME}/.cache" ) . '/Travel-Status-DE-DBRIS'; eval { require Cache::File; $cache = Cache::File->new( cache_root => $cache_path, default_expires => '90 seconds', lock_level => Cache::File::LOCK_LOCAL(), ); }; if ($@) { $cache = undef; } } my ( $from_raw, $to_raw ) = @ARGV; if ( not( $from_raw and $to_raw ) ) { show_help(1); } sub get_stop { my ($stop) = @_; my $ris = Travel::Status::DE::DBRIS->new( cache => $cache, locationSearch => $stop, developer_mode => $developer_mode, ); if ( my $err = $ris->errstr ) { say STDERR "Request error while looking up '${stop}': ${err}"; exit 2; } my $found; for my $result ( $ris->results ) { if ( defined $result->eva ) { return $result; } } say "Could not find stop '${stop}'"; exit 1; } my %opt = ( from => get_stop($from_raw), to => get_stop($to_raw), cache => $cache, developer_mode => $developer_mode, ); 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; } sub show_help { my ($code) = @_; print "Usage: dbris [-d dd.mm.yyyy] [-t hh:mm] <from> <to>\n" . "See also: man dbris-m\n"; exit $code; } sub show_version { say "dbris version ${VERSION}"; exit 0; } sub display_occupancy { my ($occupancy) = @_; if ( not $occupancy ) { return q{ }; } if ( $occupancy == 1 ) { return q{.}; } if ( $occupancy == 2 ) { return q{o}; } if ( $occupancy == 3 ) { return q{*}; } if ( $occupancy == 4 or $occupancy == 99 ) { return q{!}; } return q{?}; } sub format_occupancy { my ($stop) = @_; return display_occupancy( $stop->occupancy_first ) . display_occupancy( $stop->occupancy_second ); } sub format_delay { my ( $delay, $len ) = @_; if ( $delay and $len ) { return sprintf( "(%+${len}d)", $delay ); } return q{}; } my $ris = Travel::Routing::DE::DBRIS->new(%opt); if ( my $err = $ris->errstr ) { say STDERR "Request error: ${err}"; exit 2; } if ($raw_json_output) { say JSON->new->convert_blessed->encode( $ris->{raw_json} ); exit 0; } if ($json_output) { say JSON->new->convert_blessed->encode( [ $ris->connections ] ); exit 0; } for my $connection ( $ris->connections ) { my $header = q{}; for my $segment ( $connection->segments ) { $header .= sprintf( ' %s', $segment->train_short, ); } printf( "%s (%02d:%02d) %s %s%s\n\n", $connection->dep ? $connection->dep->strftime('%d.%m. %H:%M') : q{??.??. ??:??}, $connection->duration->in_units( 'hours', 'minutes' ), $connection->arr ? $connection->arr->strftime('%H:%M') : q{??:??}, format_occupancy($connection), $header, ); for my $segment ( $connection->segments ) { printf( "%s → %s\n", $segment->train_mid, $segment->direction ); printf( "%s ab %s\n", $segment->dep->strftime('%H:%M'), $segment->dep_name ); printf( "%s an %s\n", $segment->arr->strftime('%H:%M'), $segment->arr_name ); say q{}; } say q{---------------------------------------}; } __END__ =head1 NAME dbris - Interface to bahn.de public transit routing service =head1 SYNOPSIS B<dbris> [B<-d> I<DD.MM.YYYY>] [B<-t> I<HH:MM>] I<from-stop> I<to-stop> =head1 VERSION version 0.01 =head1 DESCRIPTION B<dbris-m> is an interface to the public transport services available on bahn.de. According to word of mouth, it uses the HAFAS backend that can also be accessed by Travel::Status::DE::HAFAS(3pm)'s DB service. However, the bahn.de entry point is likely more reliable in the long run. B<dbris-m> can serve as an arrival/departure monitor, request details about a specific trip, and look up public transport stops by name or geolocation. The operating mode depends on the contents of its non-option argument. =head2 Departure Monitor (I<station>) Show departures at I<station>. I<station> may be given as a station name or station ID. For each departure, B<dbris-m> shows =over =item * estimated departure time, =item * delay, if known, =item * trip name, number, or line, =item * direction / destination, and =item * platform, if known. =back =head2 Trip details (I<JourneyID>) List intermediate stops of I<JourneyID> (as given by the departure monitor when invoed with B<-j> / B<--with-jid>) with arrival/departure time, delay (if available), occupancy (if available), and stop name. Also includes some generic trip information. =head2 Location Search (B<?>I<query>|I<lat>B<:>I<lon>) List stations that match I<query> or that are located in the vicinity of I<lat>B<:>I<lon> geocoordinates with station ID and name. =head1 OPTIONS Values in brackets indicate options that only apply to the corresponding operating mode(s). =over =item B<-d>, B<--date> I<DD.MM.[YYYY]> (departure monitor) Request departures on the specified date. Default: today. =item B<-j>, B<--with-jid> (departure monitor) Show JourneyID for each listed arrival/departure. These can be used to obtain details on individual trips with subsequent B<dbris-m> invocations. =item B<--json> Print result(s) as JSON and exit. This is a dump of internal data structures and not guaranteed to remain stable between minor versions. Please use the Travel::Status::DE::DBRIS(3pm) module if you need a proper API. =item B<--no-cache> By default, if the Cache::File module is available, server replies are cached for 90 seconds in F<~/.cache/Travel-Status-DE-DBRIS> (or a path relative to C<$XDG_CACHE_HOME>, if set). Use this option to disable caching. You can use B<--cache> to re-enable it. =item B<--raw-json> Print unprocessed API response as JSON and exit. Useful for debugging and development purposes. =item B<-t>, B<--date> I<HH:MM> (departure monitor) Request departures on or after the specified 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 * DateTime(3pm) =item * LWP::UserAgent(3pm) =back =head1 BUGS AND LIMITATIONS =over =item * This module is very much work-in-progress =back =head1 AUTHOR Copyright (C) 2025 Birte Kristina Friesel E<lt>derf@finalrewind.orgE<gt> =head1 LICENSE This program is licensed under the same terms as Perl itself. lib/Travel/Routing/DE/DBRIS.pm 0 → 100644 +255 −0 Original line number Diff line number Diff line package Travel::Routing::DE::DBRIS; # vim:foldmethod=marker use strict; use warnings; use 5.020; use utf8; use parent 'Class::Accessor'; use Carp qw(confess); use DateTime; use DateTime::Format::Strptime; use Encode qw(decode encode); use JSON; use LWP::UserAgent; use Travel::Status::DE::DBRIS; use Travel::Routing::DE::DBRIS::Connection; our $VERSION = '0.01'; Travel::Routing::DE::DBRIS->mk_ro_accessors(qw(earlier later)); # {{{ Constructors sub new { my ( $obj, %conf ) = @_; my $service = $conf{service}; my $ua = $conf{user_agent}; if ( not $ua ) { my %lwp_options = %{ $conf{lwp_options} // { timeout => 10 } }; $ua = LWP::UserAgent->new(%lwp_options); $ua->env_proxy; } my $self = { developer_mode => $conf{developer_mode}, results => [], from => $conf{from}, to => $conf{to}, ua => $ua, }; bless( $self, $obj ); my $dt = $conf{datetime} // DateTime->now( time_zone => 'Europe/Berlin' ); my @mots = (qw(ICE EC_IC IR REGIONAL SBAHN BUS SCHIFF UBAHN TRAM ANRUFPFLICHTIG)); if ( $conf{modes_of_transit} ) { @mots = @{ $conf{modes_of_transit} // [] }; } my $req = { abfahrtsHalt => $conf{from}->id, ankunftsHalt => $conf{to}->id, anfrageZeitpunkt => $dt->strftime('%Y-%m-%dT%H:%M:00'), ankunftSuche => 'ABFAHRT', klasse => 'KLASSE_2', produktgattungen => \@mots, reisende => [ { typ => 'ERWACHSENER', ermaessigungen => [ { art => 'KEINE_ERMAESSIGUNG', klasse => 'KLASSENLOS' }, ], alter => [], anzahl => 1, } ], schnelleVerbindungen => \1, sitzplatzOnly => \0, bikeCarriage => \0, reservierungsKontingenteVorhanden => \0, nurDeutschlandTicketVerbindungen => \0, deutschlandTicketVorhanden => \0 }; $self->{strptime_obj} //= DateTime::Format::Strptime->new( pattern => '%Y-%m-%dT%H:%M:%S', time_zone => 'Europe/Berlin', ); $self->{strpdate_obj} //= DateTime::Format::Strptime->new( pattern => '%Y-%m-%d', time_zone => 'Europe/Berlin', ); my $json = $self->{json} = JSON->new->utf8; if ( $conf{async} ) { $self->{req} = $req; return $self; } if ( $conf{json} ) { $self->{raw_json} = $conf{json}; } else { my $req_str = $json->encode($req); if ( $self->{developer_mode} ) { say "requesting $req_str"; } my ( $content, $error ) = $self->post_with_cache( 'https://www.bahn.de/web/api/angebote/fahrplan', $req_str ); if ($error) { $self->{errstr} = $error; return $self; } if ( $self->{developer_mode} ) { say decode( 'utf-8', $content ); } $self->{raw_json} = $json->decode($content); $self->parse_connections; } return $self; } sub new_p { my ( $obj, %conf ) = @_; my $promise = $conf{promise}->new; if ( not( $conf{from} and $conf{to} ) ) { return $promise->reject('"from" and "to" opts are mandatory'); } my $self = $obj->new( %conf, async => 1 ); $self->{promise} = $conf{promise}; $self->post_with_cache_p( $self->{url} )->then( sub { my ($content) = @_; $self->{raw_json} = $self->{json}->decode($content); $self->parse_connections; $promise->resolve($self); return; } )->catch( sub { my ($err) = @_; $promise->reject( $err, $self ); return; } )->wait; return $promise; } # }}} # {{{ Internal Helpers sub post_with_cache { my ( $self, $url, $req ) = @_; my $cache = $self->{cache}; if ( $self->{developer_mode} ) { say "POST $url $req"; } if ($cache) { my $content = $cache->thaw($url); if ($content) { if ( $self->{developer_mode} ) { say ' cache hit'; } return ( ${$content}, undef ); } } if ( $self->{developer_mode} ) { say ' cache miss'; } my $reply = $self->{ua}->post( $url, Accept => 'application/json', 'Content-Type' => 'application/json; charset=utf-8', Origin => 'https://www.bahn.de', Referer => 'https://www.bahn.de/buchung/fahrplan/suche', 'Sec-Fetch-Dest' => 'empty', 'Sec-Fetch-Mode' => 'cors', 'Sec-Fetch-Site' => 'same-origin', TE => 'trailers', Content => $req, ); if ( $reply->is_error ) { say $reply->status_line; return ( undef, $reply->status_line ); } my $content = $reply->content; if ($cache) { $cache->freeze( $url, \$content ); } return ( $content, undef ); } sub post_with_cache_p { ...; } sub parse_connections { my ($self) = @_; my $json = $self->{raw_json}; $self->{earlier} = $json->{verbindungReference}{earlier}; $self->{later} = $json->{verbindungReference}{later}; for my $connection ( @{ $json->{verbindungen} // [] } ) { push( @{ $self->{connections} }, Travel::Routing::DE::DBRIS::Connection->new( json => $connection, strpdate_obj => $self->{strpdate_obj}, strptime_obj => $self->{strptime_obj} ) ); } } # }}} # {{{ Public Functions sub errstr { my ($self) = @_; return $self->{errstr}; } sub connections { my ($self) = @_; return @{ $self->{connections} }; } # }}} 1; lib/Travel/Routing/DE/DBRIS/Connection.pm 0 → 100644 +107 −0 Original line number Diff line number Diff line package Travel::Routing::DE::DBRIS::Connection; use strict; use warnings; use 5.020; use parent 'Class::Accessor'; use DateTime::Duration; use Travel::Routing::DE::DBRIS::Connection::Segment; our $VERSION = '0.01'; Travel::Routing::DE::DBRIS::Connection->mk_ro_accessors( qw(changes duration sched_duration rt_duration sched_dep rt_dep dep sched_arr rt_arr arr occupancy occupancy_first occupancy_second) ); sub new { my ( $obj, %opt ) = @_; my $json = $opt{json}; my $strpdate = $opt{strpdate_obj}; my $strptime = $opt{strptime_obj}; my $ref = { changes => $json->{umstiegsAnzahl}, id => $json->{tripId}, strptime_obj => $strptime, }; if ( my $d = $json->{verbindungsDauerInSeconds} ) { $ref->{sched_duration} = DateTime::Duration->new( hours => int( $d / 3600 ), minutes => int( ( $d % 3600 ) / 60 ), seconds => $d % 60, ); } if ( my $d = $json->{ezVerbindungsDauerInSeconds} ) { $ref->{rt_duration} = DateTime::Duration->new( hours => int( $d / 3600 ), minutes => int( ( $d % 3600 ) / 60 ), seconds => $d % 60, ); } $ref->{duration} = $ref->{rt_duration} // $ref->{sched_duration}; for my $occupancy ( @{ $json->{auslastungsmeldungen} // [] } ) { if ( $occupancy->{klasse} eq 'KLASSE_1' ) { $ref->{occupancy_first} = $occupancy->{stufe}; } if ( $occupancy->{klasse} eq 'KLASSE_2' ) { $ref->{occupancy_second} = $occupancy->{stufe}; } } if ( $ref->{occupancy_first} and $ref->{occupancy_second} ) { $ref->{occupancy} = ( $ref->{occupancy_first} + $ref->{occupancy_second} ) / 2; } elsif ( $ref->{occupancy_first} ) { $ref->{occupancy} = $ref->{occupancy_first}; } elsif ( $ref->{occupancy_second} ) { $ref->{occupancy} = $ref->{occupancy_second}; } for my $segment ( @{ $json->{verbindungsAbschnitte} // [] } ) { push( @{ $ref->{segments} }, Travel::Routing::DE::DBRIS::Connection::Segment->new( json => $segment, strptime_obj => $strptime ) ); } for my $key (qw(sched_dep rt_dep dep)) { $ref->{$key} = $ref->{segments}[0]{$key}; } for my $key (qw(sched_arr rt_arr arr)) { $ref->{$key} = $ref->{segments}[-1]{$key}; } bless( $ref, $obj ); return $ref; } sub segments { my ($self) = @_; return @{ $self->{segments} // [] }; } sub TO_JSON { my ($self) = @_; my $ret = { %{$self} }; return $ret; } 1; lib/Travel/Routing/DE/DBRIS/Connection/Segment.pm 0 → 100644 +79 −0 Original line number Diff line number Diff line package Travel::Routing::DE::DBRIS::Connection::Segment; use strict; use warnings; use 5.020; use parent 'Class::Accessor'; use DateTime::Duration; our $VERSION = '0.01'; Travel::Routing::DE::DBRIS::Connection::Segment->mk_ro_accessors( qw( dep_name dep_eva arr_name arr_eva train train_long train_mid train_short direction sched_dep rt_dep dep sched_arr rt_arr arr sched_duration rt_duration duration duration_percent journey_id ) ); sub new { my ( $obj, %opt ) = @_; my $json = $opt{json}; my $strptime = $opt{strptime_obj}; my $ref = { arr_eva => $json->{ankunftsOrtExtId}, arr_name => $json->{ankunftsOrt}, dep_eva => $json->{abfahrtsOrtExtId}, dep_name => $json->{abfahrtsOrt}, train => $json->{verkehrsmittel}{name}, train_short => $json->{verkehrsmittel}{kurzText}, train_mid => $json->{verkehrsmittel}{mittelText}, train_long => $json->{verkehrsmittel}{langText}, direction => $json->{verkehrsmittel}{richtung}, }; if ( my $ts = $json->{abfahrtsZeitpunkt} ) { $ref->{sched_dep} = $strptime->parse_datetime($ts); } if ( my $ts = $json->{ezAbfahrtsZeitpunkt} ) { $ref->{rt_dep} = $strptime->parse_datetime($ts); } $ref->{dep} = $ref->{rt_dep} // $ref->{sched_dep}; if ( my $ts = $json->{ankunftsZeitpunkt} ) { $ref->{sched_arr} = $strptime->parse_datetime($ts); } if ( my $ts = $json->{ezAnkunftsZeitpunkt} ) { $ref->{rt_arr} = $strptime->parse_datetime($ts); } $ref->{arr} = $ref->{rt_arr} // $ref->{sched_arr}; if ( my $d = $json->{abschnittsDauerInSeconds} ) { $ref->{sched_duration} = DateTime::Duration->new( hours => int( $d / 3600 ), minutes => int( ( $d % 3600 ) / 60 ), seconds => $d % 60, ); } if ( my $d = $json->{ezAbschnittsDauerInSeconds} ) { $ref->{rt_duration} = DateTime::Duration->new( hours => int( $d / 3600 ), minutes => int( ( $d % 3600 ) / 60 ), seconds => $d % 60, ); } $ref->{duration} = $ref->{rt_duration} // $ref->{sched_duration}; bless( $ref, $obj ); return $ref; } 1; Loading
bin/dbris 0 → 100755 +367 −0 Original line number Diff line number Diff line #!perl use strict; use warnings; use 5.020; our $VERSION = '0.01'; use utf8; use DateTime; use Encode qw(decode); use JSON; use Getopt::Long qw(:config no_ignore_case); use List::Util qw(max); use Travel::Status::DE::DBRIS; use Travel::Routing::DE::DBRIS; my ( $date, $time, $from, $to ); my $mots; my $developer_mode; my ( $json_output, $raw_json_output ); my $use_cache = 1; my $cache; my @output; binmode( STDOUT, ':encoding(utf-8)' ); for my $arg (@ARGV) { $arg = decode( 'UTF-8', $arg ); } my $output_bold = -t STDOUT ? "\033[1m" : q{}; my $output_reset = -t STDOUT ? "\033[0m" : q{}; GetOptions( 'd|date=s' => \$date, 'h|help' => sub { show_help(0) }, 't|time=s' => \$time, 'V|version' => \&show_version, 'cache!' => \$use_cache, 'devmode' => \$developer_mode, 'json' => \$json_output, 'raw-json' => \$raw_json_output, ) or show_help(1); if ($use_cache) { my $cache_path = ( $ENV{XDG_CACHE_HOME} // "$ENV{HOME}/.cache" ) . '/Travel-Status-DE-DBRIS'; eval { require Cache::File; $cache = Cache::File->new( cache_root => $cache_path, default_expires => '90 seconds', lock_level => Cache::File::LOCK_LOCAL(), ); }; if ($@) { $cache = undef; } } my ( $from_raw, $to_raw ) = @ARGV; if ( not( $from_raw and $to_raw ) ) { show_help(1); } sub get_stop { my ($stop) = @_; my $ris = Travel::Status::DE::DBRIS->new( cache => $cache, locationSearch => $stop, developer_mode => $developer_mode, ); if ( my $err = $ris->errstr ) { say STDERR "Request error while looking up '${stop}': ${err}"; exit 2; } my $found; for my $result ( $ris->results ) { if ( defined $result->eva ) { return $result; } } say "Could not find stop '${stop}'"; exit 1; } my %opt = ( from => get_stop($from_raw), to => get_stop($to_raw), cache => $cache, developer_mode => $developer_mode, ); 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; } sub show_help { my ($code) = @_; print "Usage: dbris [-d dd.mm.yyyy] [-t hh:mm] <from> <to>\n" . "See also: man dbris-m\n"; exit $code; } sub show_version { say "dbris version ${VERSION}"; exit 0; } sub display_occupancy { my ($occupancy) = @_; if ( not $occupancy ) { return q{ }; } if ( $occupancy == 1 ) { return q{.}; } if ( $occupancy == 2 ) { return q{o}; } if ( $occupancy == 3 ) { return q{*}; } if ( $occupancy == 4 or $occupancy == 99 ) { return q{!}; } return q{?}; } sub format_occupancy { my ($stop) = @_; return display_occupancy( $stop->occupancy_first ) . display_occupancy( $stop->occupancy_second ); } sub format_delay { my ( $delay, $len ) = @_; if ( $delay and $len ) { return sprintf( "(%+${len}d)", $delay ); } return q{}; } my $ris = Travel::Routing::DE::DBRIS->new(%opt); if ( my $err = $ris->errstr ) { say STDERR "Request error: ${err}"; exit 2; } if ($raw_json_output) { say JSON->new->convert_blessed->encode( $ris->{raw_json} ); exit 0; } if ($json_output) { say JSON->new->convert_blessed->encode( [ $ris->connections ] ); exit 0; } for my $connection ( $ris->connections ) { my $header = q{}; for my $segment ( $connection->segments ) { $header .= sprintf( ' %s', $segment->train_short, ); } printf( "%s (%02d:%02d) %s %s%s\n\n", $connection->dep ? $connection->dep->strftime('%d.%m. %H:%M') : q{??.??. ??:??}, $connection->duration->in_units( 'hours', 'minutes' ), $connection->arr ? $connection->arr->strftime('%H:%M') : q{??:??}, format_occupancy($connection), $header, ); for my $segment ( $connection->segments ) { printf( "%s → %s\n", $segment->train_mid, $segment->direction ); printf( "%s ab %s\n", $segment->dep->strftime('%H:%M'), $segment->dep_name ); printf( "%s an %s\n", $segment->arr->strftime('%H:%M'), $segment->arr_name ); say q{}; } say q{---------------------------------------}; } __END__ =head1 NAME dbris - Interface to bahn.de public transit routing service =head1 SYNOPSIS B<dbris> [B<-d> I<DD.MM.YYYY>] [B<-t> I<HH:MM>] I<from-stop> I<to-stop> =head1 VERSION version 0.01 =head1 DESCRIPTION B<dbris-m> is an interface to the public transport services available on bahn.de. According to word of mouth, it uses the HAFAS backend that can also be accessed by Travel::Status::DE::HAFAS(3pm)'s DB service. However, the bahn.de entry point is likely more reliable in the long run. B<dbris-m> can serve as an arrival/departure monitor, request details about a specific trip, and look up public transport stops by name or geolocation. The operating mode depends on the contents of its non-option argument. =head2 Departure Monitor (I<station>) Show departures at I<station>. I<station> may be given as a station name or station ID. For each departure, B<dbris-m> shows =over =item * estimated departure time, =item * delay, if known, =item * trip name, number, or line, =item * direction / destination, and =item * platform, if known. =back =head2 Trip details (I<JourneyID>) List intermediate stops of I<JourneyID> (as given by the departure monitor when invoed with B<-j> / B<--with-jid>) with arrival/departure time, delay (if available), occupancy (if available), and stop name. Also includes some generic trip information. =head2 Location Search (B<?>I<query>|I<lat>B<:>I<lon>) List stations that match I<query> or that are located in the vicinity of I<lat>B<:>I<lon> geocoordinates with station ID and name. =head1 OPTIONS Values in brackets indicate options that only apply to the corresponding operating mode(s). =over =item B<-d>, B<--date> I<DD.MM.[YYYY]> (departure monitor) Request departures on the specified date. Default: today. =item B<-j>, B<--with-jid> (departure monitor) Show JourneyID for each listed arrival/departure. These can be used to obtain details on individual trips with subsequent B<dbris-m> invocations. =item B<--json> Print result(s) as JSON and exit. This is a dump of internal data structures and not guaranteed to remain stable between minor versions. Please use the Travel::Status::DE::DBRIS(3pm) module if you need a proper API. =item B<--no-cache> By default, if the Cache::File module is available, server replies are cached for 90 seconds in F<~/.cache/Travel-Status-DE-DBRIS> (or a path relative to C<$XDG_CACHE_HOME>, if set). Use this option to disable caching. You can use B<--cache> to re-enable it. =item B<--raw-json> Print unprocessed API response as JSON and exit. Useful for debugging and development purposes. =item B<-t>, B<--date> I<HH:MM> (departure monitor) Request departures on or after the specified 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 * DateTime(3pm) =item * LWP::UserAgent(3pm) =back =head1 BUGS AND LIMITATIONS =over =item * This module is very much work-in-progress =back =head1 AUTHOR Copyright (C) 2025 Birte Kristina Friesel E<lt>derf@finalrewind.orgE<gt> =head1 LICENSE This program is licensed under the same terms as Perl itself.
lib/Travel/Routing/DE/DBRIS.pm 0 → 100644 +255 −0 Original line number Diff line number Diff line package Travel::Routing::DE::DBRIS; # vim:foldmethod=marker use strict; use warnings; use 5.020; use utf8; use parent 'Class::Accessor'; use Carp qw(confess); use DateTime; use DateTime::Format::Strptime; use Encode qw(decode encode); use JSON; use LWP::UserAgent; use Travel::Status::DE::DBRIS; use Travel::Routing::DE::DBRIS::Connection; our $VERSION = '0.01'; Travel::Routing::DE::DBRIS->mk_ro_accessors(qw(earlier later)); # {{{ Constructors sub new { my ( $obj, %conf ) = @_; my $service = $conf{service}; my $ua = $conf{user_agent}; if ( not $ua ) { my %lwp_options = %{ $conf{lwp_options} // { timeout => 10 } }; $ua = LWP::UserAgent->new(%lwp_options); $ua->env_proxy; } my $self = { developer_mode => $conf{developer_mode}, results => [], from => $conf{from}, to => $conf{to}, ua => $ua, }; bless( $self, $obj ); my $dt = $conf{datetime} // DateTime->now( time_zone => 'Europe/Berlin' ); my @mots = (qw(ICE EC_IC IR REGIONAL SBAHN BUS SCHIFF UBAHN TRAM ANRUFPFLICHTIG)); if ( $conf{modes_of_transit} ) { @mots = @{ $conf{modes_of_transit} // [] }; } my $req = { abfahrtsHalt => $conf{from}->id, ankunftsHalt => $conf{to}->id, anfrageZeitpunkt => $dt->strftime('%Y-%m-%dT%H:%M:00'), ankunftSuche => 'ABFAHRT', klasse => 'KLASSE_2', produktgattungen => \@mots, reisende => [ { typ => 'ERWACHSENER', ermaessigungen => [ { art => 'KEINE_ERMAESSIGUNG', klasse => 'KLASSENLOS' }, ], alter => [], anzahl => 1, } ], schnelleVerbindungen => \1, sitzplatzOnly => \0, bikeCarriage => \0, reservierungsKontingenteVorhanden => \0, nurDeutschlandTicketVerbindungen => \0, deutschlandTicketVorhanden => \0 }; $self->{strptime_obj} //= DateTime::Format::Strptime->new( pattern => '%Y-%m-%dT%H:%M:%S', time_zone => 'Europe/Berlin', ); $self->{strpdate_obj} //= DateTime::Format::Strptime->new( pattern => '%Y-%m-%d', time_zone => 'Europe/Berlin', ); my $json = $self->{json} = JSON->new->utf8; if ( $conf{async} ) { $self->{req} = $req; return $self; } if ( $conf{json} ) { $self->{raw_json} = $conf{json}; } else { my $req_str = $json->encode($req); if ( $self->{developer_mode} ) { say "requesting $req_str"; } my ( $content, $error ) = $self->post_with_cache( 'https://www.bahn.de/web/api/angebote/fahrplan', $req_str ); if ($error) { $self->{errstr} = $error; return $self; } if ( $self->{developer_mode} ) { say decode( 'utf-8', $content ); } $self->{raw_json} = $json->decode($content); $self->parse_connections; } return $self; } sub new_p { my ( $obj, %conf ) = @_; my $promise = $conf{promise}->new; if ( not( $conf{from} and $conf{to} ) ) { return $promise->reject('"from" and "to" opts are mandatory'); } my $self = $obj->new( %conf, async => 1 ); $self->{promise} = $conf{promise}; $self->post_with_cache_p( $self->{url} )->then( sub { my ($content) = @_; $self->{raw_json} = $self->{json}->decode($content); $self->parse_connections; $promise->resolve($self); return; } )->catch( sub { my ($err) = @_; $promise->reject( $err, $self ); return; } )->wait; return $promise; } # }}} # {{{ Internal Helpers sub post_with_cache { my ( $self, $url, $req ) = @_; my $cache = $self->{cache}; if ( $self->{developer_mode} ) { say "POST $url $req"; } if ($cache) { my $content = $cache->thaw($url); if ($content) { if ( $self->{developer_mode} ) { say ' cache hit'; } return ( ${$content}, undef ); } } if ( $self->{developer_mode} ) { say ' cache miss'; } my $reply = $self->{ua}->post( $url, Accept => 'application/json', 'Content-Type' => 'application/json; charset=utf-8', Origin => 'https://www.bahn.de', Referer => 'https://www.bahn.de/buchung/fahrplan/suche', 'Sec-Fetch-Dest' => 'empty', 'Sec-Fetch-Mode' => 'cors', 'Sec-Fetch-Site' => 'same-origin', TE => 'trailers', Content => $req, ); if ( $reply->is_error ) { say $reply->status_line; return ( undef, $reply->status_line ); } my $content = $reply->content; if ($cache) { $cache->freeze( $url, \$content ); } return ( $content, undef ); } sub post_with_cache_p { ...; } sub parse_connections { my ($self) = @_; my $json = $self->{raw_json}; $self->{earlier} = $json->{verbindungReference}{earlier}; $self->{later} = $json->{verbindungReference}{later}; for my $connection ( @{ $json->{verbindungen} // [] } ) { push( @{ $self->{connections} }, Travel::Routing::DE::DBRIS::Connection->new( json => $connection, strpdate_obj => $self->{strpdate_obj}, strptime_obj => $self->{strptime_obj} ) ); } } # }}} # {{{ Public Functions sub errstr { my ($self) = @_; return $self->{errstr}; } sub connections { my ($self) = @_; return @{ $self->{connections} }; } # }}} 1;
lib/Travel/Routing/DE/DBRIS/Connection.pm 0 → 100644 +107 −0 Original line number Diff line number Diff line package Travel::Routing::DE::DBRIS::Connection; use strict; use warnings; use 5.020; use parent 'Class::Accessor'; use DateTime::Duration; use Travel::Routing::DE::DBRIS::Connection::Segment; our $VERSION = '0.01'; Travel::Routing::DE::DBRIS::Connection->mk_ro_accessors( qw(changes duration sched_duration rt_duration sched_dep rt_dep dep sched_arr rt_arr arr occupancy occupancy_first occupancy_second) ); sub new { my ( $obj, %opt ) = @_; my $json = $opt{json}; my $strpdate = $opt{strpdate_obj}; my $strptime = $opt{strptime_obj}; my $ref = { changes => $json->{umstiegsAnzahl}, id => $json->{tripId}, strptime_obj => $strptime, }; if ( my $d = $json->{verbindungsDauerInSeconds} ) { $ref->{sched_duration} = DateTime::Duration->new( hours => int( $d / 3600 ), minutes => int( ( $d % 3600 ) / 60 ), seconds => $d % 60, ); } if ( my $d = $json->{ezVerbindungsDauerInSeconds} ) { $ref->{rt_duration} = DateTime::Duration->new( hours => int( $d / 3600 ), minutes => int( ( $d % 3600 ) / 60 ), seconds => $d % 60, ); } $ref->{duration} = $ref->{rt_duration} // $ref->{sched_duration}; for my $occupancy ( @{ $json->{auslastungsmeldungen} // [] } ) { if ( $occupancy->{klasse} eq 'KLASSE_1' ) { $ref->{occupancy_first} = $occupancy->{stufe}; } if ( $occupancy->{klasse} eq 'KLASSE_2' ) { $ref->{occupancy_second} = $occupancy->{stufe}; } } if ( $ref->{occupancy_first} and $ref->{occupancy_second} ) { $ref->{occupancy} = ( $ref->{occupancy_first} + $ref->{occupancy_second} ) / 2; } elsif ( $ref->{occupancy_first} ) { $ref->{occupancy} = $ref->{occupancy_first}; } elsif ( $ref->{occupancy_second} ) { $ref->{occupancy} = $ref->{occupancy_second}; } for my $segment ( @{ $json->{verbindungsAbschnitte} // [] } ) { push( @{ $ref->{segments} }, Travel::Routing::DE::DBRIS::Connection::Segment->new( json => $segment, strptime_obj => $strptime ) ); } for my $key (qw(sched_dep rt_dep dep)) { $ref->{$key} = $ref->{segments}[0]{$key}; } for my $key (qw(sched_arr rt_arr arr)) { $ref->{$key} = $ref->{segments}[-1]{$key}; } bless( $ref, $obj ); return $ref; } sub segments { my ($self) = @_; return @{ $self->{segments} // [] }; } sub TO_JSON { my ($self) = @_; my $ret = { %{$self} }; return $ret; } 1;
lib/Travel/Routing/DE/DBRIS/Connection/Segment.pm 0 → 100644 +79 −0 Original line number Diff line number Diff line package Travel::Routing::DE::DBRIS::Connection::Segment; use strict; use warnings; use 5.020; use parent 'Class::Accessor'; use DateTime::Duration; our $VERSION = '0.01'; Travel::Routing::DE::DBRIS::Connection::Segment->mk_ro_accessors( qw( dep_name dep_eva arr_name arr_eva train train_long train_mid train_short direction sched_dep rt_dep dep sched_arr rt_arr arr sched_duration rt_duration duration duration_percent journey_id ) ); sub new { my ( $obj, %opt ) = @_; my $json = $opt{json}; my $strptime = $opt{strptime_obj}; my $ref = { arr_eva => $json->{ankunftsOrtExtId}, arr_name => $json->{ankunftsOrt}, dep_eva => $json->{abfahrtsOrtExtId}, dep_name => $json->{abfahrtsOrt}, train => $json->{verkehrsmittel}{name}, train_short => $json->{verkehrsmittel}{kurzText}, train_mid => $json->{verkehrsmittel}{mittelText}, train_long => $json->{verkehrsmittel}{langText}, direction => $json->{verkehrsmittel}{richtung}, }; if ( my $ts = $json->{abfahrtsZeitpunkt} ) { $ref->{sched_dep} = $strptime->parse_datetime($ts); } if ( my $ts = $json->{ezAbfahrtsZeitpunkt} ) { $ref->{rt_dep} = $strptime->parse_datetime($ts); } $ref->{dep} = $ref->{rt_dep} // $ref->{sched_dep}; if ( my $ts = $json->{ankunftsZeitpunkt} ) { $ref->{sched_arr} = $strptime->parse_datetime($ts); } if ( my $ts = $json->{ezAnkunftsZeitpunkt} ) { $ref->{rt_arr} = $strptime->parse_datetime($ts); } $ref->{arr} = $ref->{rt_arr} // $ref->{sched_arr}; if ( my $d = $json->{abschnittsDauerInSeconds} ) { $ref->{sched_duration} = DateTime::Duration->new( hours => int( $d / 3600 ), minutes => int( ( $d % 3600 ) / 60 ), seconds => $d % 60, ); } if ( my $d = $json->{ezAbschnittsDauerInSeconds} ) { $ref->{rt_duration} = DateTime::Duration->new( hours => int( $d / 3600 ), minutes => int( ( $d % 3600 ) / 60 ), seconds => $d % 60, ); } $ref->{duration} = $ref->{rt_duration} // $ref->{sched_duration}; bless( $ref, $obj ); return $ref; } 1;
