diff options
Diffstat (limited to 'lib/Travel/Status/DE')
| -rw-r--r-- | lib/Travel/Status/DE/DeutscheBahn.pm | 333 | ||||
| -rw-r--r-- | lib/Travel/Status/DE/DeutscheBahn/Result.pm | 365 | ||||
| -rw-r--r-- | lib/Travel/Status/DE/HAFAS.pm | 346 | ||||
| -rw-r--r-- | lib/Travel/Status/DE/HAFAS/Result.pm | 277 |
4 files changed, 642 insertions, 679 deletions
diff --git a/lib/Travel/Status/DE/DeutscheBahn.pm b/lib/Travel/Status/DE/DeutscheBahn.pm index 94af401..edec8fe 100644 --- a/lib/Travel/Status/DE/DeutscheBahn.pm +++ b/lib/Travel/Status/DE/DeutscheBahn.pm @@ -4,258 +4,16 @@ use strict; use warnings; use 5.010; -no if $] >= 5.018, warnings => "experimental::smartmatch"; - -use Carp qw(confess); -use LWP::UserAgent; -use POSIX qw(strftime); -use Travel::Status::DE::DeutscheBahn::Result; -use XML::LibXML; +use parent 'Travel::Status::DE::HAFAS'; our $VERSION = '1.05'; sub new { - my ( $obj, %conf ) = @_; - my $date = strftime( '%d.%m.%Y', localtime(time) ); - my $time = strftime( '%H:%M', localtime(time) ); - - my %lwp_options = %{ $conf{lwp_options} // { timeout => 10 } }; - - my $ua = LWP::UserAgent->new(%lwp_options); - - $ua->env_proxy; - - my $reply; - - my $lang = $conf{language} // 'd'; - - if ( not $conf{station} ) { - confess('You need to specify a station'); - } - - my $ref = { - mot_filter => [ - $conf{mot}->{ice} // 1, - $conf{mot}->{ic_ec} // 1, - $conf{mot}->{d} // 1, - $conf{mot}->{nv} // 1, - $conf{mot}->{s} // 1, - $conf{mot}->{bus} // 0, - $conf{mot}->{ferry} // 0, - $conf{mot}->{u} // 0, - $conf{mot}->{tram} // 0, - ], - post => { - advancedProductMode => q{}, - input => $conf{station}, - date => $conf{date} || $date, - time => $conf{time} || $time, - REQTrain_name => q{}, - start => 'yes', - boardType => $conf{mode} // 'dep', - - # L => 'vs_java3', - }, - }; - - for my $i ( 0 .. @{ $ref->{mot_filter} } ) { - if ( $ref->{mot_filter}->[$i] ) { - $ref->{post}->{"GUIREQProduct_$i"} = 'on'; - } - } - - bless( $ref, $obj ); + my ( $class, %opt ) = @_; - $reply - = $ua->post( - "http://reiseauskunft.bahn.de/bin/bhftafel.exe/${lang}n?rt=1", - $ref->{post} ); + $opt{service} = 'deutschebahn'; - if ( $reply->is_error ) { - $ref->{errstr} = $reply->status_line(); - return $ref; - } - - $ref->{html} = $reply->content; - - $ref->{tree} = XML::LibXML->load_html( - string => $ref->{html}, - recover => 2, - suppress_errors => 1, - suppress_warnings => 1, - ); - - $ref->check_input_error(); - - return $ref; -} - -sub new_from_html { - my ( $obj, %opt ) = @_; - - my $ref = { - html => $opt{html}, - post => { boardType => $opt{mode} // 'dep' } - }; - - $ref->{post}->{boardType} = $opt{mode} // 'dep'; - - $ref->{tree} = XML::LibXML->load_html( - string => $ref->{html}, - recover => 2, - suppress_errors => 1, - suppress_warnings => 1, - ); - - return bless( $ref, $obj ); -} - -sub check_input_error { - my ($self) = @_; - - my $xp_errdiv = XML::LibXML::XPathExpression->new( - '//div[@class = "errormsg leftMargin"]'); - my $xp_opts - = XML::LibXML::XPathExpression->new('//select[@class = "error"]'); - my $xp_values = XML::LibXML::XPathExpression->new('./option'); - - my $e_errdiv = ( $self->{tree}->findnodes($xp_errdiv) )[0]; - my $e_opts = ( $self->{tree}->findnodes($xp_opts) )[0]; - - if ($e_errdiv) { - $self->{errstr} = $e_errdiv->textContent; - - if ($e_opts) { - my @nodes = ( $e_opts->findnodes($xp_values) ); - $self->{errstr} - .= join( q{}, map { "\n" . $_->textContent } @nodes ); - } - } - - return; -} - -sub errstr { - my ($self) = @_; - - return $self->{errstr}; -} - -sub get_node { - my ( $parent, $name, $xpath, $index ) = @_; - $index //= 0; - - my @nodes = $parent->findnodes($xpath); - - if ( $#nodes < $index ) { - - # called by map, so we must explicitly return undef. - ## no critic (Subroutines::ProhibitExplicitReturnUndef) - return undef; - } - - my $node = $nodes[$index]; - - return $node->textContent; -} - -sub results { - my ($self) = @_; - my $mode = $self->{post}->{boardType}; - - my $xp_element = XML::LibXML::XPathExpression->new( - "//table[\@class = \"result stboard ${mode}\"]/tr"); - my $xp_train_more = XML::LibXML::XPathExpression->new('./td[3]/a'); - - # bhftafel.exe is not y2k1-safe - my $re_morelink = qr{ date = (?<date> .. [.] .. [.] .. ) }x; - - my @parts = ( - [ 'time', './td[@class="time"]' ], - [ 'train', './td[3]' ], - [ 'route', './td[@class="route"]' ], - [ 'dest', './td[@class="route"]//a' ], - [ 'platform', './td[@class="platform"]' ], - [ 'info', './td[@class="ris"]' ], - [ 'routeinfo', './td[@class="route"]//span[@class="red bold"]' ], - ); - - @parts = map { [ $_->[0], XML::LibXML::XPathExpression->new( $_->[1] ) ] } - @parts; - - my $re_via = qr{ - ^ \s* (?<stop> .+? ) \s* \n - (?<time> \d{1,2}:\d{1,2} ) - }mx; - - if ( defined $self->{results} ) { - return @{ $self->{results} }; - } - if ( not defined $self->{tree} ) { - return; - } - - $self->{results} = []; - - for my $tr ( @{ $self->{tree}->findnodes($xp_element) } ) { - - my @via; - my $first = 1; - my ( $time, $train, $route, $dest, $platform, $info, $routeinfo ) - = map { get_node( $tr, @{$_} ) } @parts; - my $e_train_more = ( $tr->findnodes($xp_train_more) )[0]; - - if ( not( $time and $dest ) ) { - next; - } - - $e_train_more->getAttribute('href') =~ $re_morelink; - - my $date = $+{date}; - - substr( $date, 6, 0 ) = '20'; - - $platform //= q{}; - $info //= q{}; - $routeinfo //= q{}; - - for my $str ( $time, $train, $dest, $platform, $info, $routeinfo ) { - $str =~ s/\n/ /mg; - $str =~ tr/ //s; - $str =~ s/^ +//; - $str =~ s/ +$//; - } - - while ( $route =~ m{$re_via}g ) { - if ($first) { - $first = 0; - next; - } - - if ( $+{stop} =~ m{ [(] Halt \s entf.llt [)] }ox ) { - next; - } - - push( @via, [ $+{time}, $+{stop} ] ); - } - - push( - @{ $self->{results} }, - Travel::Status::DE::DeutscheBahn::Result->new( - date => $date, - time => $time, - train => $train, - route_raw => $route, - route => \@via, - route_end => $dest, - platform => $platform, - info_raw => $info, - routeinfo_raw => $routeinfo, - ) - ); - } - - return @{ $self->{results} }; + return $class->SUPER::new(%opt); } 1; @@ -264,14 +22,14 @@ __END__ =head1 NAME -Travel::Status::DE::DeutscheBahn - Interface to the DeutscheBahn online -arrival/departure monitor +Travel::Status::DE::HAFAS - Interface to HAFAS-based online arrival/departure +monitors =head1 SYNOPSIS - use Travel::Status::DE::DeutscheBahn; + use Travel::Status::DE::HAFAS; - my $status = Travel::Status::DE::DeutscheBahn->new( + my $status = Travel::Status::DE::HAFAS->new( station => 'Essen Hbf', ); @@ -295,8 +53,8 @@ version 1.05 =head1 DESCRIPTION -Travel::Status::DE::DeutscheBahn is an interface to the DeutscheBahn -arrival/departure monitor available at +Travel::Status::DE::DeutscheBahn is an interface to the Deutsche Bahn +departure monitor available at L<http://reiseauskunft.bahn.de/bin/bhftafel.exe/dn>. It takes a station name and (optional) date and time and reports all arrivals @@ -310,67 +68,12 @@ unspecified). =item my $status = Travel::Status::DE::DeutscheBahn->new(I<%opts>) Requests the departures/arrivals as specified by I<opts> and returns a new -Travel::Status::DE::DeutscheBahn element with the results. Dies if the wrong +Travel::Status::DE::HAFAS element with the results. Dies if the wrong I<opts> were passed. -Supported I<opts> are: - -=over - -=item B<station> => I<station> - -The train station to report for, e.g. "Essen HBf" or -"Alfredusbad, Essen (Ruhr)". Mandatory. - -=item B<date> => I<dd>.I<mm>.I<yyyy> - -Date to report for. Defaults to the current day. - -=item B<language> => I<language> - -Set language for additional information. Accepted arguments: B<d>eutsch, -B<e>nglish, B<i>talian, B<n> (dutch). - -=item B<lwp_options> => I<\%hashref> - -Passed on to C<< LWP::UserAgent->new >>. Defaults to C<< { timeout => 10 } >>, -you can use an empty hashref to override it. - -=item B<time> => I<hh>:I<mm> - -Time to report for. Defaults to now. - -=item B<mode> => B<arr>|B<dep> - -By default, Travel::Status::DE::DeutscheBahn reports train departures -(B<dep>). Set this to B<arr> to get arrivals instead. - -=item B<mot> => I<\%hashref> - -Modes of transport to show. Accepted keys are: B<ice> (ICE trains), B<ic_ec> -(IC and EC trains), B<d> (InterRegio and similarly fast trains), B<nv> -("Nahverkehr", mostly RegionalExpress trains), B<s> ("S-Bahn"), B<bus>, -B<ferry>, B<u> ("U-Bahn") and B<tram>. - -Setting a mode (as hash key) to 1 includes it, 0 excludes it. undef leaves it -at the default. - -By default, the following are shown: ice, ic_ec, d, nv, s. - -=back - -=item $status->errstr - -In case of an error in the HTTP request, returns a string describing it. If -no error occurred, returns undef. - -=item $status->results - -Returns a list of arrivals/departures. Each list element is a -Travel::Status::DE::DeutscheBahn::Result(3pm) object. - -If no matching results were found or the parser / http request failed, returns -undef. +Calls Travel::Status::DE::HAFAS->new with service = DB. All I<opts> are passed +on. Please see Travel::Status::DE::HAFAS(3pm) for I<opts> documentation +and other methdos. =back @@ -386,21 +89,23 @@ None. =item * LWP::UserAgent(3pm) +=item * Travel::Status::DE::HAFAS(3pm) + =item * XML::LibXML(3pm) =back =head1 BUGS AND LIMITATIONS -There are a few character encoding issues. +Unknown. =head1 SEE ALSO -Travel::Status::DE::DeutscheBahn::Result(3pm). +Travel::Status::DE::HAFAS(3pm). =head1 AUTHOR -Copyright (C) 2011 by Daniel Friesel E<lt>derf@finalrewind.orgE<gt> +Copyright (C) 2015 by Daniel Friesel E<lt>derf@finalrewind.orgE<gt> =head1 LICENSE diff --git a/lib/Travel/Status/DE/DeutscheBahn/Result.pm b/lib/Travel/Status/DE/DeutscheBahn/Result.pm deleted file mode 100644 index be9ec18..0000000 --- a/lib/Travel/Status/DE/DeutscheBahn/Result.pm +++ /dev/null @@ -1,365 +0,0 @@ -package Travel::Status::DE::DeutscheBahn::Result; - -use strict; -use warnings; -use 5.010; - -no if $] >= 5.018, warnings => "experimental::smartmatch"; - -use parent 'Class::Accessor'; - -our $VERSION = '1.05'; - -Travel::Status::DE::DeutscheBahn::Result->mk_ro_accessors( - qw(date time train route_end route_raw platform info_raw routeinfo_raw)); - -sub new { - my ( $obj, %conf ) = @_; - - my $ref = \%conf; - - return bless( $ref, $obj ); -} - -sub destination { - my ($self) = @_; - - return $self->{route_end}; -} - -sub line { - my ($self) = @_; - - return $self->{train}; -} - -sub info { - my ($self) = @_; - - my $info = $self->info_raw; - - $info =~ s{ ,Grund }{}ox; - $info =~ s{ ^ \s+ }{}ox; - $info - =~ s{ (?: ^ | , ) (?: p.nktlich | [nk] [.] [Aa] [.] | on \s time ) }{}ox; - $info =~ s{ ^ , }{}ox; - - return $info; -} - -sub delay { - my ($self) = @_; - - my $info = $self->info_raw; - - if ( $info =~ m{ p.nktlich }ox ) { - return 0; - } - if ( $info =~ m{ (?: ca \. \s* )? \+ (?<delay> \d+) :? \s* }ox ) { - return $+{delay}; - } - - return; -} - -sub is_cancelled { - my ($self) = @_; - my $info = $self->info_raw; - - if ( $info =~ m{ Fahrt \s f.llt \s aus }ox ) { - return 1; - } - return 0; -} - -sub origin { - my ($self) = @_; - - return $self->{route_end}; -} - -sub route { - my ($self) = @_; - - my @stops = map { $_->[1] } @{ $self->{route} }; - return @stops; -} - -sub route_info { - my ($self) = @_; - - my $route_info = $self->routeinfo_raw; - - $route_info =~ s{ ^ [\s\n]+ }{}x; - $route_info =~ s{ [\s\n]+ $ }{}x; - - return $route_info; -} - -sub route_interesting { - my ( $self, $max_parts ) = @_; - - my @via = $self->route; - my ( @via_main, @via_show, $last_stop ); - $max_parts //= 3; - - for my $stop (@via) { - if ( $stop =~ m{ Hbf | Flughafen }ox ) { - push( @via_main, $stop ); - } - } - $last_stop = pop(@via); - - if ( @via_main and $via_main[-1] eq $last_stop ) { - pop(@via_main); - } - - if ( @via_main and @via and $via[0] eq $via_main[0] ) { - shift(@via_main); - } - - if ( @via < $max_parts ) { - @via_show = @via; - } - else { - if ( @via_main >= $max_parts ) { - @via_show = ( $via[0] ); - } - else { - @via_show = splice( @via, 0, $max_parts - @via_main ); - } - - while ( @via_show < $max_parts and @via_main ) { - my $stop = shift(@via_main); - if ( $stop ~~ \@via_show or $stop eq $last_stop ) { - next; - } - push( @via_show, $stop ); - } - } - - for (@via_show) { - s{ ?Hbf}{}; - } - - return @via_show; - -} - -sub route_timetable { - my ($self) = @_; - - return @{ $self->{route} }; -} - -sub TO_JSON { - my ($self) = @_; - - return { %{$self} }; -} - -sub type { - my ($self) = @_; - - # $self->{train} is either "TYPE 12345" or "TYPE12345" - my ($type) = ( $self->{train} =~ m{ ^ ([A-Z]+) }x ); - - return $type; -} - -1; - -__END__ - -=head1 NAME - -Travel::Status::DE::DeutscheBahn::Result - Information about a single -arrival/departure received by Travel::Status::DE::DeutscheBahn - -=head1 SYNOPSIS - - for my $departure ($status->results) { - printf( - "At %s: %s to %s from platform %s\n", - $departure->time, - $departure->line, - $departure->destination, - $departure->platform, - ); - } - - # or (depending on module setup) - for my $arrival ($status->results) { - printf( - "At %s: %s from %s on platform %s\n", - $arrival->time, - $arrival->line, - $arrival->origin, - $arrival->platform, - ); - } - -=head1 VERSION - -version 1.05 - -=head1 DESCRIPTION - -Travel::Status::DE::DeutscheBahn::Result describes a single arrival/departure -as obtained by Travel::Status::DE::DeutscheBahn. It contains information about -the platform, time, route and more. - -=head1 METHODS - -=head2 ACCESSORS - -=over - -=item $result->date - -Arrival/Departure date in "dd.mm.yyyy" format. - -=item $result->delay - -Returns the train's delay in minutes, or undef if it is unknown. - -=item $result->info - -Returns additional information, for instance the reason why the train is -delayed. May be an empty string if no (useful) information is available. - -=item $result->is_cancelled - -True if the train was cancelled, false otherwise. - -=item $result->line - -=item $result->train - -Returns the line name, either in a format like "S 1" (S-Bahn line 1) -or "RE 10111" (RegionalExpress train 10111, no line information). - -=item $result->platform - -Returns the platform from which the train will depart / at which it will -arrive. - -=item $result->route - -Returns a list of station names the train will pass between the selected -station and its origin/destination. - -=item $result->route_end - -Returns the last element of the route. Depending on how you set up -Travel::Status::DE::DeutscheBahn (arrival or departure listing), this is -either the train's destination or its origin station. - -=item $result->destination - -=item $result->origin - -Convenience aliases for $result->route_end. - -=item $result->route_interesting([I<max>]) - -Returns a list of up to I<max> (default: 3) interesting stations the train -will pass on its journey. Since deciding whether a station is interesting or -not is somewhat tricky, this feature should be considered experimental. - -The first element of the list is always the train's next stop. The following -elements contain as many main stations as possible, but there may also be -smaller stations if not enough main stations are available. - -In future versions, other factors may be taken into account as well. For -example, right now airport stations are usually not included in this list, -although they should be. - -Note that all main stations will be stripped of their "Hbf" suffix. - -=item $result->route_raw - -Returns the raw string used to create the route array. - -Note that cancelled stops are filtered from B<route>, but still present in -B<route_raw>. - -=item $result->route_timetable - -Similar to B<route>. however, this function returns a list of array -references of the form C<< [ arrival time, station name ] >>. - -=item $result->route_info - -Returns a string containing information related to the train's route, such as -"landslide between X and Y, expect delays". - -=item $result->time - -Returns the arrival/departure time as string in "hh:mm" format. - -=item $result->type - -Returns the type of this train, e.g. "S" for S-Bahn, "RE" for Regional Express -or "ICE" for InterCity-Express. - -=back - -=head2 INTERNAL - -=over - -=item $result = Travel::Status::DE::DeutscheBahn::Result->new(I<%data>) - -Returns a new Travel::Status::DE::DeutscheBahn::Result object. -You usually do not need to call this. - -Required I<data>: - -=over - -=item B<time> => I<hh:mm> - -=item B<train> => I<string> - -=item B<route_raw> => I<string> - -=item B<route> => I<arrayref> - -=item B<route_end> => I<string> - -=item B<platform> => I<string> - -=item B<info_raw> => I<string> - -=back - -=back - -=head1 DIAGNOSTICS - -None. - -=head1 DEPENDENCIES - -=over - -=item Class::Accessor(3pm) - -=back - -=head1 BUGS AND LIMITATIONS - -None known. - -=head1 SEE ALSO - -Travel::Status::DE::DeutscheBahn(3pm). - -=head1 AUTHOR - -Copyright (C) 2011 by Daniel Friesel E<lt>derf@finalrewind.orgE<gt> - -=head1 LICENSE - -This module is licensed under the same terms as Perl itself. diff --git a/lib/Travel/Status/DE/HAFAS.pm b/lib/Travel/Status/DE/HAFAS.pm new file mode 100644 index 0000000..d091f52 --- /dev/null +++ b/lib/Travel/Status/DE/HAFAS.pm @@ -0,0 +1,346 @@ +package Travel::Status::DE::HAFAS; + +use strict; +use warnings; +use 5.010; + +no if $] >= 5.018, warnings => "experimental::smartmatch"; + +use Carp qw(confess); +use LWP::UserAgent; +use POSIX qw(strftime); +use Travel::Status::DE::HAFAS::Result; +use XML::LibXML; + +our $VERSION = '1.05'; + +sub new { + my ( $obj, %conf ) = @_; + + my $date = $conf{date} // strftime( '%d.%m.%Y', localtime(time) ); + my $time = $conf{time} // strftime( '%H:%M', localtime(time) ); + my $lang = $conf{language} // 'd'; + my $mode = $conf{mode} // 'dep'; + my $service = $conf{service} // 'DB'; + + my %lwp_options = %{ $conf{lwp_options} // { timeout => 10 } }; + + my $ua = LWP::UserAgent->new(%lwp_options); + + $ua->env_proxy; + + my $reply; + + if ( not $conf{station} ) { + confess('You need to specify a station'); + } + + my $ref = { + active_service => $service, + developer_mode => $conf{developer_mode}, + post => { + input => $conf{station}, + date => $date, + time => $time, + start => 'yes', # value doesn't matter, just needs to be set + boardType => $mode, + L => 'vs_java3', + }, + service => { + DB => { + url => 'http://reiseauskunft.bahn.de/bin/bhftafel.exe', + name => 'Deutsche Bahn', + productbits => + [qw[ice ic_ec d nv s bus ferry u tram ondemand x x x x]], + } + }, + }; + + bless( $ref, $obj ); + + $ref->set_productfilter; + + my $url = $ref->{service}{$service}{url} . '/' . $lang . 'n'; + + $reply = $ua->post( $url, $ref->{post} ); + + if ( $reply->is_error ) { + $ref->{errstr} = $reply->status_line; + return $ref; + } + + # the interface does not return valid XML (but it's close!) + $ref->{raw_xml} + = '<?xml version="1.0" encoding="iso-8859-15"?><wrap>' + . $reply->content + . '</wrap>'; + + if ( $ref->{developer_mode} ) { + say $ref->{raw_xml}; + } + + $ref->{tree} = XML::LibXML->load_xml( + string => $ref->{raw_xml}, + + # recover => 2, + # suppress_errors => 1, + # suppress_warnings => 1, + ); + + if ( $ref->{developer_mode} ) { + say $ref->{tree}->toString(1); + } + + $ref->check_input_error; + return $ref; +} + +sub set_productfilter { + my ($self) = @_; + + my $service = $self->{active_service}; + + $self->{post}{productsFilter} + = '1' x ( scalar @{ $self->{service}{$service}{productbits} } ); +} + +sub check_input_error { + my ($self) = @_; + + my $xp_err = XML::LibXML::XPathExpression->new('//Err'); + my $err = ( $self->{tree}->findnodes($xp_err) )[0]; + + if ($err) { + $self->{errstr} + = $err->getAttribute('text') + . ' (code ' + . $err->getAttribute('code') . ')'; + } + + return; +} + +sub errstr { + my ($self) = @_; + + return $self->{errstr}; +} + +sub results { + my ($self) = @_; + my $mode = $self->{post}->{boardType}; + + my $xp_element = XML::LibXML::XPathExpression->new('//Journey'); + my $xp_msg = XML::LibXML::XPathExpression->new('./HIMMessage'); + + if ( defined $self->{results} ) { + return @{ $self->{results} }; + } + if ( not defined $self->{tree} ) { + return; + } + + $self->{results} = []; + + for my $tr ( @{ $self->{tree}->findnodes($xp_element) } ) { + + my @message_nodes = $tr->findnodes($xp_msg); + my $train = $tr->getAttribute('prod'); + my $time = $tr->getAttribute('fpTime'); + my $date = $tr->getAttribute('fpDate'); + my $dest = $tr->getAttribute('targetLoc'); + my $platform = $tr->getAttribute('platform'); + my $new_platform = $tr->getAttribute('newpl'); + my $delay = $tr->getAttribute('delay'); + my $e_delay = $tr->getAttribute('e_delay'); + my $info = $tr->getAttribute('delayReason'); + my $routeinfo = $tr->textContent; + my @messages; + + if ( not( $time and $dest ) ) { + next; + } + + for my $n (@message_nodes) { + push( @messages, $n->getAttribute('header') ); + } + + substr( $date, 6, 0 ) = '20'; + + $info //= q{}; + $routeinfo //= q{}; + + $train =~ s{#.*$}{}; + + push( + @{ $self->{results} }, + Travel::Status::DE::HAFAS::Result->new( + date => $date, + raw_delay => $delay, + raw_e_delay => $e_delay, + messages => \@messages, + time => $time, + train => $train, + route_end => $dest, + platform => $platform, + new_platform => $new_platform, + info => $info, + routeinfo_raw => $routeinfo, + ) + ); + } + + return @{ $self->{results} }; +} + +# static +sub get_services { +} + +1; + +__END__ + +=head1 NAME + +Travel::Status::DE::HAFAS - Interface to HAFAS-based online arrival/departure +monitors + +=head1 SYNOPSIS + + use Travel::Status::DE::HAFAS; + + my $status = Travel::Status::DE::HAFAS->new( + station => 'Essen Hbf', + ); + + if (my $err = $status->errstr) { + die("Request error: ${err}\n"); + } + + for my $departure ($status->results) { + printf( + "At %s: %s to %s from platform %s\n", + $departure->time, + $departure->line, + $departure->destination, + $departure->platform, + ); + } + +=head1 VERSION + +version 1.05 + +=head1 DESCRIPTION + +Travel::Status::DE::HAFAS is an interface to HAFAS-based +arrival/departure monitors, for instance the one available at +L<http://reiseauskunft.bahn.de/bin/bhftafel.exe/dn>. + +It takes a station name and (optional) date and time and reports all arrivals +or departures at that station starting at the specified point in time (now if +unspecified). + +=head1 METHODS + +=over + +=item my $status = Travel::Status::DE::HAFAS->new(I<%opts>) + +Requests the departures/arrivals as specified by I<opts> and returns a new +Travel::Status::DE::HAFAS element with the results. Dies if the wrong +I<opts> were passed. + +Supported I<opts> are: + +=over + +=item B<station> => I<station> + +The train station to report for, e.g. "Essen HBf" or +"Alfredusbad, Essen (Ruhr)". Mandatory. + +=item B<date> => I<dd>.I<mm>.I<yyyy> + +Date to report for. Defaults to the current day. + +=item B<language> => I<language> + +Set language for additional information. Accepted arguments: B<d>eutsch, +B<e>nglish, B<i>talian, B<n> (dutch). + +=item B<lwp_options> => I<\%hashref> + +Passed on to C<< LWP::UserAgent->new >>. Defaults to C<< { timeout => 10 } >>, +you can use an empty hashref to override it. + +=item B<time> => I<hh>:I<mm> + +Time to report for. Defaults to now. + +=item B<mode> => B<arr>|B<dep> + +By default, Travel::Status::DE::HAFAS reports train departures +(B<dep>). Set this to B<arr> to get arrivals instead. + +=item B<mot> => I<\%hashref> + +Modes of transport to show. Accepted keys are: B<ice> (ICE trains), B<ic_ec> +(IC and EC trains), B<d> (InterRegio and similarly fast trains), B<nv> +("Nahverkehr", mostly RegionalExpress trains), B<s> ("S-Bahn"), B<bus>, +B<ferry>, B<u> ("U-Bahn") and B<tram>. + +Setting a mode (as hash key) to 1 includes it, 0 excludes it. undef leaves it +at the default. + +By default, the following are shown: ice, ic_ec, d, nv, s. + +=back + +=item $status->errstr + +In case of an error in the HTTP request, returns a string describing it. If +no error occurred, returns undef. + +=item $status->results + +Returns a list of arrivals/departures. Each list element is a +Travel::Status::DE::HAFAS::Result(3pm) object. + +If no matching results were found or the parser / http request failed, returns +undef. + +=back + +=head1 DIAGNOSTICS + +None. + +=head1 DEPENDENCIES + +=over + +=item * Class::Accessor(3pm) + +=item * LWP::UserAgent(3pm) + +=item * XML::LibXML(3pm) + +=back + +=head1 BUGS AND LIMITATIONS + +Unknown. + +=head1 SEE ALSO + +Travel::Status::DE::HAFAS::Result(3pm). + +=head1 AUTHOR + +Copyright (C) 2015 by Daniel Friesel E<lt>derf@finalrewind.orgE<gt> + +=head1 LICENSE + +This module is licensed under the same terms as Perl itself. diff --git a/lib/Travel/Status/DE/HAFAS/Result.pm b/lib/Travel/Status/DE/HAFAS/Result.pm new file mode 100644 index 0000000..f2aee63 --- /dev/null +++ b/lib/Travel/Status/DE/HAFAS/Result.pm @@ -0,0 +1,277 @@ +package Travel::Status::DE::HAFAS::Result; + +use strict; +use warnings; +use 5.010; + +no if $] >= 5.018, warnings => 'experimental::smartmatch'; + +use parent 'Class::Accessor'; + +our $VERSION = '1.05'; + +Travel::Status::DE::HAFAS::Result->mk_ro_accessors( + qw(date info raw_e_delay raw_delay time train route_end info_raw)); + +sub new { + my ( $obj, %conf ) = @_; + + my $ref = \%conf; + + return bless( $ref, $obj ); +} + +sub delay { + my ($self) = @_; + + if ( defined $self->{raw_e_delay} ) { + return $self->{raw_e_delay}; + } + if ( defined $self->{raw_delay} + and $self->{raw_delay} ne q{-} + and $self->{raw_delay} ne 'cancel' ) + { + return $self->{raw_delay}; + } + return; +} + +sub destination { + my ($self) = @_; + + return $self->{route_end}; +} + +sub line { + my ($self) = @_; + + return $self->{train}; +} + +sub is_cancelled { + my ($self) = @_; + + if ( $self->{raw_delay} and $self->{raw_delay} eq 'cancel' ) { + return 1; + } + return 0; +} + +sub is_changed_platform { + my ($self) = @_; + + if ( defined $self->{new_platform} and defined $self->{platform} ) { + if ( $self->{new_platform} ne $self->{platform} ) { + return 1; + } + return 0; + } + if ( defined $self->{net_platform} ) { + return 1; + } + + return 0; +} + +sub messages { + my ($self) = @_; + + if ( $self->{messages} ) { + return @{ $self->{messages} }; + } + return; +} + +sub origin { + my ($self) = @_; + + return $self->{route_end}; +} + +sub platform { + my ($self) = @_; + + return $self->{new_platform} // $self->{platform}; +} + +sub TO_JSON { + my ($self) = @_; + + return { %{$self} }; +} + +sub type { + my ($self) = @_; + + # $self->{train} is either "TYPE 12345" or "TYPE12345" + my ($type) = ( $self->{train} =~ m{ ^ ([[:upper:]]+) }x ); + + return $type; +} + +1; + +__END__ + +=head1 NAME + +Travel::Status::DE::HAFAS::Result - Information about a single +arrival/departure received by Travel::Status::DE::HAFAS + +=head1 SYNOPSIS + + for my $departure ($status->results) { + printf( + "At %s: %s to %s from platform %s\n", + $departure->time, + $departure->line, + $departure->destination, + $departure->platform, + ); + } + + # or (depending on module setup) + for my $arrival ($status->results) { + printf( + "At %s: %s from %s on platform %s\n", + $arrival->time, + $arrival->line, + $arrival->origin, + $arrival->platform, + ); + } + +=head1 VERSION + +version 1.05 + +=head1 DESCRIPTION + +Travel::Status::DE::HAFAS::Result describes a single arrival/departure +as obtained by Travel::Status::DE::HAFAS. It contains information about +the platform, time, route and more. + +=head1 METHODS + +=head2 ACCESSORS + +=over + +=item $result->date + +Arrival/Departure date in "dd.mm.yyyy" format. + +=item $result->delay + +Returns the train's delay in minutes, or undef if it is unknown. +Also returns undef if the train has been cancelled. + +=item $result->info + +Returns additional information, for instance the most recent delay reason. +Returns an empty string if no (useful) information is available. + +=item $result->is_cancelled + +True if the train was cancelled, false otherwise. + +=item $result->is_changed_platform + +True if the platform (as returned by the B<platform> accessor) is not the +scheduled one. Note that the scheduled platform is unknown in this case. + +=item $result->messages + +Returns a list of message strings related to this train. Messages usually are +service notices (e.g. "missing carriage") or detailed delay reasons +(e.g. "switch damage between X and Y, expect delays"). + +=item $result->line + +=item $result->train + +Returns the line name, either in a format like "S 1" (S-Bahn line 1) +or "RE 10111" (RegionalExpress train 10111, no line information). + +=item $result->platform + +Returns the platform from which the train will depart / at which it will +arrive. Realtime data if available, schedule data otherwise. + +=item $result->route_end + +Returns the last element of the route. Depending on how you set up +Travel::Status::DE::HAFAS (arrival or departure listing), this is +either the train's destination or its origin station. + +=item $result->destination + +=item $result->origin + +Convenience aliases for C<< $result->route_end >>. + +=item $result->time + +Returns the arrival/departure time as string in "hh:mm" format. + +=item $result->type + +Returns the type of this train, e.g. "S" for S-Bahn, "RE" for Regional Express +or "ICE" for InterCity-Express. + +=back + +=head2 INTERNAL + +=over + +=item $result = Travel::Status::DE::HAFAS::Result->new(I<%data>) + +Returns a new Travel::Status::DE::HAFAS::Result object. +You usually do not need to call this. + +Required I<data>: + +=over + +=item B<time> => I<hh:mm> + +=item B<train> => I<string> + +=item B<route_end> => I<string> + +=item B<platform> => I<string> + +=item B<info_raw> => I<string> + +=back + +=back + +=head1 DIAGNOSTICS + +None. + +=head1 DEPENDENCIES + +=over + +=item Class::Accessor(3pm) + +=back + +=head1 BUGS AND LIMITATIONS + +None known. + +=head1 SEE ALSO + +Travel::Status::DE::HAFAS(3pm). + +=head1 AUTHOR + +Copyright (C) 2011 by Daniel Friesel E<lt>derf@finalrewind.orgE<gt> + +=head1 LICENSE + +This module is licensed under the same terms as Perl itself. |