From c438b3c4e210a4480652f297f1bf9510cdf44244 Mon Sep 17 00:00:00 2001 From: Birte Kristina Friesel Date: Sun, 22 Sep 2024 13:19:14 +0200 Subject: Switch from XML to JSON API flavour --- lib/Travel/Status/DE/EFA.pm | 608 ++++++++++++---------------------- lib/Travel/Status/DE/EFA/Departure.pm | 357 ++++++++++++++++++++ lib/Travel/Status/DE/EFA/Line.pm | 2 +- lib/Travel/Status/DE/EFA/Result.pm | 348 ------------------- 4 files changed, 568 insertions(+), 747 deletions(-) create mode 100644 lib/Travel/Status/DE/EFA/Departure.pm delete mode 100644 lib/Travel/Status/DE/EFA/Result.pm (limited to 'lib/Travel/Status/DE') diff --git a/lib/Travel/Status/DE/EFA.pm b/lib/Travel/Status/DE/EFA.pm index ca207d5..eb104b3 100644 --- a/lib/Travel/Status/DE/EFA.pm +++ b/lib/Travel/Status/DE/EFA.pm @@ -9,75 +9,78 @@ our $VERSION = '2.02'; use Carp qw(confess cluck); use DateTime; +use DateTime::Format::Strptime; use Encode qw(encode); +use JSON; use Travel::Status::DE::EFA::Line; -use Travel::Status::DE::EFA::Result; +use Travel::Status::DE::EFA::Departure; use Travel::Status::DE::EFA::Stop; use LWP::UserAgent; -use XML::LibXML; my %efa_instance = ( BSVG => { - url => 'https://bsvg.efa.de/bsvagstd/XML_DM_REQUEST', + url => 'https://bsvg.efa.de/bsvagstd', name => 'Braunschweiger Verkehrs-GmbH', }, DING => { - url => 'https://www.ding.eu/ding3/XSLT_DM_REQUEST', + url => 'https://www.ding.eu/ding3', + stopseq => +'https://www.ding.eu/ding3/XML_STOPSEQCOORD_REQUEST?=&jsonp=jsonpFn5&line=din:87002: :R:j24&stop=9001008&tripCode=290&date=20240520&time=14.0041.00&coordOutputFormat=WGS84[DD.DDDDD]&coordListOutputFormat=string&outputFormat=json&tStOTType=NEXT&hideBannerInfo=1', name => 'Donau-Iller Nahverkehrsverbund', }, KVV => { - url => 'https://projekte.kvv-efa.de/sl3-alone/XSLT_DM_REQUEST', + url => 'https://projekte.kvv-efa.de/sl3-alone', name => 'Karlsruher Verkehrsverbund', }, LinzAG => { - url => 'https://www.linzag.at/static/XSLT_DM_REQUEST', + url => 'https://www.linzag.at/static', name => 'Linz AG', encoding => 'iso-8859-15', }, MVV => { - url => 'https://efa.mvv-muenchen.de/mobile/XSLT_DM_REQUEST', + url => 'https://efa.mvv-muenchen.de/mobile', name => 'Münchner Verkehrs- und Tarifverbund', }, NVBW => { - url => 'https://www.efa-bw.de/nvbw/XSLT_DM_REQUEST', + url => 'https://www.efa-bw.de/nvbw', name => 'Nahverkehrsgesellschaft Baden-Württemberg', }, VAG => { - url => 'https://efa.vagfr.de/vagfr3/XSLT_DM_REQUEST', + url => 'https://efa.vagfr.de/vagfr3', name => 'Freiburger Verkehrs AG', }, VGN => { - url => 'https://efa.vgn.de/vgnExt_oeffi/XML_DM_REQUEST', + url => 'https://efa.vgn.de/vgnExt_oeffi', name => 'Verkehrsverbund Grossraum Nuernberg', }, # HTTPS: certificate verification fails VMV => { - url => 'http://efa.vmv-mbh.de/vmv/XML_DM_REQUEST', + url => 'http://efa.vmv-mbh.de/vmv', name => 'Verkehrsgesellschaft Mecklenburg-Vorpommern', }, VRN => { - url => 'https://www.vrn.de/mngvrn//XML_DM_REQUEST', + url => 'https://www.vrn.de/mngvrn/', name => 'Verkehrsverbund Rhein-Neckar', }, VRR => { - url => 'https://efa.vrr.de/vrr/XSLT_DM_REQUEST', + url => 'https://efa.vrr.de/vrr', name => 'Verkehrsverbund Rhein-Ruhr', }, VRR2 => { - url => 'https://app.vrr.de/standard/XML_DM_REQUEST', + url => 'https://app.vrr.de/standard', name => 'Verkehrsverbund Rhein-Ruhr (alternative)', }, VRR3 => { - url => 'https://efa.vrr.de/rbgstd3/XML_DM_REQUEST', + url => 'https://efa.vrr.de/rbgstd3', name => 'Verkehrsverbund Rhein-Ruhr (alternative alternative)', }, VVO => { - url => 'https://efa.vvo-online.de/VMSSL3/XSLT_DM_REQUEST', + url => 'https://efa.vvo-online.de/VMSSL3', name => 'Verkehrsverbund Oberelbe', }, VVS => { - url => 'https://www2.vvs.de/vvs/XSLT_DM_REQUEST', + url => 'https://www2.vvs.de/vvs', name => 'Verkehrsverbund Stuttgart', }, @@ -107,26 +110,10 @@ sub new_p { } my $content = $tx->res->body; - if ( $opt{efa_encoding} ) { - $self->{xml} = encode( $opt{efa_encoding}, $content ); - } - else { - $self->{xml} = $content; - } - - if ( not $self->{xml} ) { - - # LibXML doesn't like empty documents - $promise->reject('Server returned nothing (empty result)'); - return; - } - - $self->{tree} = XML::LibXML->load_xml( - string => $self->{xml}, - ); + $self->{response} = $self->{json}->decode($content); if ( $self->{developer_mode} ) { - say $self->{tree}->toString(1); + say $self->{json}->pretty->encode( $self->{response} ); } $self->check_for_ambiguous(); @@ -158,7 +145,7 @@ sub new { delete $opt{timeout}; } - if ( not( $opt{name} ) ) { + if ( not( $opt{name} or $opt{from_json} ) ) { confess('You must specify a name'); } if ( $opt{type} @@ -169,6 +156,12 @@ sub new { if ( $opt{service} and exists $efa_instance{ $opt{service} } ) { $opt{efa_url} = $efa_instance{ $opt{service} }{url}; + if ( $opt{journey} ) { + $opt{efa_url} .= '/XML_STOPSEQCOORD_REQUEST'; + } + else { + $opt{efa_url} .= '/XML_DM_REQUEST'; + } $opt{time_zone} //= $efa_instance{ $opt{service} }{time_zone}; } @@ -219,39 +212,33 @@ sub new { my $self = { post => { - command => q{}, - deleteAssignedStops_dm => '1', - help => 'Hilfe', - itdDateDay => $dt->day, - itdDateMonth => $dt->month, - itdDateYear => $dt->year, - 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 => $dt->hour, - itdTimeMinute => $dt->minute, - language => 'de', - mode => 'direct', - nameInfo_dm => 'invalid', - nameState_dm => 'empty', - name_dm => encode( 'UTF-8', $opt{name} ), - outputFormat => 'XML', - ptOptionsActive => '1', - requestID => '0', - reset => 'neue Anfrage', - sessionID => '0', - submitButton => 'anfordern', - typeInfo_dm => 'invalid', - type_dm => $opt{type} // 'stop', - useProxFootSearch => $opt{proximity_search} ? '1' : '0', - useRealtime => '1', + 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} ), }, + 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 => 'Europe/Berlin', + ), + strp_stopseq_s => DateTime::Format::Strptime->new( + pattern => '%Y%m%d %H:%M:%S', + time_zone => 'Europe/Berlin', + ), + + json => JSON->new->utf8, }; if ( $opt{place} ) { @@ -281,33 +268,26 @@ sub new { return $self; } - my $response = $self->{ua}->post( $self->{efa_url}, $self->{post} ); - - if ( $response->is_error ) { - $self->{errstr} = $response->status_line; - return $self; + if ( $self->{developer_mode} ) { + say 'POST ' . $self->{efa_url}; + while ( my ( $key, $value ) = each %{ $self->{post} } ) { + printf( "%30s = %s\n", $key, $value ); + } } - if ( $opt{efa_encoding} ) { - $self->{xml} = encode( $opt{efa_encoding}, $response->content ); - } - else { - $self->{xml} = $response->decoded_content; - } + if ( not $self->{response} ) { + my $response = $self->{ua}->post( $self->{efa_url}, $self->{post} ); - if ( not $self->{xml} ) { + if ( $response->is_error ) { + $self->{errstr} = $response->status_line; + return $self; + } - # LibXML doesn't like empty documents - $self->{errstr} = 'Server returned nothing (empty result)'; - return $self; + $self->{response} = $self->{json}->decode( $response->content ); } - $self->{tree} = XML::LibXML->load_xml( - string => $self->{xml}, - ); - if ( $self->{developer_mode} ) { - say $self->{tree}->toString(1); + say $self->{json}->pretty->encode( $self->{response} ); } $self->check_for_ambiguous(); @@ -315,20 +295,6 @@ sub new { return $self; } -sub new_from_xml { - my ( $class, %opt ) = @_; - - my $self = { - xml => $opt{xml}, - }; - - $self->{tree} = XML::LibXML->load_xml( - string => $self->{xml}, - ); - - return bless( $self, $class ); -} - sub errstr { my ($self) = @_; @@ -356,182 +322,98 @@ sub place_candidates { sub check_for_ambiguous { my ($self) = @_; - my $xml = $self->{tree}; + my $json = $self->{response}; - 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 $xp_place_elem = XML::LibXML::XPathExpression->new('./odvPlaceElem'); - my $xp_name_elem = XML::LibXML::XPathExpression->new('./odvNameElem'); - - my $e_place = ( $xml->findnodes($xp_place) )[0]; - my $e_name = ( $xml->findnodes($xp_name) )[0]; - my @e_mesg = $xml->findnodes($xp_mesg); - - if ( not( $e_place and $e_name ) ) { - - # this should not happen[tm] - cluck('skipping ambiguity check- itdOdvPlace/itdOdvName missing'); - return; - } - - my $s_place = $e_place->getAttribute('state'); - my $s_name = $e_name->getAttribute('state'); - - if ( $s_place eq 'list' ) { - $self->{place_candidates} = [ map { $_->textContent } - @{ $e_place->findnodes($xp_place_elem) } ]; - $self->{errstr} = 'ambiguous place parameter'; + if ( $json->{departureList} ) { return; } - 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; + 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} + = [ map { $_->{name} } @{ $json->{dm}{points} // [] } ]; + return; + } + if ( $m->{name} eq 'error' and $m->{value} eq 'place list' ) { + $self->{errstr} = "ambiguous name parameter"; + $self->{name_candidates} + = [ map { $_->{name} } @{ $json->{dm}{points} // [] } ]; + return; + } } return; } -sub identified_data { - my ($self) = @_; - - if ( not $self->{tree} ) { - return; - } - - 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]; - - return ( $e_place->textContent, $e_name->textContent ); -} - sub lines { my ($self) = @_; - my @lines; if ( $self->{lines} ) { return @{ $self->{lines} }; } - if ( not $self->{tree} ) { - return; - } - - my $xp_element - = XML::LibXML::XPathExpression->new('//itdServingLines/itdServingLine'); - - 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'); - - for my $e ( $self->{tree}->findnodes($xp_element) ) { - - my $e_info = ( $e->findnodes($xp_info) )[0]; - my $e_route = ( $e->findnodes($xp_route) )[0]; - my $e_oper = ( $e->findnodes($xp_oper) )[0]; - - 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'); - - push( - @lines, - Travel::Status::DE::EFA::Line->new( - name => $line, - direction => $direction, - valid => $valid, - type => $type, - mot => $mot, - route => $route, - operator => $operator, - identifier => $identifier, - ) - ); + for my $line ( @{ $self->{response}{servingLines}{lines} // [] } ) { + push( @{ $self->{lines} }, $self->parse_line($line) ); } - $self->{lines} = \@lines; + return @{ $self->{lines} // [] }; +} - return @lines; +sub parse_line { + my ( $self, $line ) = @_; + + my $mode = $line->{mode} // {}; + + 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}, + , + ); } 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 ( $self, $stop_seq, $requested_id ) = @_; my @ret; - for my $e (@nodes) { - my @dates = $e->findnodes($xp_routepoint_date); - my @times = $e->findnodes($xp_routepoint_time); + 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 ); - # 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. - - if ( $dates[0] and $times[0] and $dates[0]->getAttribute('day') != -1 ) - { - $arr = DateTime->new( - year => $dates[0]->getAttribute('year'), - month => $dates[0]->getAttribute('month'), - day => $dates[0]->getAttribute('day'), - hour => $times[0]->getAttribute('hour'), - minute => $times[0]->getAttribute('minute'), - second => $times[0]->getAttribute('second') // 0, - time_zone => 'Europe/Berlin' - ); + if ( $ref->{arrDateTimeSec} ) { + $arr = $self->{strp_stopseq_s} + ->parse_datetime( $ref->{arrDateTimeSec} ); + } + elsif ( $ref->{arrDateTime} ) { + $arr = $self->{strp_stopseq}->parse_datetime( $ref->{arrDateTime} ); } - if ( $dates[-1] - and $times[-1] - and $dates[-1]->getAttribute('day') != -1 ) - { - $dep = DateTime->new( - year => $dates[-1]->getAttribute('year'), - month => $dates[-1]->getAttribute('month'), - day => $dates[-1]->getAttribute('day'), - hour => $times[-1]->getAttribute('hour'), - minute => $times[-1]->getAttribute('minute'), - second => $times[-1]->getAttribute('second') // 0, - time_zone => 'Europe/Berlin' - ); + if ( $ref->{depDateTimeSec} ) { + $dep = $self->{strp_stopseq_s} + ->parse_datetime( $ref->{depDateTimeSec} ); + } + elsif ( $ref->{depDateTime} ) { + $dep = $self->{strp_stopseq}->parse_datetime( $ref->{depDateTime} ); } push( @@ -539,14 +421,79 @@ sub parse_route { Travel::Status::DE::EFA::Stop->new( arr => $arr, dep => $dep, - name => $e->getAttribute('name'), - name_suf => $e->getAttribute('nameWO'), - platform => $e->getAttribute('platformName'), + name => $stop->{name}, + name_suf => $stop->{nameWO}, + platform => $ref->{platform} || $stop->{platformName} || undef, ) ); } - return @ret; + return \@ret; +} + +sub parse_departure { + my ( $self, $departure ) = @_; + + my ( $sched_dt, $real_dt ); + my ( $prev_route, $next_route ); + + 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', + ); + } + + if ( $departure->{prevStopSeq} ) { + $prev_route = $self->parse_route( $departure->{prevStopSeq}, + $departure->{stopID} ); + } + if ( $departure->{onwardStopSeq} ) { + $next_route = $self->parse_route( $departure->{onwardStopSeq}, + $departure->{stopID} ); + } + + my @hints + = map { $_->{content} } @{ $departure->{servingLine}{hints} // [] }; + + return Travel::Status::DE::EFA::Departure->new( + rt_datetime => $real_dt, + platform => $departure->{platform}, + platform_name => $departure->{platformName}, + platform_type => $departure->{pointType}, + 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, + prev_route => $prev_route, + next_route => $next_route, + ); } sub results { @@ -557,147 +504,10 @@ sub results { return @{ $self->{results} }; } - if ( not $self->{tree} ) { - return; - } - - 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; - } - - my ( $sched_dt, $real_dt ); - - if ( $e_date and $e_time and $e_date->getAttribute('day') != -1 ) { - $sched_dt = DateTime->new( - year => $e_date->getAttribute('year'), - month => $e_date->getAttribute('month'), - day => $e_date->getAttribute('day'), - hour => $e_time->getAttribute('hour'), - minute => $e_time->getAttribute('minute'), - second => $e_time->getAttribute('second') // 0, - time_zone => 'Europe/Berlin' - ); - } - - if ( $e_rdate and $e_rtime and $e_rdate->getAttribute('day') != -1 ) { - $real_dt = DateTime->new( - year => $e_rdate->getAttribute('year'), - month => $e_rdate->getAttribute('month'), - day => $e_rdate->getAttribute('day'), - hour => $e_rtime->getAttribute('hour'), - minute => $e_rtime->getAttribute('minute'), - second => $e_rtime->getAttribute('second') // 0, - time_zone => 'Europe/Berlin' - ); - } - - my $platform = $e->getAttribute('platform'); - my $platform_name = $e->getAttribute('platformName'); - my $countdown = $e->getAttribute('countdown'); - my $occupancy = $e->getAttribute('occupancy'); - my $line = $e_line->getAttribute('number'); - my $train_type = $e_line->getAttribute('trainType'); - my $train_name = $e_line->getAttribute('trainName'); - my $train_no = $e_line->getAttribute('trainNum'); - my $dest = $e_line->getAttribute('direction'); - my $info = $e_info->textContent; - my $key = $e_line->getAttribute('key'); - 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) ] } ); - } + my $json = $self->{response}; - 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; - } - - if ( $platform_name and $platform_name =~ m{ ^ (Gleis | Bstg[.])}ox ) { - $platform = ( split( / /, $platform_name ) )[1]; - } - elsif ( $platform_name and not $platform ) { - $platform = $platform_name; - } - - push( - @results, - Travel::Status::DE::EFA::Result->new( - rt_datetime => $real_dt, - platform => $platform, - platform_db => $platform_is_db, - platform_name => $platform_name, - key => $key, - lineref => $line_obj[0] // undef, - line => $line, - train_type => $train_type, - train_name => $train_name, - train_no => $train_no, - destination => $dest, - occupancy => $occupancy, - countdown => $countdown, - info => $info, - delay => $delay, - sched_datetime => $sched_dt, - type => $type, - mot => $mot, - prev_route => \@prev_route, - next_route => \@next_route, - ) - ); + for my $departure ( @{ $json->{departureList} // [] } ) { + push( @results, $self->parse_departure($departure) ); } @results = map { $_->[0] } @@ -734,7 +544,7 @@ 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', + efa_url => 'https://efa.vrr.de/vrr/XML_DM_REQUEST', name => 'Essen Helenenstr' ); @@ -805,7 +615,7 @@ iso-8859-15. If true: Request full routes for all departures from the backend. This enables the B, B and B accessors in -Travel::Status::DE::EFA::Result(3pm). +Travel::Status::DE::EFA::Departure(3pm). =item B => B<0>|B<1> @@ -867,7 +677,7 @@ nothing (undef / empty list) otherwise. =item $status->results -Returns a list of Travel::Status::DE::EFA::Result(3pm) objects, each one describing +Returns a list of Travel::Status::DE::EFA::Departure(3pm) objects, each one describing one departure. =item Travel::Status::DE::EFA::get_efa_urls() @@ -906,23 +716,25 @@ None. =item * DateTime(3pm) -=item * LWP::UserAgent(3pm) +=item * DateTime::Format::Strptime(3pm) + +=item * JSON(3pm) -=item * XML::LibXML(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-2023 by Birte Kristina Friesel Ederf@finalrewind.orgE +Copyright (C) 2011-2024 by Birte Kristina Friesel Ederf@finalrewind.orgE =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..802f84e --- /dev/null +++ b/lib/Travel/Status/DE/EFA/Departure.pm @@ -0,0 +1,357 @@ +package Travel::Status::DE::EFA::Departure; + +use strict; +use warnings; +use 5.010; + +use parent 'Class::Accessor'; + +our $VERSION = '2.02'; + +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 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 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; + } + + $ref->{datetime} = $ref->{rt_datetime} // $ref->{sched_datetime}; + + return bless( $ref, $obj ); +} + +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_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::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 2.02 + +=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->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 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->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. 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->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. + +=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 * StraEenbahn + +=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-2023 by Birte Kristina Friesel Ederf@finalrewind.orgE + +=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 69526fd..4f44c7b 100644 --- a/lib/Travel/Status/DE/EFA/Line.pm +++ b/lib/Travel/Status/DE/EFA/Line.pm @@ -9,7 +9,7 @@ use parent 'Class::Accessor'; our $VERSION = '2.02'; 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 diff --git a/lib/Travel/Status/DE/EFA/Result.pm b/lib/Travel/Status/DE/EFA/Result.pm deleted file mode 100644 index 11ff15a..0000000 --- a/lib/Travel/Status/DE/EFA/Result.pm +++ /dev/null @@ -1,348 +0,0 @@ -package Travel::Status::DE::EFA::Result; - -use strict; -use warnings; -use 5.010; - -use parent 'Class::Accessor'; - -our $VERSION = '2.02'; - -Travel::Status::DE::EFA::Result->mk_ro_accessors( - qw(countdown datetime delay destination is_cancelled info key line lineref - mot occupancy operator platform platform_db platform_name rt_datetime - sched_datetime 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 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; - } - - $ref->{datetime} = $ref->{rt_datetime} // $ref->{sched_datetime}; - - 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->datetime->strftime('%H:%M'), $departure->line, - $departure->destination, $departure->platform - ); - } - -=head1 VERSION - -version 2.02 - -=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 - -=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->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 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->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->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. 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->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. - -=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 * StraEenbahn - -=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-2023 by Birte Kristina Friesel Ederf@finalrewind.orgE - -=head1 LICENSE - -This module is licensed under the same terms as Perl itself. -- cgit v1.2.3