diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/Travel/Status/DE/EFA.pm | 1083 | ||||
| -rw-r--r-- | lib/Travel/Status/DE/EFA/Departure.pm | 528 | ||||
| -rw-r--r-- | lib/Travel/Status/DE/EFA/Info.pm | 127 | ||||
| -rw-r--r-- | lib/Travel/Status/DE/EFA/Line.pm | 8 | ||||
| -rw-r--r-- | lib/Travel/Status/DE/EFA/Result.pm | 330 | ||||
| -rw-r--r-- | lib/Travel/Status/DE/EFA/Services.pm.PL | 147 | ||||
| -rw-r--r-- | lib/Travel/Status/DE/EFA/Stop.pm | 133 | ||||
| -rw-r--r-- | lib/Travel/Status/DE/EFA/Trip.pm | 342 | ||||
| -rw-r--r-- | lib/Travel/Status/DE/VRR.pm | 11 |
9 files changed, 1874 insertions, 835 deletions
diff --git a/lib/Travel/Status/DE/EFA.pm b/lib/Travel/Status/DE/EFA.pm index d79f3d1..be08b9a 100644 --- a/lib/Travel/Status/DE/EFA.pm +++ b/lib/Travel/Status/DE/EFA.pm @@ -5,17 +5,63 @@ use warnings; use 5.010; use utf8; -no if $] >= 5.018, warnings => 'experimental::smartmatch'; - -our $VERSION = '1.17'; +our $VERSION = '3.13'; use Carp qw(confess cluck); +use DateTime; +use DateTime::Format::Strptime; use Encode qw(encode); +use JSON; +use Travel::Status::DE::EFA::Departure; +use Travel::Status::DE::EFA::Info; use Travel::Status::DE::EFA::Line; -use Travel::Status::DE::EFA::Result; +use Travel::Status::DE::EFA::Services; use Travel::Status::DE::EFA::Stop; +use Travel::Status::DE::EFA::Trip; use LWP::UserAgent; -use XML::LibXML; + +sub new_p { + my ( $class, %opt ) = @_; + my $promise = $opt{promise}->new; + + my $self; + + eval { $self = $class->new( %opt, async => 1 ); }; + if ($@) { + return $promise->reject($@); + } + + $self->{promise} = $opt{promise}; + + $self->post_with_cache_p->then( + sub { + my ($content) = @_; + $self->{response} = $self->{json}->decode($content); + + if ( $self->{developer_mode} ) { + say $self->{json}->pretty->encode( $self->{response} ); + } + + $self->check_for_ambiguous(); + + if ( $self->{errstr} ) { + $promise->reject( $self->{errstr}, $self ); + return; + } + + $promise->resolve($self); + return; + } + )->catch( + sub { + my ( $err, $self ) = @_; + $promise->reject($err); + return; + } + )->wait; + + return $promise; +} sub new { my ( $class, %opt ) = @_; @@ -25,22 +71,49 @@ sub new { delete $opt{timeout}; } - my $ua = LWP::UserAgent->new(%opt); - my @now = localtime( time() ); - - my @time = @now[ 2, 1 ]; - my @date = ( $now[3], $now[4] + 1, $now[5] + 1900 ); - - if ( not( $opt{place} and $opt{name} ) ) { - confess('You need to specify a place and a name'); + if ( + not( $opt{coord} + or $opt{name} + or $opt{stopfinder} + or $opt{stopseq} + or $opt{from_json} ) + ) + { + confess('You must specify a name'); } - if ( $opt{type} and not( $opt{type} ~~ [qw[stop address poi]] ) ) { - confess('type must be stop, address or poi'); + if ( $opt{type} + and not( $opt{type} =~ m{ ^ (?: stop | stopID | address | poi ) $ }x ) ) + { + confess('type must be stop, stopID, address, or poi'); } + if ( $opt{service} ) { + if ( my $service + = Travel::Status::DE::EFA::Services::get_service( $opt{service} ) ) + { + $opt{efa_url} = $service->{url}; + if ( $opt{coord} ) { + $opt{efa_url} .= '/XML_COORD_REQUEST'; + } + elsif ( $opt{stopfinder} ) { + $opt{efa_url} .= '/XML_STOPFINDER_REQUEST'; + } + elsif ( $opt{stopseq} ) { + $opt{efa_url} .= '/XML_STOPSEQCOORD_REQUEST'; + } + else { + $opt{efa_url} .= '/XML_DM_REQUEST'; + } + $opt{time_zone} //= $service->{time_zone}; + } + } + + $opt{time_zone} //= 'Europe/Berlin'; + if ( not $opt{efa_url} ) { - confess('efa_url is mandatory'); + confess('service or efa_url must be specified'); } + my $dt = $opt{datetime} // DateTime->now( time_zone => $opt{time_zone} ); ## no critic (RegularExpressions::ProhibitUnusedCapture) ## no critic (Variables::ProhibitPunctuationVars) @@ -48,7 +121,10 @@ sub new { if ( $opt{time} and $opt{time} =~ m{ ^ (?<hour> \d\d? ) : (?<minute> \d\d ) $ }x ) { - @time = @+{qw{hour minute}}; + $dt->set( + hour => $+{hour}, + minute => $+{minute} + ); } elsif ( $opt{time} ) { confess('Invalid time specified'); @@ -61,10 +137,17 @@ sub new { ) { if ( $+{year} ) { - @date = @+{qw{day month year}}; + $dt->set( + day => $+{day}, + month => $+{month}, + year => $+{year} + ); } else { - @date[ 0, 1 ] = @+{qw{day month}}; + $dt->set( + day => $+{day}, + month => $+{month} + ); } } elsif ( $opt{date} ) { @@ -72,43 +155,86 @@ sub new { } my $self = { - post => { - command => q{}, - deleteAssignedStops_dm => '1', - help => 'Hilfe', - itdDateDay => $date[0], - itdDateMonth => $date[1], - itdDateYear => $date[2], - itdLPxx_id_dm => ':dm', - itdLPxx_mapState_dm => q{}, - itdLPxx_mdvMap2_dm => q{}, - itdLPxx_mdvMap_dm => '3406199:401077:NAV3', - itdLPxx_transpCompany => 'vrr', - itdLPxx_view => q{}, - itdTimeHour => $time[0], - itdTimeMinute => $time[1], - language => 'de', - mode => 'direct', - nameInfo_dm => 'invalid', - nameState_dm => 'empty', - name_dm => encode( 'UTF-8', $opt{name} ), - outputFormat => 'XML', - placeInfo_dm => 'invalid', - placeState_dm => 'empty', - place_dm => encode( 'UTF-8', $opt{place} ), - ptOptionsActive => '1', - requestID => '0', - reset => 'neue Anfrage', - sessionID => '0', - submitButton => 'anfordern', - typeInfo_dm => 'invalid', - type_dm => $opt{type} // 'stop', - useProxFootSearch => '0', - useRealtime => '1', - }, + cache => $opt{cache}, + response => $opt{from_json}, developer_mode => $opt{developer_mode}, + efa_url => $opt{efa_url}, + service => $opt{service}, + strp_stopseq => DateTime::Format::Strptime->new( + pattern => '%Y%m%d %H:%M', + time_zone => $opt{time_zone}, + ), + strp_stopseq_s => DateTime::Format::Strptime->new( + pattern => '%Y%m%d %H:%M:%S', + time_zone => $opt{time_zone}, + ), + + json => JSON->new->utf8, }; + if ( $opt{coord} ) { + + # outputFormat => 'JSON' returns invalid JSON + $self->{post} = { + coord => sprintf( '%.7f:%.7f:%s', + $opt{coord}{lon}, $opt{coord}{lat}, 'WGS84[DD.ddddd]' ), + radius_1 => 1320, + type_1 => 'STOP', + coordListOutputFormat => 'list', + max => 30, + inclFilter => 1, + outputFormat => 'rapidJson', + }; + } + elsif ( $opt{stopfinder} ) { + + # filter: 2 (stop) | 4 (street) | 8 (address) | 16 (crossing) | 32 (poi) | 64 (postcod) + $self->{post} = { + locationServerActive => 1, + type_sf => 'any', + name_sf => $opt{stopfinder}{name}, + anyObjFilter_sf => 2, + coordOutputFormat => 'WGS84[DD.DDDDD]', + outputFormat => 'JSON', + }; + } + elsif ( $opt{stopseq} ) { + + # outputFormat => 'JSON' also works; leads to different output + $self->{post} = { + line => $opt{stopseq}{stateless}, + stop => $opt{stopseq}{stop_id}, + tripCode => $opt{stopseq}{key}, + date => $opt{stopseq}{date}, + time => $opt{stopseq}{time}, + coordOutputFormat => 'WGS84[DD.DDDDD]', + outputFormat => 'rapidJson', + useRealtime => '1', + }; + } + else { + $self->{post} = { + language => 'de', + mode => 'direct', + outputFormat => 'JSON', + type_dm => $opt{type} // 'stop', + useProxFootSearch => $opt{proximity_search} ? '1' : '0', + useRealtime => '1', + itdDateDay => $dt->day, + itdDateMonth => $dt->month, + itdDateYear => $dt->year, + itdTimeHour => $dt->hour, + itdTimeMinute => $dt->minute, + name_dm => encode( 'UTF-8', $opt{name} ), + }; + } + + if ( $opt{place} ) { + $self->{post}{placeInfo_dm} = 'invalid'; + $self->{post}{placeState_dm} = 'empty'; + $self->{post}{place_dm} = encode( 'UTF-8', $opt{place} ); + } + if ( $opt{full_routes} ) { $self->{post}->{depType} = 'stopEvents'; $self->{post}->{includeCompleteStopSeq} = 1; @@ -117,35 +243,46 @@ sub new { bless( $self, $class ); - $ua->env_proxy; + if ( $opt{user_agent} ) { + $self->{ua} = $opt{user_agent}; + } + else { + my %lwp_options = %{ $opt{lwp_options} // { timeout => 10 } }; + $self->{ua} = LWP::UserAgent->new(%lwp_options); + $self->{ua}->env_proxy; + } - my $response = $ua->post( $opt{efa_url}, $self->{post} ); + if ( $self->{cache} ) { + $self->{cache_key} + = $self->{efa_url} . '?' + . join( '&', + map { $_ . '=' . $self->{post}{$_} } sort keys %{ $self->{post} } ); + } - if ( $response->is_error ) { - $self->{errstr} = $response->status_line; + if ( $opt{async} ) { return $self; } - if ( $opt{efa_encoding} ) { - $self->{xml} = encode( $opt{efa_encoding}, $response->content ); - } - else { - $self->{xml} = $response->decoded_content; + if ( $self->{developer_mode} ) { + say 'POST ' . $self->{efa_url}; + while ( my ( $key, $value ) = each %{ $self->{post} } ) { + printf( "%30s = %s\n", $key, $value ); + } } - if ( not $self->{xml} ) { + if ( not $self->{response} ) { + my ( $response, $error ) = $self->post_with_cache; - # LibXML doesn't like empty documents - $self->{errstr} = 'Server returned nothing (empty result)'; - return $self; - } + if ($error) { + $self->{errstr} = $error; + return $self; + } - $self->{tree} = XML::LibXML->load_xml( - string => $self->{xml}, - ); + $self->{response} = $self->{json}->decode($response); + } if ( $self->{developer_mode} ) { - say $self->{tree}->toString(1); + say $self->{json}->pretty->encode( $self->{response} ); } $self->check_for_ambiguous(); @@ -153,18 +290,92 @@ sub new { return $self; } -sub new_from_xml { - my ( $class, %opt ) = @_; +sub post_with_cache { + my ($self) = @_; + my $cache = $self->{cache}; + my $url = $self->{efa_url}; - my $self = { - xml => $opt{xml}, - }; + if ( $self->{developer_mode} ) { + say 'POST ' . ( $self->{cache_key} // $url ); + } - $self->{tree} = XML::LibXML->load_xml( - string => $self->{xml}, - ); + if ($cache) { + my $content = $cache->thaw( $self->{cache_key} ); + 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, $self->{post} ); + + if ( $reply->is_error ) { + return ( undef, $reply->status_line ); + } + my $content = $reply->content; + + if ($cache) { + $cache->freeze( $self->{cache_key}, \$content ); + } - return bless( $self, $class ); + return ( $content, undef ); +} + +sub post_with_cache_p { + my ($self) = @_; + my $cache = $self->{cache}; + my $url = $self->{efa_url}; + + if ( $self->{developer_mode} ) { + say 'POST ' . ( $self->{cache_key} // $url ); + } + + my $promise = $self->{promise}->new; + + if ($cache) { + my $content = $cache->thaw( $self->{cache_key} ); + if ($content) { + if ( $self->{developer_mode} ) { + say ' cache hit'; + } + return $promise->resolve( ${$content} ); + } + } + + if ( $self->{developer_mode} ) { + say ' cache miss'; + } + + $self->{ua}->post_p( $url, form => $self->{post} )->then( + sub { + my ($tx) = @_; + if ( my $err = $tx->error ) { + $promise->reject( + "POST $url returned HTTP $err->{code} $err->{message}"); + return; + } + my $content = $tx->res->body; + if ($cache) { + $cache->freeze( $self->{cache_key}, \$content ); + } + $promise->resolve($content); + return; + } + )->catch( + sub { + my ($err) = @_; + $promise->reject($err); + return; + } + )->wait; + + return $promise; } sub errstr { @@ -191,322 +402,245 @@ sub place_candidates { return; } -sub sprintf_date { - my ($e) = @_; +sub check_for_ambiguous { + my ($self) = @_; + + my $json = $self->{response}; - if ( $e->getAttribute('day') == -1 ) { + if ( $json->{departureList} ) { return; } - return sprintf( '%02d.%02d.%d', - $e->getAttribute('day'), - $e->getAttribute('month'), - $e->getAttribute('year'), - ); -} - -sub sprintf_time { - my ($e) = @_; - - if ( $e->getAttribute('minute') == -1 ) { - return; + for my $m ( @{ $json->{dm}{message} // [] } ) { + if ( $m->{name} eq 'error' and $m->{value} eq 'name list' ) { + $self->{errstr} = "ambiguous name parameter"; + $self->{name_candidates} = []; + for my $point ( @{ $json->{dm}{points} // [] } ) { + my $place = $point->{ref}{place}; + push( + @{ $self->{name_candidates} }, + Travel::Status::DE::EFA::Stop->new( + place => $place, + full_name => $point->{name}, + name => $point->{name} =~ s{\Q$place\E,? ?}{}r, + id_num => $point->{ref}{id}, + ) + ); + } + return; + } + if ( $m->{name} eq 'error' and $m->{value} eq 'place list' ) { + $self->{errstr} = "ambiguous name parameter"; + $self->{place_candidates} = []; + for my $point ( @{ $json->{dm}{points} // [] } ) { + my $place = $point->{ref}{place}; + push( + @{ $self->{place_candidates} }, + Travel::Status::DE::EFA::Stop->new( + place => $place, + full_name => $point->{name}, + name => $point->{name} =~ s{\Q$place\E,? ?}{}r, + id_num => $point->{ref}{id}, + ) + ); + } + return; + } } - return sprintf( '%02d:%02d', - $e->getAttribute('hour'), - $e->getAttribute('minute'), - ); + return; } -sub check_for_ambiguous { +sub stop { my ($self) = @_; + if ( $self->{stop} ) { + return $self->{stop}; + } - my $xml = $self->{tree}; - - my $xp_place = XML::LibXML::XPathExpression->new('//itdOdv/itdOdvPlace'); - my $xp_name = XML::LibXML::XPathExpression->new('//itdOdv/itdOdvName'); - my $xp_mesg - = XML::LibXML::XPathExpression->new('//itdMessage[@type="error"]'); + my $point = $self->{response}{dm}{points}{point}; + my $place = $point->{ref}{place}; - my $xp_place_elem = XML::LibXML::XPathExpression->new('./odvPlaceElem'); - my $xp_name_elem = XML::LibXML::XPathExpression->new('./odvNameElem'); + $self->{stop} = Travel::Status::DE::EFA::Stop->new( + place => $place, + full_name => $point->{name}, + name => $point->{name} =~ s{\Q$place\E,? ?}{}r, + id_num => $point->{ref}{id}, + id_code => $point->{ref}{gid}, + ); - my $e_place = ( $xml->findnodes($xp_place) )[0]; - my $e_name = ( $xml->findnodes($xp_name) )[0]; - my @e_mesg = $xml->findnodes($xp_mesg); + return $self->{stop}; +} - if ( not( $e_place and $e_name ) ) { +sub stops { + my ($self) = @_; - # this should not happen[tm] - cluck('skipping ambiguity check- itdOdvPlace/itdOdvName missing'); - return; + if ( $self->{stops} ) { + return @{ $self->{stops} }; } - my $s_place = $e_place->getAttribute('state'); - my $s_name = $e_name->getAttribute('state'); + my $stops = $self->{response}{dm}{itdOdvAssignedStops} // []; - if ( $s_place eq 'list' ) { - $self->{place_candidates} = [ map { $_->textContent } - @{ $e_place->findnodes($xp_place_elem) } ]; - $self->{errstr} = 'ambiguous place parameter'; - return; + if ( ref($stops) eq 'HASH' ) { + $stops = [$stops]; } - if ( $s_name eq 'list' ) { - $self->{name_candidates} - = [ map { $_->textContent } @{ $e_name->findnodes($xp_name_elem) } ]; - $self->{errstr} = 'ambiguous name parameter'; - return; - } - if ( $s_place eq 'notidentified' ) { - $self->{errstr} = 'invalid place parameter'; - return; - } - if ( $s_name eq 'notidentified' ) { - $self->{errstr} = 'invalid name parameter'; - return; - } - if (@e_mesg) { - $self->{errstr} = join( q{; }, map { $_->textContent } @e_mesg ); - return; + my @stops; + for my $stop ( @{$stops} ) { + push( + @stops, + Travel::Status::DE::EFA::Stop->new( + place => $stop->{place}, + name => $stop->{name}, + full_name => $stop->{nameWithPlace}, + id_num => $stop->{stopID}, + id_code => $stop->{gid}, + ) + ); } - return; + $self->{stops} = \@stops; + return @stops; } -sub identified_data { +sub infos { my ($self) = @_; - if ( not $self->{tree} ) { - return; + if ( $self->{infos} ) { + return @{ $self->{infos} }; } - my $xp_place - = XML::LibXML::XPathExpression->new('//itdOdv/itdOdvPlace/odvPlaceElem'); - my $xp_name - = XML::LibXML::XPathExpression->new('//itdOdv/itdOdvName/odvNameElem'); - - my $e_place = ( $self->{tree}->findnodes($xp_place) )[0]; - my $e_name = ( $self->{tree}->findnodes($xp_name) )[0]; + for my $info ( @{ $self->{response}{dm}{points}{point}{infos} // [] } ) { + push( + @{ $self->{infos} }, + Travel::Status::DE::EFA::Info->new( json => $info ) + ); + } - return ( $e_place->textContent, $e_name->textContent ); + return @{ $self->{infos} // [] }; } sub lines { my ($self) = @_; - my @lines; if ( $self->{lines} ) { return @{ $self->{lines} }; } - if ( not $self->{tree} ) { - return; + for my $line ( @{ $self->{response}{servingLines}{lines} // [] } ) { + push( @{ $self->{lines} }, $self->parse_line($line) ); } - my $xp_element - = XML::LibXML::XPathExpression->new('//itdServingLines/itdServingLine'); + return @{ $self->{lines} // [] }; +} - my $xp_info = XML::LibXML::XPathExpression->new('./itdNoTrain'); - my $xp_route = XML::LibXML::XPathExpression->new('./itdRouteDescText'); - my $xp_oper = XML::LibXML::XPathExpression->new('./itdOperator/name'); +sub parse_line { + my ( $self, $line ) = @_; - for my $e ( $self->{tree}->findnodes($xp_element) ) { + my $mode = $line->{mode} // {}; - my $e_info = ( $e->findnodes($xp_info) )[0]; - my $e_route = ( $e->findnodes($xp_route) )[0]; - my $e_oper = ( $e->findnodes($xp_oper) )[0]; + return Travel::Status::DE::EFA::Line->new( + type => $mode->{product}, + name => $mode->{name}, + number => $mode->{number}, + direction => $mode->{destination}, + valid => $mode->{timetablePeriod}, + mot => $mode->{product}, + operator => $mode->{diva}{operator}, + identifier => $mode->{diva}{globalId}, - if ( not($e_info) ) { - cluck( 'node with insufficient data. This should not happen. ' - . $e->getAttribute('number') ); - next; - } + ); +} - my $line = $e->getAttribute('number'); - my $direction = $e->getAttribute('direction'); - my $valid = $e->getAttribute('valid'); - my $type = $e_info->getAttribute('name'); - my $mot = $e->getAttribute('motType'); - my $route = ( $e_route ? $e_route->textContent : undef ); - my $operator = ( $e_oper ? $e_oper->textContent : undef ); - my $identifier = $e->getAttribute('stateless'); +sub results { + my ($self) = @_; - push( - @lines, - Travel::Status::DE::EFA::Line->new( - name => $line, - direction => $direction, - valid => $valid, - type => $type, - mot => $mot, - route => $route, - operator => $operator, - identifier => $identifier, - ) - ); + if ( $self->{results} ) { + return @{ $self->{results} }; } - $self->{lines} = \@lines; - - return @lines; + if ( $self->{post}{coord} ) { + return $self->results_coord; + } + elsif ( $self->{post}{name_sf} ) { + return $self->results_stopfinder; + } + else { + return $self->results_dm; + } } -sub parse_route { - my ( $self, @nodes ) = @_; - my $xp_routepoint_date - = XML::LibXML::XPathExpression->new('./itdDateTime/itdDate'); - my $xp_routepoint_time - = XML::LibXML::XPathExpression->new('./itdDateTime/itdTime'); - - my @ret; - - for my $e (@nodes) { - my @dates = $e->findnodes($xp_routepoint_date); - my @times = $e->findnodes($xp_routepoint_time); +sub results_coord { + my ($self) = @_; + my $json = $self->{response}; - # note that the first stop has an arrival node with an invalid - # timestamp and the terminal stop has a departure node with an - # invalid timestamp. sprintf_{date,time} return undef in these - # cases. + my @results; + for my $stop ( @{ $json->{locations} // [] } ) { push( - @ret, + @results, Travel::Status::DE::EFA::Stop->new( - arr_date => sprintf_date( $dates[0] ), - arr_time => sprintf_time( $times[0] ), - dep_date => sprintf_date( $dates[-1] ), - dep_time => sprintf_time( $times[-1] ), - name => $e->getAttribute('name'), - name_suf => $e->getAttribute('nameWO'), - platform => $e->getAttribute('platformName'), + place => $stop->{parent}{name}, + full_name => $stop->{properties}{STOP_NAME_WITH_PLACE}, + distance_m => $stop->{properties}{distance}, + name => $stop->{name}, + id_code => $stop->{id}, ) ); } - return @ret; + $self->{results} = \@results; + + return @results; } -sub results { +sub results_stopfinder { my ($self) = @_; + my $json = $self->{response}; + my @results; - if ( $self->{results} ) { - return @{ $self->{results} }; + # Edge case: there is just a single result. + # Oh EFA, you so silly. + if ( ref( $json->{stopFinder}{points} ) eq 'HASH' + and exists $json->{stopFinder}{points}{point} ) + { + $json->{stopFinder}{points} = [ $json->{stopFinder}{points}{point} ]; } - if ( not $self->{tree} ) { - return; + for my $stop ( @{ $json->{stopFinder}{points} // [] } ) { + push( + @results, + Travel::Status::DE::EFA::Stop->new( + place => $stop->{ref}{place}, + full_name => $stop->{name}, + name => $stop->{object}, + id_num => $stop->{ref}{id}, + id_code => $stop->{ref}{gid}, + ) + ); } - my $xp_element = XML::LibXML::XPathExpression->new('//itdDeparture'); - - my $xp_date = XML::LibXML::XPathExpression->new('./itdDateTime/itdDate'); - my $xp_time = XML::LibXML::XPathExpression->new('./itdDateTime/itdTime'); - my $xp_rdate = XML::LibXML::XPathExpression->new('./itdRTDateTime/itdDate'); - my $xp_rtime = XML::LibXML::XPathExpression->new('./itdRTDateTime/itdTime'); - my $xp_line = XML::LibXML::XPathExpression->new('./itdServingLine'); - my $xp_info - = XML::LibXML::XPathExpression->new('./itdServingLine/itdNoTrain'); - my $xp_prev_route - = XML::LibXML::XPathExpression->new('./itdPrevStopSeq/itdPoint'); - my $xp_next_route - = XML::LibXML::XPathExpression->new('./itdOnwardStopSeq/itdPoint'); - - $self->lines; - - for my $e ( $self->{tree}->findnodes($xp_element) ) { - - my $e_date = ( $e->findnodes($xp_date) )[0]; - my $e_time = ( $e->findnodes($xp_time) )[0]; - my $e_line = ( $e->findnodes($xp_line) )[0]; - my $e_info = ( $e->findnodes($xp_info) )[0]; - - my $e_rdate = ( $e->findnodes($xp_rdate) )[0]; - my $e_rtime = ( $e->findnodes($xp_rtime) )[0]; - - if ( not( $e_date and $e_time and $e_line ) ) { - cluck('node with insufficient data. This should not happen'); - next; - } + $self->{results} = \@results; - my $date = sprintf_date($e_date); - my $time = sprintf_time($e_time); - - my $rdate = $e_rdate ? sprintf_date($e_rdate) : $date; - my $rtime = $e_rtime ? sprintf_time($e_rtime) : $time; - - my $platform = $e->getAttribute('platform'); - my $platform_name = $e->getAttribute('platformName'); - my $line = $e_line->getAttribute('number'); - my $dest = $e_line->getAttribute('direction'); - my $info = $e_info->textContent; - my $key = $e_line->getAttribute('key'); - my $countdown = $e->getAttribute('countdown'); - my $delay = $e_info->getAttribute('delay'); - my $type = $e_info->getAttribute('name'); - my $mot = $e_line->getAttribute('motType'); - - my $platform_is_db = 0; - - my @prev_route; - my @next_route; - - if ( $self->{want_full_routes} ) { - @prev_route - = $self->parse_route( @{ [ $e->findnodes($xp_prev_route) ] } ); - @next_route - = $self->parse_route( @{ [ $e->findnodes($xp_next_route) ] } ); - } + return @results; +} - my @line_obj - = grep { $_->{identifier} eq $e_line->getAttribute('stateless') } - @{ $self->{lines} }; - - # platform / platformName are inconsistent. The following cases are - # known: - # - # * platform="int", platformName="" : non-DB platform - # * platform="int", platformName="Bstg. int" : non-DB platform - # * platform="#int", platformName="Gleis int" : non-DB platform - # * platform="#int", platformName="Gleis int" : DB platform? - # * platform="", platformName="Gleis int" : DB platform - # * platform="DB", platformName="Gleis int" : DB platform - # * platform="gibberish", platformName="Gleis int" : DB platform - - if ( ( $platform_name and $platform_name =~ m{ ^ Gleis }ox ) - and not( $platform and $platform =~ s{ ^ \# }{}ox ) ) - { - $platform_is_db = 1; - } +sub results_dm { + my ($self) = @_; + my $json = $self->{response}; - if ( $platform_name and $platform_name =~ m{ ^ (Gleis | Bstg[.])}ox ) { - $platform = ( split( / /, $platform_name ) )[1]; - } - elsif ( $platform_name and not $platform ) { - $platform = $platform_name; - } + # Oh EFA, you so silly + if ( $json->{departureList} and ref( $json->{departureList} ) eq 'HASH' ) { + $json->{departureList} = [ $json->{departureList}{departure} ]; + } + my @results; + for my $departure ( @{ $json->{departureList} // [] } ) { push( @results, - Travel::Status::DE::EFA::Result->new( - date => $rdate, - time => $rtime, - platform => $platform, - platform_db => $platform_is_db, - platform_name => $platform_name, - key => $key, - lineref => $line_obj[0] // undef, - line => $line, - destination => $dest, - countdown => $countdown, - info => $info, - delay => $delay, - sched_date => $date, - sched_time => $time, - type => $type, - mot => $mot, - prev_route => \@prev_route, - next_route => \@next_route, + Travel::Status::DE::EFA::Departure->new( + json => $departure, + strp_stopseq => $self->{strp_stopseq}, + strp_stopseq_s => $self->{strp_stopseq_s} ) ); } @@ -520,124 +654,31 @@ sub results { return @results; } -# static -sub get_efa_urls { - - # sorted lexically by shortname - return ( - { - url => 'https://bsvg.efa.de/bsvagstd/XML_DM_REQUEST', - name => 'Braunschweiger Verkehrs-GmbH', - shortname => 'BSVG', - }, - { - url => 'https://www.ding.eu/ding3/XSLT_DM_REQUEST', - name => 'Donau-Iller Nahverkehrsverbund', - shortname => 'DING', - }, - { - url => 'https://projekte.kvv-efa.de/sl3-alone/XSLT_DM_REQUEST', - name => 'Karlsruher Verkehrsverbund', - shortname => 'KVV', - }, - { - url => 'https://www.linzag.at/static/XSLT_DM_REQUEST', - name => 'Linz AG', - shortname => 'LinzAG', - encoding => 'iso-8859-15', - }, - { - url => 'https://efa.mvv-muenchen.de/mobile/XSLT_DM_REQUEST', - name => 'Münchner Verkehrs- und Tarifverbund', - shortname => 'MVV', - }, - { - url => 'https://www.efa-bw.de/nvbw/XSLT_DM_REQUEST', - name => 'Nahverkehrsgesellschaft Baden-Württemberg', - shortname => 'NVBW', - }, - - # HTTPS not supported - { - url => 'http://efa.svv-info.at/sbs/XSLT_DM_REQUEST', - name => 'Salzburger Verkehrsverbund', - shortname => 'SVV', - }, - - # HTTPS: invalid certificate - { - url => 'http://www.travelineeastmidlands.co.uk/em/XSLT_DM_REQUEST', - name => 'Traveline East Midlands', - shortname => 'TLEM', - }, - { - url => 'https://efa.vagfr.de/vagfr3/XSLT_DM_REQUEST', - name => 'Freiburger Verkehrs AG', - shortname => 'VAG', - }, - - # HTTPS: unsupported protocol - { - url => 'http://mobil.vbl.ch/vblmobil/XML_DM_REQUEST', - name => 'Verkehrsbetriebe Luzern', - shortname => 'VBL', - }, - - # HTTPS not supported - { - url => 'http://fahrplan.verbundlinie.at/stv/XSLT_DM_REQUEST', - name => 'Verkehrsverbund Steiermark', - shortname => 'Verbundlinie', - }, - { - url => 'https://efa.vgn.de/vgnExt_oeffi/XML_DM_REQUEST', - name => 'Verkehrsverbund Grossraum Nuernberg', - shortname => 'VGN', - }, +sub result { + my ($self) = @_; - # HTTPS: certificate verification fails - { - url => 'http://efa.vmv-mbh.de/vmv/XML_DM_REQUEST', - name => 'Verkehrsgesellschaft Mecklenburg-Vorpommern', - shortname => 'VMV', - }, - { - url => 'https://efa.vor.at/wvb/XSLT_DM_REQUEST', - name => 'Verkehrsverbund Ost-Region', - shortname => 'VOR', - encoding => 'iso-8859-15', - }, + return Travel::Status::DE::EFA::Trip->new( json => $self->{response} ); +} - # HTTPS not supported - { - url => 'http://fahrplanauskunft.vrn.de/vrn/XML_DM_REQUEST', - name => 'Verkehrsverbund Rhein-Neckar', - shortname => 'VRN', - }, - { - url => 'https://efa.vrr.de/vrr/XSLT_DM_REQUEST', - name => 'Verkehrsverbund Rhein-Ruhr', - shortname => 'VRR', - }, - { - url => 'https://app.vrr.de/standard/XML_DM_REQUEST', - name => 'Verkehrsverbund Rhein-Ruhr (alternative)', - shortname => 'VRR2', - }, +# static +sub get_service_ids { + return Travel::Status::DE::EFA::Services::get_service_ids(@_); +} - # HTTPS not supported - { - url => 'http://efa.vvo-online.de:8080/dvb/XSLT_DM_REQUEST', - name => 'Verkehrsverbund Oberelbe', - shortname => 'VVO', - }, - { - url => 'https://www2.vvs.de/vvs/XSLT_DM_REQUEST', - name => 'Verkehrsverbund Stuttgart', - shortname => 'VVS', - }, +sub get_services { + my @services; + for my $service ( Travel::Status::DE::EFA::Services::get_service_ids() ) { + my %desc + = %{ Travel::Status::DE::EFA::Services::get_service($service) }; + $desc{shortname} = $service; + push( @services, \%desc ); + } + return @services; +} - ); +# static +sub get_service { + return Travel::Status::DE::EFA::Services::get_service(@_); } 1; @@ -653,27 +694,30 @@ Travel::Status::DE::EFA - unofficial EFA departure monitor use Travel::Status::DE::EFA; my $status = Travel::Status::DE::EFA->new( - efa_url => 'https://efa.vrr.de/vrr/XSLT_DM_REQUEST', - place => 'Essen', name => 'Helenenstr' + service => 'VRR', + name => 'Essen Helenenstr' ); for my $d ($status->results) { printf( "%s %-8s %-5s %s\n", - $d->time, $d->platform_name, $d->line, $d->destination + $d->datetime->strftime('%H:%M'), + $d->platform_name, $d->line, $d->destination ); } =head1 VERSION -version 1.17 +version 3.13 =head1 DESCRIPTION Travel::Status::DE::EFA is an unofficial interface to EFA-based departure monitors. -It reports all upcoming tram/bus/train departures at a given place. +It can serve as a departure monitor, request details about a specific +trip/journey, and look up public transport stops by name or geolocation. +The operating mode depends on its constructor arguments. =head1 METHODS @@ -681,32 +725,52 @@ It reports all upcoming tram/bus/train departures at a given place. =item my $status = Travel::Status::DE::EFA->new(I<%opt>) -Requests the departures as specified by I<opts> and returns a new -Travel::Status::DE::EFA object. B<efa_url>, B<place> and B<name> are -mandatory. Dies if the wrong I<opts> were passed. +Requests data as specified by I<opts> and returns a new Travel::Status::DE::EFA +object. B<service> and exactly one of B<coord>, B<stopfinder>, B<stopseq> or +B<name> are mandatory. Dies if the wrong I<opts> were passed. Arguments: =over -=item B<efa_url> => I<url> +=item B<service> => I<name> -URL to the EFA service. See C<< efa-m --list >> for known URLs. -If you found a URL not listed there, please notify +EFA service. See C<< efa-m --list >> for known services. +If you found a service not listed there, please notify E<lt>derf+efa@finalrewind.orgE<gt>. +=item B<coord> => I<hashref> + +Look up stops in the vicinity of the given coordinates. I<hashref> must +contain a B<lon> and a B<lat> element providing WGS84 longitude/latitude. + +=item B<stopfinder> => { B<name> => I<name> } + +Look up stops matching I<name>. + +=item B<stopseq> => I<hashref> + +Look up trip details. I<hashref> must provide B<stateless> (line ID), +B<stop_id> (stop ID used as start for the reported route), B<key> (line trip +number), and B<date> (departure date as YYYYMMDD string). + +=item B<name> => I<name> + +List departure for address / point of interest / stop I<name>. + =item B<place> => I<place> Name of the place/city -=item B<type> => B<address>|B<poi>|B<stop> +=item B<type> => B<address>|B<poi>|B<stop>|B<stopID> Type of the following I<name>. B<poi> means "point of interest". Defaults to B<stop> (stop/station name). -=item B<name> => I<name> +=item B<datetime> => I<DateTime object> -address / poi / stop name to list departures for. +Request departures for the date/time specified by I<DateTime object>. +Default: now. =item B<efa_encoding> => I<encoding> @@ -718,7 +782,12 @@ iso-8859-15. If true: Request full routes for all departures from the backend. This enables the B<route_pre>, B<route_post> and B<route_interesting> accessors in -Travel::Status::DE::EFA::Result(3pm). +Travel::Status::DE::EFA::Departure(3pm). + +=item B<proximity_search> => B<0>|B<1> + +If true: Show departures for stops in the proximity of the requested place +as well. =item B<timeout> => I<seconds> @@ -727,17 +796,37 @@ Default: 10 seconds. Set to 0 or a negative value to disable it. =back +=item my $status_p = Travel::Status::DE::EFA->new_p(I<%opt>) + +Returns a promise that resolves into a Travel::Status::DE::EFA instance +($status) on success and rejects with an error message on failure. In case +the error occured after construction of the Travel::Status::DE::EFA object +(e.g. due to an ambiguous name/place parameter), the second argument of the +rejected promise holds a Travel::Status::DE::EFA instance that can be used +to query place/name candidates (see name_candidates and place_candidates). + +In addition to the arguments of B<new>, the following mandatory arguments must +be set. + +=over + +=item B<promise> => I<promises module> + +Promises implementation to use for internal promises as well as B<new_p> return +value. Recommended: Mojo::Promise(3pm). + +=item B<user_agent> => I<user agent> + +User agent instance to use for asynchronous requests. The object must implement +a B<post_p> function. Recommended: Mojo::UserAgent(3pm). + +=back + =item $status->errstr In case of an HTTP request or EFA error, returns a string describing it. If none occured, returns undef. -=item $status->identified_data - -Returns a list of the identified values for I<place> and I<name>. -For instance, when requesting data for "E", "MartinSTR", B<identified_data> -will return ("Essen", "Martinstr."). - =item $status->lines Returns a list of Travel::Status::DE::EFA::Line(3pm) objects, each one @@ -753,28 +842,70 @@ nothing (undef / empty list) otherwise. Returns a list of B<place> candidates if I<place> is ambiguous. Returns nothing (undef / empty list) otherwise. +=item $status->stop + +Returns a Travel::Status::DE::EFA::Stop(3pm) instance describing the requested +stop. + +=item $status->stops + +In case the requested place/name is served by multiple stops and the backend +provides a list of those: returns a list of Travel::Status::DE::EFA::Stop(3pm) +instances describing each of them. Returns an empty list otherwise. + =item $status->results -Returns a list of Travel::Status::DE::EFA::Result(3pm) objects, each one describing -one departure. +In departure monitor mode: returns a list of +Travel::Status::DE::EFA::Departure(3pm) objects, each one describing one +departure. + +In coord or stopfinder mode: returns a list of +Travel::Status::DE::EFA::Stop(3pm) objects. + +=item $status->result -=item Travel::Status::DE::EFA::get_efa_urls() +In stopseq mode: Returns a Travel::Status::DE::EFA::Trip(3pm) object. -Returns a list of known EFA entry points. Each list element is a hashref with -the following elements. +=item Travel::Status::DE::EFA::get_service_ids() + +Returns the list of supported services (backends). + +=item Travel::Status::DE::EFA::get_service(I<service>) + +Returns a hashref describing the requested I<service> ID with the following keys. =over -=item B<url>: service URL as passed to B<efa_url> +=item B<name> => I<string> + +Provider name, e.g. Verkehrsverbund Oberelbe. + +=item B<url> => I<string> + +Backend base URL. + +=item B<homepage> => I<string> (optional) + +Provider homepage. -=item B<name>: Name of the entity operating this service +=item B<languages> => I<arrayref> (optional) -=item B<shortname>: Short name of the entity +Supportde languages, e.g. de, en. -=item B<encoding>: Server-side encoding override for B<efa_encoding> (optional) +=item B<coverage> => I<hashref> + +Area in which the service provides near-optimal coverage. Typically, this +means a (nearly) complete list of departures and real-time data. The +hashref contains two optional keys: B<area> (GeoJSON) and B<regions> (list of +strings, e.g. "DE" or "CH-BE"). =back +=item Travel::Status::DE::EFA::get_services() + +Returns a list of hashrefs describing all supported services. In addition +to the keys listed above, each service contains a B<shortname> (service ID). + =back =head1 DIAGNOSTICS @@ -787,23 +918,27 @@ None. =item * Class::Accessor(3pm) -=item * LWP::UserAgent(3pm) +=item * DateTime(3pm) -=item * XML::LibXML(3pm) +=item * DateTime::Format::Strptime(3pm) + +=item * JSON(3pm) + +=item * LWP::UserAgent(3pm) =back =head1 BUGS AND LIMITATIONS -Not all features of the web interface are supported. +The API is not exposed completely. =head1 SEE ALSO -efa-m(1), Travel::Status::DE::EFA::Result(3pm). +efa-m(1), Travel::Status::DE::EFA::Departure(3pm). =head1 AUTHOR -Copyright (C) 2011-2015 by Daniel Friesel E<lt>derf@finalrewind.orgE<gt> +Copyright (C) 2011-2025 Birte Kristina Friesel E<lt>derf@finalrewind.orgE<gt> =head1 LICENSE diff --git a/lib/Travel/Status/DE/EFA/Departure.pm b/lib/Travel/Status/DE/EFA/Departure.pm new file mode 100644 index 0000000..ec17a12 --- /dev/null +++ b/lib/Travel/Status/DE/EFA/Departure.pm @@ -0,0 +1,528 @@ +package Travel::Status::DE::EFA::Departure; + +use strict; +use warnings; +use 5.010; + +use DateTime; +use List::Util qw(any); +use Travel::Status::DE::EFA::Stop; + +use parent 'Class::Accessor'; + +our $VERSION = '3.13'; + +Travel::Status::DE::EFA::Departure->mk_ro_accessors( + qw(countdown datetime delay destination is_cancelled key line lineref mot + occupancy operator origin platform platform_db platform_name rt_datetime + sched_datetime stateless stop_id_num train_type train_name train_no type) +); + +my @mot_mapping = qw{ + zug s-bahn u-bahn stadtbahn tram stadtbus regionalbus + schnellbus seilbahn schiff ast sonstige +}; + +sub parse_departure { + my ( $self, $departure ) = @_; +} + +sub new { + my ( $obj, %conf ) = @_; + + my $departure = $conf{json}; + my ( $sched_dt, $real_dt ); + + if ( my $dt = $departure->{dateTime} ) { + $sched_dt = DateTime->new( + year => $dt->{year}, + month => $dt->{month}, + day => $dt->{day}, + hour => $dt->{hour}, + minute => $dt->{minute}, + second => $dt->{second} // 0, + time_zone => 'Europe/Berlin', + ); + } + + if ( my $dt = $departure->{realDateTime} ) { + $real_dt = DateTime->new( + year => $dt->{year}, + month => $dt->{month}, + day => $dt->{day}, + hour => $dt->{hour}, + minute => $dt->{minute}, + second => $dt->{second} // 0, + time_zone => 'Europe/Berlin', + ); + } + + my @hints + = map { $_->{content} } @{ $departure->{servingLine}{hints} // [] }; + + my $ref = { + strp_stopseq_s => $conf{strp_stopseq_s}, + strp_stopseq => $conf{strp_stopseq}, + rt_datetime => $real_dt, + platform => $departure->{platform}, + platform_name => $departure->{platformName}, + platform_type => $departure->{pointType}, + key => $departure->{servingLine}{key}, + stateless => $departure->{servingLine}{stateless}, + stop_id_num => $departure->{stopID}, + line => $departure->{servingLine}{symbol}, + train_type => $departure->{servingLine}{trainType}, + train_name => $departure->{servingLine}{trainName}, + train_no => $departure->{servingLine}{trainNum}, + origin => $departure->{servingLine}{directionFrom}, + destination => $departure->{servingLine}{direction}, + occupancy => $departure->{occupancy}, + countdown => $departure->{countdown}, + delay => $departure->{servingLine}{delay}, + sched_datetime => $sched_dt, + type => $departure->{servingLine}{name}, + mot => $departure->{servingLine}{motType}, + hints => \@hints, + }; + + if ( defined $ref->{delay} and $ref->{delay} eq '-9999' ) { + $ref->{delay} = 0; + $ref->{is_cancelled} = 1; + } + else { + $ref->{is_cancelled} = 0; + } + + $ref->{datetime} = $ref->{rt_datetime} // $ref->{sched_datetime}; + + bless( $ref, $obj ); + + if ( $departure->{prevStopSeq} ) { + $ref->{prev_route} = $ref->parse_route( $departure->{prevStopSeq}, + $departure->{stopID} ); + } + if ( $departure->{onwardStopSeq} ) { + $ref->{next_route} = $ref->parse_route( $departure->{onwardStopSeq}, + $departure->{stopID} ); + } + + return $ref; +} + +sub parse_route { + my ( $self, $stop_seq, $requested_id ) = @_; + my @ret; + + if ( not $stop_seq ) { + return \@ret; + } + + # Oh EFA, you so silly + if ( ref($stop_seq) eq 'HASH' ) { + + # For lines that start or terminate at the requested stop, onwardStopSeq / prevStopSeq includes the requested stop. + if ( $stop_seq->{ref}{id} eq $requested_id ) { + return \@ret; + } + $stop_seq = [$stop_seq]; + } + + for my $stop ( @{ $stop_seq // [] } ) { + my $ref = $stop->{ref}; + my ( $arr, $dep ); + + if ( $ref->{arrDateTimeSec} ) { + $arr = $self->{strp_stopseq_s} + ->parse_datetime( $ref->{arrDateTimeSec} ); + } + elsif ( $ref->{arrDateTime} ) { + $arr = $self->{strp_stopseq}->parse_datetime( $ref->{arrDateTime} ); + } + + if ( $ref->{depDateTimeSec} ) { + $dep = $self->{strp_stopseq_s} + ->parse_datetime( $ref->{depDateTimeSec} ); + } + elsif ( $ref->{depDateTime} ) { + $dep = $self->{strp_stopseq}->parse_datetime( $ref->{depDateTime} ); + } + + push( + @ret, + Travel::Status::DE::EFA::Stop->new( + sched_arr => $arr, + sched_dep => $dep, + arr_delay => $ref->{arrValid} ? $ref->{arrDelay} : undef, + dep_delay => $ref->{depValid} ? $ref->{depDelay} : undef, + id_num => $ref->{id}, + id_code => $ref->{gid}, + full_name => $stop->{name}, + place => $stop->{place}, + name => $stop->{nameWO}, + occupancy => $stop->{occupancy}, + platform => $ref->{platform} || $stop->{platformName} || undef, + ) + ); + } + + return \@ret; +} + +sub id { + my ($self) = @_; + + if ( $self->{id} ) { + return $self->{id}; + } + + return $self->{id} = sprintf( '%s@%d(%s)%d', + $self->stateless =~ s{ }{}gr, + scalar $self->route_pre ? ( $self->route_pre )[0]->id_num + : $self->stop_id_num, + ( scalar $self->route_pre and ( $self->route_pre )[0]->sched_dep ) + ? ( $self->route_pre )[0]->sched_dep->strftime('%Y%m%dT%H:%M') + : $self->sched_datetime->strftime('%Y%m%dT%H:%M'), + $self->key ); +} + +sub hints { + my ($self) = @_; + + return @{ $self->{hints} // [] }; +} + +sub mot_name { + my ($self) = @_; + + return $mot_mapping[ $self->{mot} ] // 'sonstige'; +} + +sub route_pre { + my ($self) = @_; + + return @{ $self->{prev_route} // [] }; +} + +sub route_post { + my ($self) = @_; + + return @{ $self->{next_route} // [] }; +} + +sub route_interesting { + my ( $self, $max_parts ) = @_; + + my @via = $self->route_post; + my ( @via_main, @via_show, $last_stop ); + $max_parts //= 3; + + for my $stop (@via) { + if ( + $stop->name =~ m{ Bf | Hbf | Flughafen | [Bb]ahnhof + | Krankenhaus | Klinik | (?: S $ ) }ox + ) + { + push( @via_main, $stop ); + } + } + $last_stop = pop(@via); + + if ( @via_main and $via_main[-1] == $last_stop ) { + pop(@via_main); + } + if ( @via and $via[-1] == $last_stop ) { + pop(@via); + } + + if ( @via_main and @via and $via[0] == $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 ( any { $_->name eq $stop->name } @via_show + or $stop->name eq $last_stop->name ) + { + next; + } + push( @via_show, $stop ); + } + } + + return @via_show; +} + +sub TO_JSON { + my ($self) = @_; + + # compute on-demand keys + $self->id; + + my $ret = { %{$self} }; + + delete $ret->{strp_stopseq}; + delete $ret->{strp_stopseq_s}; + + for my $k (qw(datetime rt_datetime sched_datetime)) { + if ( $ret->{$k} ) { + $ret->{$k} = $ret->{$k}->epoch; + } + } + + return $ret; +} + +1; + +__END__ + +=head1 NAME + +Travel::Status::DE::EFA::Departure - Information about a single +departure received by Travel::Status::DE::EFA + +=head1 SYNOPSIS + + for my $departure ($status->results) { + printf( + "At %s: %s to %s from platform %d\n", + $departure->datetime->strftime('%H:%M'), $departure->line, + $departure->destination, $departure->platform + ); + } + +=head1 VERSION + +version 3.13 + +=head1 DESCRIPTION + +Travel::Status::DE::EFA::Departure describes a single departure as obtained by +Travel::Status::DE::EFA. It contains information about the time, platform, +line number and destination. + +=head1 METHODS + +=head2 ACCESSORS + +=over + +=item $departure->countdown + +Time in minutes from now until the tram/bus/train will depart, including +realtime data if available. + +If delay information is available, it is already included. + +=item $departure->datetime + +DateTime(3pm) object for departure date and time. Realtime data if available, +schedule data otherwise. + +=item $departure->delay + +Expected delay from scheduled departure time in minutes. A delay of 0 +indicates departure on time. undef when no realtime information is available. + +=item $departure->destination + +Destination name. + +=item $departure->hints + +Additional information related to the departure (list of strings). If +departures for an address were requested, this is the stop name, otherwise it +may be recent news related to the line's schedule. + +=item $departure->id + +Stringified unique(?) identifier of this departure; suitable for passing to +Travel::Status::DE::EFA->new(stopseq) after decomposing it again. +The returned string combines B<stateless>, B<stop_id_num> (or the ID of the first +stop in B<route_pre>, if present), B<sched_datetime>, and B<key>. + +=item $departure->is_cancelled + +1 if the departure got cancelled, 0 otherwise. + +=item $departure->key + +Key of this departure of the corresponding line. Unique for a given day when +combined with B<stateless>. + +=item $departure->line + +The name/number of the line. + +=item $departure->lineref + +Travel::Status::DE::EFA::Line(3pm) object describing the departing line in +detail. + +=item $departure->mot + +Returns the "mode of transport" number. This is usually an integer between 0 +and 11. + +=item $departure->mot_name + +Returns the "mode of transport", for instance "zug", "s-bahn", "tram" or +"sonstige". + +=item $departure->occupancy + +Returns expected occupancy, if available, undef otherwise. + +Occupancy values are passed from the backend as-is. Known values are +"MANY_SEATS" (low occupation), "FEW_SEATS" (high occupation), +"STANDING_ONLY" (very high occupation), and "FULL" (boarding not advised). + +=item $departure->origin + +Origin name. + +=item $departure->platform + +Departure platform number (may not be a number). + +=item $departure->platform_db + +true if the platform number is operated by DB ("Gleis x"), false ("Bstg. x") +otherwise. + +Unfortunately, there is no distinction between tram and bus platforms yet, +which may also have the same numbers. + +=item $departure->route_interesting + +List of up to three "interesting" stations served by this departure. Is a +subset of B<route_post>. Each station is a Travel::Status::DE::EFA::Stop(3pm) +object. + +=item $departure->route_pre + +List of stations the vehicle passed (or will have passed) before this stop. +Each station is a Travel::Status::DE::EFA::Stop(3pm) object. + +=item $departure->route_post + +List of stations the vehicle will pass after this stop. +Each station is a Travel::Status::DE::EFA::Stop(3pm) object. + +=item $departure->rt_datetime + +DateTime(3pm) object holding the departure date and time according to +realtime data. Undef if unknown / unavailable. + +=item $departure->sched_datetime + +DateTime(3pm) object holding the scheduled departure date and time. + +=item $departure->stateless + +Unique line identifier. + +=item $departure->train_type + +Train type, e.g. "ICE". Typically only defined for long-distance trains. + +=item $departure->train_name + +Train name, e.g. "ICE International" or "InterCityExpresS" or "Deichgraf". +Typically only defined for long-distance trains. + +=item $departure->train_no + +Train number. Only defined if departure is a train. + +=item $departure->type + +Type of the departure. Note that efa.vrr.de sometimes puts bogus data in this +field. See L</DEPARTURE TYPES>. + +=back + +=head2 INTERNAL + +=over + +=item $departure = Travel::Status::DE::EFA::Departure->new(I<%data>) + +Returns a new Travel::Status::DE::EFA::Departure object. You should not need to +call this. + +=item $departure->TO_JSON + +Allows the object data to be serialized to JSON. + +=back + +=head1 DEPARTURE TYPES + +The following are known so far: + +=over + +=item * Abellio-Zug + +=item * Bus + +=item * Eurocity + +=item * Intercity-Express + +=item * NE (NachtExpress / night bus) + +=item * Niederflurbus + +=item * R-Bahn (RE / RegionalExpress) + +=item * S-Bahn + +=item * SB (Schnellbus) + +=item * StraE<szlig>enbahn + +=item * U-Bahn + +=back + +=head1 DIAGNOSTICS + +None. + +=head1 DEPENDENCIES + +=over + +=item Class::Accessor(3pm) + +=back + +=head1 BUGS AND LIMITATIONS + +C<< $result->type >> may contain bogus data. This comes from the efa.vrr.de +interface. + +=head1 SEE ALSO + +Travel::Status::DE::EFA(3pm). + +=head1 AUTHOR + +Copyright (C) 2011-2025 Birte Kristina 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/EFA/Info.pm b/lib/Travel/Status/DE/EFA/Info.pm new file mode 100644 index 0000000..424c9f1 --- /dev/null +++ b/lib/Travel/Status/DE/EFA/Info.pm @@ -0,0 +1,127 @@ +package Travel::Status::DE::EFA::Info; + +use strict; +use warnings; +use 5.010; + +use parent 'Class::Accessor'; + +our $VERSION = '3.13'; + +Travel::Status::DE::EFA::Info->mk_ro_accessors( + qw(link_url link_text subject content subtitle additional_text)); + +sub new { + my ( $obj, %opt ) = @_; + + my $json = $opt{json}; + + my $ref = { + param => {}, + link_url => $json->{infoLinkURL}, + link_text => $json->{infoLinkText}, + subject => $json->{infoText}{subject}, + content => $json->{infoText}{content}, + subtitle => $json->{infoText}{subtitle}, + additional_text => $json->{infoText}{additionalText}, + }; + + for my $param ( @{ $json->{paramList} // [] } ) { + $ref->{param}{ $param->{name} } = $param->{value}; + } + + return bless( $ref, $obj ); +} + +sub TO_JSON { + my ($self) = @_; + + return { %{$self} }; +} + +1; + +__END__ + +=head1 NAME + +Travel::Status::DE::EFA::Info - Information about a public transit stop + +=head1 SYNOPSIS + + if ( $info->subject and $info->subtitle ne $info->subject ) { + printf( "# %s\n%s\n", $info->subtitle, $info->subject ); + } + else { + printf( "# %s\n", $info->subtitle ); + } + +=head1 VERSION + +version 3.13 + +=head1 DESCRIPTION + +Travel::Status::DE::EFA::Info holds a single information message related to +a specific public transit stop. + +=head1 ACCESSORS + +All accessors may return undef. +Individual accessors may return identical strings. +Strings may contain HTML elements. + +=over + +=item $info->additional_text + +=item $info->content + +=item $info->link_url + +URL to a site related to this information message. +The site may or may not hold additional data. + +=item $info->link_text + +Text for linking to link_url. + +=item $info->param + +Hashref of parameters, e.g. C<< incidentDateTime >> (string describing the +date/time range during which this message is valid). + +=item $info->subject + +=item $info->subtitle + +=back + +=head1 DIAGNOSTICS + +None. + +=head1 DEPENDENCIES + +=over + +=item Class::Accessor(3pm) + +=back + +=head1 BUGS AND LIMITATIONS + +This module is a Work in Progress. +Its API may change between minor versions. + +=head1 SEE ALSO + +Travel::Status::DE::EFA(3pm). + +=head1 AUTHOR + +Copyright (C) 2024-2025 Birte Kristina 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/EFA/Line.pm b/lib/Travel/Status/DE/EFA/Line.pm index e5cb3a3..061c904 100644 --- a/lib/Travel/Status/DE/EFA/Line.pm +++ b/lib/Travel/Status/DE/EFA/Line.pm @@ -6,10 +6,10 @@ use 5.010; use parent 'Class::Accessor'; -our $VERSION = '1.17'; +our $VERSION = '3.13'; Travel::Status::DE::EFA::Line->mk_ro_accessors( - qw(direction mot name operator route type valid)); + qw(direction mot name number operator route type valid)); my @mot_mapping = qw{ zug s-bahn u-bahn stadtbahn tram stadtbus regionalbus @@ -57,7 +57,7 @@ requested station =head1 VERSION -version 1.17 +version 3.13 =head1 DESCRIPTION @@ -151,7 +151,7 @@ Travel::Status::DE::EFA(3pm). =head1 AUTHOR -Copyright (C) 2011-2015 by Daniel Friesel E<lt>derf@finalrewind.orgE<gt> +Copyright (C) 2011-2025 Birte Kristina Friesel E<lt>derf@finalrewind.orgE<gt> =head1 LICENSE diff --git a/lib/Travel/Status/DE/EFA/Result.pm b/lib/Travel/Status/DE/EFA/Result.pm deleted file mode 100644 index b8553d7..0000000 --- a/lib/Travel/Status/DE/EFA/Result.pm +++ /dev/null @@ -1,330 +0,0 @@ -package Travel::Status::DE::EFA::Result; - -use strict; -use warnings; -use 5.010; - -no if $] >= 5.018, warnings => 'experimental::smartmatch'; - -use parent 'Class::Accessor'; - -our $VERSION = '1.17'; - -Travel::Status::DE::EFA::Result->mk_ro_accessors( - qw(countdown date delay destination is_cancelled info key line lineref - mot platform platform_db platform_name sched_date sched_time time type) -); - -my @mot_mapping = qw{ - zug s-bahn u-bahn stadtbahn tram stadtbus regionalbus - schnellbus seilbahn schiff ast sonstige -}; - -sub new { - my ( $obj, %conf ) = @_; - - my $ref = \%conf; - - if ( defined $ref->{delay} and $ref->{delay} eq '-9999' ) { - $ref->{delay} = 0; - $ref->{is_cancelled} = 1; - } - else { - $ref->{is_cancelled} = 0; - } - - return bless( $ref, $obj ); -} - -sub mot_name { - my ($self) = @_; - - return $mot_mapping[ $self->{mot} ] // 'sonstige'; -} - -sub route_pre { - my ($self) = @_; - - return @{ $self->{prev_route} }; -} - -sub route_post { - my ($self) = @_; - - return @{ $self->{next_route} }; -} - -sub route_interesting { - my ( $self, $max_parts ) = @_; - - my @via = $self->route_post; - my ( @via_main, @via_show, $last_stop ); - $max_parts //= 3; - - for my $stop (@via) { - if ( - $stop->name_suf =~ m{ Bf | Hbf | Flughafen | Hauptbahnhof - | Krankenhaus | Klinik | (?: S $ ) }ox - ) - { - push( @via_main, $stop ); - } - } - $last_stop = pop(@via); - - if ( @via_main and $via_main[-1] == $last_stop ) { - pop(@via_main); - } - if ( @via and $via[-1] == $last_stop ) { - pop(@via); - } - - if ( @via_main and @via and $via[0] == $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); - - # FIXME cannot smartmatch $stop since it became an object - # if ( $stop ~~ \@via_show or $stop == $last_stop ) { - # next; - # } - push( @via_show, $stop ); - } - } - - return @via_show; -} - -sub TO_JSON { - my ($self) = @_; - - return { %{$self} }; -} - -1; - -__END__ - -=head1 NAME - -Travel::Status::DE::EFA::Result - Information about a single -departure received by Travel::Status::DE::EFA - -=head1 SYNOPSIS - - for my $departure ($status->results) { - printf( - "At %s: %s to %s from platform %d\n", - $departure->time, $departure->line, $departure->destination, - $departure->platform - ); - } - -=head1 VERSION - -version 1.17 - -=head1 DESCRIPTION - -Travel::Status::DE::EFA::Result describes a single departure as obtained by -Travel::Status::DE::EFA. It contains information about the time, platform, -line number and destination. - -=head1 METHODS - -=head2 ACCESSORS - -"Actual" in the description means that the delay (if available) is already -included in the calculation, "Scheduled" means it isn't. - -=over - -=item $departure->countdown - -Actual time in minutes from now until the tram/bus/train will depart. - -If delay information is available, it is already included. - -=item $departure->date - -Actual departure date (DD.MM.YYYY). - -=item $departure->delay - -Expected delay from scheduled departure time in minutes. A delay of 0 -indicates departure on time. undef when no realtime information is available. - -=item $departure->destination - -Destination name. - -=item $departure->info - -Additional information related to the departure (string). If departures for -an address were requested, this is the stop name, otherwise it may be recent -news related to the line's schedule. If no information is available, returns -an empty string. - -=item $departure->is_cancelled - -1 if the departure got cancelled, 0 otherwise. - -=item $departure->key - -Unknown. Unlike the name may suggest, this is not a unique key / UUID for a -departure: On the same day, different lines departing at the same station -may have the same key. It might, however, be unique when combined with the -B<line> information. - -=item $departure->line - -The name/number of the line. - -=item $departure->lineref - -Travel::Status::DE::EFA::Line(3pm) object describing the departing line in -detail. - -=item $departure->mot - -Returns the "mode of transport" number. This is usually an integer between 0 -and 11. - -=item $departure->mot_name - -Returns the "mode of transport", for instance "zug", "s-bahn", "tram" or -"sonstige". - -=item $departure->platform - -Departure platform number (may not be a number). - -=item $departure->platform_db - -true if the platform number is operated by DB ("Gleis x"), false ("Bstg. x") -otherwise. - -Unfortunately, there is no distinction between tram and bus platforms yet, -which may also have the same numbers. - -=item $departure->route_interesting - -List of up to three "interesting" stations served by this departure. Is a -subset of B<route_post>. Each station is a Travel::Status::DE::EFA::Stop(3pm) -object. - -=item $departure->route_pre - -List of stations the train passed (or will have passed) befoe this stop. -Each station is a Travel::Status::DE::EFA::Stop(3pm) object. - -=item $departure->route_post - -List of stations the train will pass after this stop. -Each station is a Travel::Status::DE::EFA::Stop(3pm) object. - -=item $departure->sched_date - -Scheduled departure date (DD.MM.YYYY). - -=item $departure->sched_time - -Scheduled departure time (HH:MM). - -=item $departure->time - -Actual departure time (HH:MM). - -=item $departure->type - -Type of the departure. Note that efa.vrr.de sometimes puts bogus data in this -field. See L</DEPARTURE TYPES>. - -=back - -=head2 INTERNAL - -=over - -=item $departure = Travel::Status::DE::EFA::Result->new(I<%data>) - -Returns a new Travel::Status::DE::EFA::Result object. You should not need to -call this. - -=item $departure->TO_JSON - -Allows the object data to be serialized to JSON. - -=back - -=head1 DEPARTURE TYPES - -The following are known so far: - -=over - -=item * Abellio-Zug - -=item * Bus - -=item * Eurocity - -=item * Intercity-Express - -=item * NE (NachtExpress / night bus) - -=item * Niederflurbus - -=item * R-Bahn (RE / RegionalExpress) - -=item * S-Bahn - -=item * SB (Schnellbus) - -=item * StraE<szlig>enbahn - -=item * U-Bahn - -=back - -=head1 DIAGNOSTICS - -None. - -=head1 DEPENDENCIES - -=over - -=item Class::Accessor(3pm) - -=back - -=head1 BUGS AND LIMITATIONS - -C<< $result->type >> may contain bogus data. This comes from the efa.vrr.de -interface. - -=head1 SEE ALSO - -Travel::Status::DE::EFA(3pm). - -=head1 AUTHOR - -Copyright (C) 2011-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/EFA/Services.pm.PL b/lib/Travel/Status/DE/EFA/Services.pm.PL new file mode 100644 index 0000000..81027d7 --- /dev/null +++ b/lib/Travel/Status/DE/EFA/Services.pm.PL @@ -0,0 +1,147 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use 5.014; +use utf8; +use Data::Dumper; +use Encode qw(encode); +use File::Slurp qw(read_file write_file); +use JSON; + +my $json = JSON->new->utf8; + +sub load_instance { + my ( $path, %opt ) = @_; + + my $data = $json->decode( + scalar read_file("ext/transport-apis/data/${path}-efa.json") ); + my %ret = ( + name => $opt{name} // $data->{name} =~ s{ *[(][^)]+[)]}{}r, + homepage => $data->{attribution}{homepage}, + url => $opt{url} // $data->{options}{endpoint} =~ s{ / $ }{}rx, + time_zone => $data->{timezone}, + languages => $data->{supportedLanguages}, + coverage => { + area => $data->{coverage}{realtimeCoverage}{area}, + regions => $data->{coverage}{realtimeCoverage}{region} // [] + }, + ); + + return %ret; +} + +# GVH: 403 +# VRT: Encoding issues +# VVSt: NXDOMAIN +my %efa_instance = ( + BEG => { + url => 'https://bahnland-bayern.de/efa', + name => 'Bayerische Eisenbahngesellschaft', + }, + BSVG => { + url => 'https://bsvg.efa.de/bsvagstd', + name => 'Braunschweiger Verkehrs-GmbH', + }, + bwegt => { load_instance('de/bwegt') }, + DING => { + url => 'https://www.ding.eu/ding3', + name => 'Donau-Iller Nahverkehrsverbund', + }, + KVV => { load_instance('de/kvv') }, + LinzAG => { + url => 'https://www.linzag.at/static', + name => 'Linz AG', + encoding => 'iso-8859-15', + }, + MVV => { load_instance('de/mvv') }, + NVBW => { + url => 'https://www.efa-bw.de/nvbw', + name => 'Nahverkehrsgesellschaft Baden-Württemberg', + }, + NWL => { + url => 'https://westfalenfahrplan.de/nwl-efa', + name => 'Nahverkehr Westfalen-Lippe', + }, + Rolph => { load_instance('de/rolph') }, + RVV => { + url => 'https://efa.rvv.de/efa', + name => 'Regensburger Verkehrsverbund', + }, + VAG => { + url => 'https://efa.vagfr.de/vagfr3', + name => 'Freiburger Verkehrs AG', + }, + VGN => + { load_instance( 'de/vgn', url => 'https://efa.vgn.de/vgnExt_oeffi' ) }, + VMV => { load_instance('de/vmv') }, + VRN => { + url => 'https://www.vrn.de/mngvrn/', + name => 'Verkehrsverbund Rhein-Neckar', + }, + VRR => { + load_instance( + 'de/vrr', + url => 'https://efa.vrr.de/vrr', + ), + }, + VRR2 => { load_instance('de/vrr') }, + VRR3 => { load_instance( 'de/vrr', url => 'https://efa.vrr.de/rbgstd3' ) }, + VVO => { + url => 'https://efa.vvo-online.de/VMSSL3', + name => 'Verkehrsverbund Oberelbe', + }, + VVS => { load_instance('de/vvs') }, + +); + +my $buf = <<'__EOF__'; +package Travel::Status::DE::EFA::Services; + +# vim:readonly +# This package has been automatically generated +# by lib/Travel/Status/DE/EFA/Services.pm.PL. +# Do not edit, changes will be lost. + +use strict; +use warnings; +use 5.014; +use utf8; + +our $VERSION = '3.13'; + +# Most of these have been adapted from +# <https://github.com/public-transport/transport-apis> and +# <https://github.com/public-transport/hafas-client/tree/main/p>. +# Many thanks to Jannis R / @derhuerst and all contributors for maintaining +# these resources. + +__EOF__ + +my $perlobj = Data::Dumper->new( [ \%efa_instance ], ['efa_instance'] ); + +$buf .= 'my ' . $perlobj->Sortkeys(1)->Indent(0)->Dump; + +$buf .= <<'__EOF__'; + +sub get_service_ids { + return sort keys %{$efa_instance}; +} + +sub get_service { + my ($service) = @_; + return $efa_instance->{$service}; +} + +sub get_service_ref { + return $efa_instance; +} + +sub get_service_map { + return %{$efa_instance}; +} + +1; +__EOF__ + +write_file( $ARGV[0], { binmode => ':utf8' }, $buf ); diff --git a/lib/Travel/Status/DE/EFA/Stop.pm b/lib/Travel/Status/DE/EFA/Stop.pm index 566caa8..910111e 100644 --- a/lib/Travel/Status/DE/EFA/Stop.pm +++ b/lib/Travel/Status/DE/EFA/Stop.pm @@ -4,27 +4,71 @@ use strict; use warnings; use 5.010; -no if $] >= 5.018, warnings => 'experimental::smartmatch'; - use parent 'Class::Accessor'; -our $VERSION = '1.17'; +our $VERSION = '3.13'; Travel::Status::DE::EFA::Stop->mk_ro_accessors( - qw(arr_date arr_time dep_date dep_time name name_suf platform)); + qw(sched_arr rt_arr arr arr_delay + sched_dep rt_dep dep dep_delay + occupancy delay distance_m is_cancelled + place name full_name id_num id_code latlon + platform niveau) +); sub new { my ( $obj, %conf ) = @_; my $ref = \%conf; + if ( $ref->{sched_arr} and $ref->{arr_delay} and not $ref->{rt_arr} ) { + $ref->{rt_arr} + = $ref->{sched_arr}->clone->add( minutes => $ref->{arr_delay} ); + } + + if ( $ref->{sched_dep} and $ref->{dep_delay} and not $ref->{rt_dep} ) { + $ref->{rt_dep} + = $ref->{sched_dep}->clone->add( minutes => $ref->{dep_delay} ); + } + + $ref->{arr} //= $ref->{rt_arr} // $ref->{sched_arr}; + $ref->{dep} //= $ref->{rt_dep} // $ref->{sched_dep}; + + if ( $ref->{rt_arr} + and $ref->{sched_arr} + and not defined $ref->{arr_delay} ) + { + $ref->{arr_delay} + = $ref->{rt_arr}->subtract_datetime( $ref->{sched_arr} ) + ->in_units('minutes'); + } + + if ( $ref->{rt_dep} + and $ref->{sched_dep} + and not defined $ref->{dep_delay} ) + { + $ref->{dep_delay} + = $ref->{rt_dep}->subtract_datetime( $ref->{sched_dep} ) + ->in_units('minutes'); + } + + $ref->{delay} = $ref->{dep_delay} // $ref->{arr_delay}; + return bless( $ref, $obj ); } sub TO_JSON { my ($self) = @_; - return { %{$self} }; + my $ret = { %{$self} }; + + for my $k (qw(sched_arr rt_arr arr sched_dep rt_dep dep)) { + if ( $ret->{$k} ) { + $ret->{$k} = $ret->{$k}->epoch; + } + } + + return $ret; } 1; @@ -41,14 +85,15 @@ in a Travel::Status::DE::EFA::Result's route for my $stop ($departure->route_post) { printf( "%s -> %s : %40s %s\n", - $stop->arr_time // q{ }, $stop->dep_time // q{ }, + $stop->arr ? $stop->arr->strftime('%H:%M') : q{--:--}, + $stop->dep ? $stop->dep->strftime('%H:%M') : q{--:--}, $stop->name, $stop->platform ); } =head1 VERSION -version 1.17 +version 3.13 =head1 DESCRIPTION @@ -60,32 +105,77 @@ delays or changed platforms are not taken into account. =head2 ACCESSORS +Most accessors return undef if the corresponding data is not available. + =over -=item $stop->arr_date +=item $stop->sched_arr -arrival date (DD.MM.YYYY). undef if this is the first scheduled stop. +DateTime(3pm) object holding scheduled arrival date and time. -=item $stop->arr_time +=item $stop->rt_arr -arrival time (HH:MM). undef if this is the first scheduled stop. +DateTime(3pm) object holding estimated (real-time) arrival date and time. -=item $stop->dep_date +=item $stop->arr -departure date (DD.MM.YYYY). undef if this is the final scehduled stop. +DateTime(3pm) object holding arrival date and time. Real-time data if +available, schedule data otherwise. -=item $stop->dep_time +=item $stop->arr_delay -departure time (HH:MM). undef if this is the final scehduled stop. +Arrival delay in minutes. -=item $stop->name +=item $stop->sched_dep + +DateTime(3pm) object holding scheduled departure date and time. + +=item $stop->rt_dep + +DateTime(3pm) object holding estimated (real-time) departure date and time. + +=item $stop->dep + +DateTime(3pm) object holding departure date and time. Real-time data if +available, schedule data otherwise. + +=item $stop->dep_delay + +Departure delay in minutes. + +=item $stop->delay -stop name with city prefix ("I<City> I<Stop>", for instance +Delay in minutes. Departure delya if available, arrival delay otherwise. + +=item $stop->distance_m + +Distance from request coordinates in meters. undef if the object has not +been obtained by means of a coord request. + +=item $stop->id_num + +Stop ID (numeric). + +=item $stop->id_code + +Stop ID (code). + +=item $stop->place + +Place or city name, for instance "Essen". + +=item $stop->full_name + +stop name with place or city prefix ("I<City> I<Stop>", for instance "Essen RE<uuml>ttenscheider Stern"). -=item $stop->name_suf +=item $stop->name + +stop name without place or city prefix, for instance "RE<uuml>ttenscheider Stern". + +=item $stop->latlon -stop name without city prefix, for instance "RE<uuml>ttenscheider Stern". +Arrayref describing the stop's latitude and longitude in WGS84 coordinates. =item $stop->platform @@ -122,7 +212,8 @@ None. =head1 BUGS AND LIMITATIONS -None known. +This module is a Work in Progress. +Its API may change between minor versions. =head1 SEE ALSO @@ -130,7 +221,7 @@ Travel::Status::DE::EFA(3pm). =head1 AUTHOR -Copyright (C) 2015 by Daniel Friesel E<lt>derf@finalrewind.orgE<gt> +Copyright (C) 2015-2025 Birte Kristina Friesel E<lt>derf@finalrewind.orgE<gt> =head1 LICENSE diff --git a/lib/Travel/Status/DE/EFA/Trip.pm b/lib/Travel/Status/DE/EFA/Trip.pm new file mode 100644 index 0000000..5b86695 --- /dev/null +++ b/lib/Travel/Status/DE/EFA/Trip.pm @@ -0,0 +1,342 @@ +package Travel::Status::DE::EFA::Trip; + +use strict; +use warnings; +use 5.010; + +use DateTime::Format::Strptime; +use Travel::Status::DE::EFA::Stop; + +use parent 'Class::Accessor'; + +our $VERSION = '3.13'; + +Travel::Status::DE::EFA::Trip->mk_ro_accessors( + qw(operator product product_class name line number type id dest_name dest_id) +); + +sub new { + my ( $obj, %conf ) = @_; + + my $json = $conf{json}{transportation} // $conf{json}{leg}{transportation}; + + my $ref = { + operator => $json->{operator}{name}, + product => $json->{product}{name}, + product_class => $json->{product}{class}, + polyline_raw => $conf{json}{leg}{coords}, + name => $json->{name}, + line => $json->{disassembledName}, + number => $json->{properties}{trainNumber}, + type => $json->{properties}{trainType} // $json->{product}{name}, + id => $json->{id}, + dest_name => $json->{destination}{name}, + dest_id => $json->{destination}{id}, + route_raw => $json->{locationSequence} + // $conf{json}{leg}{stopSequence}, + strptime_obj => DateTime::Format::Strptime->new( + pattern => '%Y-%m-%dT%H:%M:%SZ', + time_zone => 'UTC' + ), + }; + if ( ref( $ref->{polyline_raw} ) eq 'ARRAY' + and @{ $ref->{polyline_raw} } == 1 ) + { + $ref->{polyline_raw} = $ref->{polyline_raw}[0]; + } + return bless( $ref, $obj ); +} + +sub polyline { + my ( $self, %opt ) = @_; + + if ( $self->{polyline} ) { + return @{ $self->{polyline} }; + } + + if ( not @{ $self->{polyline_raw} // [] } ) { + if ( $opt{fallback} ) { + return map { + { + lat => $_->{latlon}[0], + lon => $_->{latlon}[1], + stop => $_, + } + } $self->route; + } + return; + } + + $self->{polyline} = [ map { { lat => $_->[0], lon => $_->[1] } } + @{ $self->{polyline_raw} } ]; + my $distance; + + eval { + require GIS::Distance; + $distance = GIS::Distance->new; + }; + + if ($distance) { + my %min_dist; + for my $stop ( $self->route ) { + for my $polyline_index ( 0 .. $#{ $self->{polyline} } ) { + my $pl = $self->{polyline}[$polyline_index]; + my $dist = $distance->distance_metal( + $stop->{latlon}[0], + $stop->{latlon}[1], + $pl->{lat}, $pl->{lon} + ); + if ( not $min_dist{ $stop->{id_code} } + or $min_dist{ $stop->{id_code} }{dist} > $dist ) + { + $min_dist{ $stop->{id_code} } = { + dist => $dist, + index => $polyline_index, + }; + } + } + } + for my $stop ( $self->route ) { + if ( $min_dist{ $stop->{id_code} } ) { + $self->{polyline}[ $min_dist{ $stop->{id_code} }{index} ]{stop} + = $stop; + } + } + } + + return @{ $self->{polyline} }; +} + +sub parse_dt { + my ( $self, $value ) = @_; + + if ($value) { + my $dt = $self->{strptime_obj}->parse_datetime($value); + if ($dt) { + return $dt->set_time_zone('Europe/Berlin'); + } + } + return undef; +} + +sub route { + my ($self) = @_; + + if ( $self->{route} ) { + return @{ $self->{route} }; + } + + for my $stop ( @{ $self->{route_raw} // [] } ) { + my $chain = $stop; + my ( $platform, $place, $name, $name_full, $id_num, $id_code ); + while ( $chain->{type} ) { + if ( $chain->{type} eq 'platform' ) { + $platform = $chain->{properties}{platformName} + // $chain->{properties}{platform}; + } + elsif ( $chain->{type} eq 'stop' ) { + $name = $chain->{disassembledName}; + $name_full = $chain->{name}; + $id_code = $chain->{id}; + $id_num = $chain->{properties}{stopId}; + } + elsif ( $chain->{type} eq 'locality' ) { + $place = $chain->{name}; + } + $chain = $chain->{parent}; + } + push( + @{ $self->{route} }, + Travel::Status::DE::EFA::Stop->new( + sched_arr => $self->parse_dt( $stop->{arrivalTimePlanned} ), + sched_dep => $self->parse_dt( $stop->{departureTimePlanned} ), + rt_arr => $self->parse_dt( $stop->{arrivalTimeEstimated} ), + rt_dep => $self->parse_dt( $stop->{departureTimeEstimated} ), + occupancy => $stop->{properties}{occupancy}, + is_cancelled => $stop->{isCancelled}, + latlon => $stop->{coord}, + full_name => $name_full, + name => $name, + place => $place, + niveau => $stop->{niveau}, + platform => $platform, + id_code => $id_code, + id_num => $id_num, + ) + ); + } + + delete $self->{route_raw}; + + return @{ $self->{route} // [] }; +} + +sub TO_JSON { + my ($self) = @_; + + # lazy loading + $self->route; + + # lazy loading + $self->polyline; + + my $ret = { %{$self} }; + + delete $ret->{strptime_obj}; + + return $ret; +} + +1; + +__END__ + +=head1 NAME + +Travel::Status::DE::EFA::Trip - Information about an individual public transit +trip + +=head1 SYNOPSIS + + printf( "%s %s -> %s\n", $trip->type, $trip->line // q{}, $trip->dest_name ); + for my $stop ( $trip->route ) { + ...; + } + +=head1 VERSION + +version 3.13 + +=head1 DESCRIPTION + +Travel::Status::DE::EFA::Trip describes a single trip / journey of a public +transport line. + +=head1 METHODS + +=head2 ACCESSORS + +Most accessors return undef if the corresponding data is not available. + +=over + +=item $trip->operator + +Operator name. + +=item $trip->product + +Product name. + +=item $trip->product_class + +Product class. + +=item $trip->name + +Trip or line name. + +=item $trip->line + +Line identifier. Note that this is not necessarily numeric. + +=item $trip->number + +Trip/journey number. + +=item $trip->type + +Transport / vehicle type, e.g. "RE" or "Bus". + +=item $trip->id + +Unique(?) trip ID + +=item $trip->dest_name + +Name of the trip's destination stop + +=item $trip->dest_id + +ID of the trip's destination stop + +=item $trip->route + +List of Travel::Status::DE::EFA::Stop(3pm) objects describing the route of this +trip. + +Note: The EFA API requires a stop to be specified when requesting trip details. +The stops returned by this accessor appear to be limited to stops after the +requested stop; earlier ones may be missing. + +=item $journey->polyline(I<%opt>) + +List of geocoordinates that describe the trips's route. +Each list entry is a hash with the following keys. + +=over + +=item * lon (longitude) + +=item * lat (latitude) + +=item * stop (Stop object for this location, if any. undef otherwise) + +=back + +Note that stop is not provided by the backend and instead inferred by this +module. + +If the backend does not provide geocoordinates and this accessor was called +with B< fallback > set to a true value, it returns the list of stop coordinates +instead. Otherwise, it returns an empty list. + +=back + +=head2 INTERNAL + +=over + +=item $trip = Travel::Status::DE::EFA::Trip->new(I<%data>) + +Returns a new Travel::Status::DE::EFA::Trip object. You should not need to +call this. + +=item $trip->TO_JSON + +Allows the object data to be serialized to JSON. + +=back + +=head1 DIAGNOSTICS + +None. + +=head1 DEPENDENCIES + +=over + +=item Class::Accessor(3pm) + +=item DateTime::Format::Strptime(3pm) + +=item Travel::Status::DE::EFA::Stop(3pm) + +=back + +=head1 BUGS AND LIMITATIONS + +This module is a Work in Progress. +Its API may change between minor versions. + +=head1 SEE ALSO + +Travel::Status::DE::EFA(3pm). + +=head1 AUTHOR + +Copyright (C) 2024-2025 Birte Kristina 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/VRR.pm b/lib/Travel/Status/DE/VRR.pm index 9552e73..6782523 100644 --- a/lib/Travel/Status/DE/VRR.pm +++ b/lib/Travel/Status/DE/VRR.pm @@ -4,9 +4,7 @@ use strict; use warnings; use 5.010; -no if $] >= 5.018, warnings => "experimental::smartmatch"; - -our $VERSION = '1.17'; +our $VERSION = '3.13'; use parent 'Travel::Status::DE::EFA'; @@ -37,14 +35,15 @@ Travel::Status::DE::VRR - unofficial VRR departure monitor. for my $d ($status->results) { printf( "%s %d %-5s %s\n", - $d->time, $d->platform, $d->line, $d->destination + $d->datetime->strftime('%H:%M'), + $d->platform, $d->line, $d->destination ); } =head1 VERSION -version 1.17 +version 3.13 =head1 DESCRIPTION @@ -96,7 +95,7 @@ efa-m(1), Travel::Status::DE::EFA(3pm). =head1 AUTHOR -Copyright (C) 2013-2015 by Daniel Friesel E<lt>derf@finalrewind.orgE<gt> +Copyright (C) 2013-2023 Birte Kristina Friesel E<lt>derf@finalrewind.orgE<gt> =head1 LICENSE |