File Coverage

blib/lib/Travel/Status/DE/EFA.pm
Criterion Covered Total %
statement 161 257 62.6
branch 25 82 30.4
condition 11 39 28.2
subroutine 22 25 88.0
pod 8 13 61.5
total 227 416 54.5


line stmt bran cond sub pod time code
1             package Travel::Status::DE::EFA;
2              
3 2     2   1107 use strict;
  2         6  
  2         63  
4 2     2   13 use warnings;
  2         4  
  2         49  
5 2     2   41 use 5.010;
  2         10  
6 2     2   12 use utf8;
  2         4  
  2         31  
7              
8             our $VERSION = '1.22';
9              
10 2     2   112 use Carp qw(confess cluck);
  2         4  
  2         138  
11 2     2   644 use Encode qw(encode);
  2         16207  
  2         198  
12 2     2   990 use Travel::Status::DE::EFA::Line;
  2         14  
  2         11  
13 2     2   1053 use Travel::Status::DE::EFA::Result;
  2         6  
  2         14  
14 2     2   1024 use Travel::Status::DE::EFA::Stop;
  2         6  
  2         10  
15 2     2   1793 use LWP::UserAgent;
  2         110953  
  2         89  
16 2     2   1537 use XML::LibXML;
  2         68280  
  2         25  
17              
18             sub new {
19 0     0 1 0 my ( $class, %opt ) = @_;
20              
21 0   0     0 $opt{timeout} //= 10;
22 0 0       0 if ( $opt{timeout} <= 0 ) {
23 0         0 delete $opt{timeout};
24             }
25              
26 0         0 my $ua = LWP::UserAgent->new(%opt);
27 0         0 my @now = localtime( time() );
28              
29 0         0 my @time = @now[ 2, 1 ];
30 0         0 my @date = ( $now[3], $now[4] + 1, $now[5] + 1900 );
31              
32 0 0       0 if ( not( $opt{name} ) ) {
33 0         0 confess('You must specify a name');
34             }
35 0 0 0     0 if ( $opt{type}
36             and not( $opt{type} =~ m{ ^ (?: stop stopID address poi ) $ }x ) )
37             {
38 0         0 confess('type must be stop, stopID, address, or poi');
39             }
40              
41 0 0       0 if ( not $opt{efa_url} ) {
42 0         0 confess('efa_url is mandatory');
43             }
44              
45             ## no critic (RegularExpressions::ProhibitUnusedCapture)
46             ## no critic (Variables::ProhibitPunctuationVars)
47              
48 0 0 0     0 if ( $opt{time}
    0          
49             and $opt{time} =~ m{ ^ (? \d\d? ) : (? \d\d ) $ }x )
50             {
51 2     2   1835 @time = @+{qw{hour minute}};
  2         759  
  2         7162  
  0         0  
52             }
53             elsif ( $opt{time} ) {
54 0         0 confess('Invalid time specified');
55             }
56              
57 0 0 0     0 if (
    0          
58             $opt{date}
59             and $opt{date} =~ m{ ^ (? \d\d? ) [.] (? \d\d? ) [.]
60             (? \d{4} )? $ }x
61             )
62             {
63 0 0       0 if ( $+{year} ) {
64 0         0 @date = @+{qw{day month year}};
65             }
66             else {
67 0         0 @date[ 0, 1 ] = @+{qw{day month}};
68             }
69             }
70             elsif ( $opt{date} ) {
71 0         0 confess('Invalid date specified');
72             }
73              
74             my $self = {
75             post => {
76             command => q{},
77             deleteAssignedStops_dm => '1',
78             help => 'Hilfe',
79             itdDateDay => $date[0],
80             itdDateMonth => $date[1],
81             itdDateYear => $date[2],
82             itdLPxx_id_dm => ':dm',
83             itdLPxx_mapState_dm => q{},
84             itdLPxx_mdvMap2_dm => q{},
85             itdLPxx_mdvMap_dm => '3406199:401077:NAV3',
86             itdLPxx_transpCompany => 'vrr',
87             itdLPxx_view => q{},
88             itdTimeHour => $time[0],
89             itdTimeMinute => $time[1],
90             language => 'de',
91             mode => 'direct',
92             nameInfo_dm => 'invalid',
93             nameState_dm => 'empty',
94             name_dm => encode( 'UTF-8', $opt{name} ),
95             outputFormat => 'XML',
96             ptOptionsActive => '1',
97             requestID => '0',
98             reset => 'neue Anfrage',
99             sessionID => '0',
100             submitButton => 'anfordern',
101             typeInfo_dm => 'invalid',
102             type_dm => $opt{type} // 'stop',
103             useProxFootSearch => $opt{proximity_search} ? '1' : '0',
104             useRealtime => '1',
105             },
106             developer_mode => $opt{developer_mode},
107 0 0 0     0 };
108              
109 0 0       0 if ( $opt{place} ) {
110 0         0 $self->{post}{placeInfo_dm} = 'invalid';
111 0         0 $self->{post}{placeState_dm} = 'empty';
112 0         0 $self->{post}{place_dm} = encode( 'UTF-8', $opt{place} );
113             }
114              
115 0 0       0 if ( $opt{full_routes} ) {
116 0         0 $self->{post}->{depType} = 'stopEvents';
117 0         0 $self->{post}->{includeCompleteStopSeq} = 1;
118 0         0 $self->{want_full_routes} = 1;
119             }
120              
121 0         0 bless( $self, $class );
122              
123 0         0 $ua->env_proxy;
124              
125 0         0 my $response = $ua->post( $opt{efa_url}, $self->{post} );
126              
127 0 0       0 if ( $response->is_error ) {
128 0         0 $self->{errstr} = $response->status_line;
129 0         0 return $self;
130             }
131              
132 0 0       0 if ( $opt{efa_encoding} ) {
133 0         0 $self->{xml} = encode( $opt{efa_encoding}, $response->content );
134             }
135             else {
136 0         0 $self->{xml} = $response->decoded_content;
137             }
138              
139 0 0       0 if ( not $self->{xml} ) {
140              
141             # LibXML doesn't like empty documents
142 0         0 $self->{errstr} = 'Server returned nothing (empty result)';
143 0         0 return $self;
144             }
145              
146             $self->{tree} = XML::LibXML->load_xml(
147             string => $self->{xml},
148 0         0 );
149              
150 0 0       0 if ( $self->{developer_mode} ) {
151 0         0 say $self->{tree}->toString(1);
152             }
153              
154 0         0 $self->check_for_ambiguous();
155              
156 0         0 return $self;
157             }
158              
159             sub new_from_xml {
160 2     2 0 2229 my ( $class, %opt ) = @_;
161              
162             my $self = {
163             xml => $opt{xml},
164 2         10 };
165              
166             $self->{tree} = XML::LibXML->load_xml(
167             string => $self->{xml},
168 2         14 );
169              
170 2         5420 return bless( $self, $class );
171             }
172              
173             sub errstr {
174 2     2 1 911 my ($self) = @_;
175              
176 2         14 return $self->{errstr};
177             }
178              
179             sub name_candidates {
180 1     1 1 4 my ($self) = @_;
181              
182 1 50       4 if ( $self->{name_candidates} ) {
183 1         2 return @{ $self->{name_candidates} };
  1         6  
184             }
185 0         0 return;
186             }
187              
188             sub place_candidates {
189 1     1 1 5 my ($self) = @_;
190              
191 1 50       5 if ( $self->{place_candidates} ) {
192 0         0 return @{ $self->{place_candidates} };
  0         0  
193             }
194 1         6 return;
195             }
196              
197             sub sprintf_date {
198 49     49 0 114 my ($e) = @_;
199              
200 49 50       98 if ( $e->getAttribute('day') == -1 ) {
201 0         0 return;
202             }
203              
204 49         558 return sprintf( '%02d.%02d.%d',
205             $e->getAttribute('day'),
206             $e->getAttribute('month'),
207             $e->getAttribute('year'),
208             );
209             }
210              
211             sub sprintf_time {
212 49     49 0 116 my ($e) = @_;
213              
214 49 50       98 if ( $e->getAttribute('minute') == -1 ) {
215 0         0 return;
216             }
217              
218 49         466 return sprintf( '%02d:%02d',
219             $e->getAttribute('hour'),
220             $e->getAttribute('minute'),
221             );
222             }
223              
224             sub check_for_ambiguous {
225 1     1 0 919 my ($self) = @_;
226              
227 1         6 my $xml = $self->{tree};
228              
229 1         45 my $xp_place = XML::LibXML::XPathExpression->new('//itdOdv/itdOdvPlace');
230 1         9 my $xp_name = XML::LibXML::XPathExpression->new('//itdOdv/itdOdvName');
231 1         19 my $xp_mesg
232             = XML::LibXML::XPathExpression->new('//itdMessage[@type="error"]');
233              
234 1         6 my $xp_place_elem = XML::LibXML::XPathExpression->new('./odvPlaceElem');
235 1         7 my $xp_name_elem = XML::LibXML::XPathExpression->new('./odvNameElem');
236              
237 1         10 my $e_place = ( $xml->findnodes($xp_place) )[0];
238 1         100 my $e_name = ( $xml->findnodes($xp_name) )[0];
239 1         31 my @e_mesg = $xml->findnodes($xp_mesg);
240              
241 1 50 33     98 if ( not( $e_place and $e_name ) ) {
242              
243             # this should not happen[tm]
244 0         0 cluck('skipping ambiguity check- itdOdvPlace/itdOdvName missing');
245 0         0 return;
246             }
247              
248 1         22 my $s_place = $e_place->getAttribute('state');
249 1         22 my $s_name = $e_name->getAttribute('state');
250              
251 1 50       15 if ( $s_place eq 'list' ) {
252 0         0 $self->{place_candidates} = [ map { $_->textContent }
253 0         0 @{ $e_place->findnodes($xp_place_elem) } ];
  0         0  
254 0         0 $self->{errstr} = 'ambiguous place parameter';
255 0         0 return;
256             }
257 1 50       6 if ( $s_name eq 'list' ) {
258             $self->{name_candidates}
259 1         2 = [ map { $_->textContent } @{ $e_name->findnodes($xp_name_elem) } ];
  2         125  
  1         6  
260              
261 1         10 $self->{errstr} = 'ambiguous name parameter';
262 1         45 return;
263             }
264 0 0       0 if ( $s_place eq 'notidentified' ) {
265 0         0 $self->{errstr} = 'invalid place parameter';
266 0         0 return;
267             }
268 0 0       0 if ( $s_name eq 'notidentified' ) {
269 0         0 $self->{errstr} = 'invalid name parameter';
270 0         0 return;
271             }
272 0 0       0 if (@e_mesg) {
273 0         0 $self->{errstr} = join( q{; }, map { $_->textContent } @e_mesg );
  0         0  
274 0         0 return;
275             }
276              
277 0         0 return;
278             }
279              
280             sub identified_data {
281 2     2 1 7 my ($self) = @_;
282              
283 2 50       52 if ( not $self->{tree} ) {
284 0         0 return;
285             }
286              
287 2         58 my $xp_place
288             = XML::LibXML::XPathExpression->new('//itdOdv/itdOdvPlace/odvPlaceElem');
289 2         14 my $xp_name
290             = XML::LibXML::XPathExpression->new('//itdOdv/itdOdvName/odvNameElem');
291              
292 2         14 my $e_place = ( $self->{tree}->findnodes($xp_place) )[0];
293 2         220 my $e_name = ( $self->{tree}->findnodes($xp_name) )[0];
294              
295 2         130 return ( $e_place->textContent, $e_name->textContent );
296             }
297              
298             sub lines {
299 3     3 1 11 my ($self) = @_;
300 3         8 my @lines;
301              
302 3 100       16 if ( $self->{lines} ) {
303 1         31 return @{ $self->{lines} };
  1         5  
304             }
305              
306 2 50       39 if ( not $self->{tree} ) {
307 0         0 return;
308             }
309              
310 2         49 my $xp_element
311             = XML::LibXML::XPathExpression->new('//itdServingLines/itdServingLine');
312              
313 2         12 my $xp_info = XML::LibXML::XPathExpression->new('./itdNoTrain');
314 2         22 my $xp_route = XML::LibXML::XPathExpression->new('./itdRouteDescText');
315 2         21 my $xp_oper = XML::LibXML::XPathExpression->new('./itdOperator/name');
316              
317 2         11 for my $e ( $self->{tree}->findnodes($xp_element) ) {
318              
319 54         1477 my $e_info = ( $e->findnodes($xp_info) )[0];
320 54         1406 my $e_route = ( $e->findnodes($xp_route) )[0];
321 54         1041 my $e_oper = ( $e->findnodes($xp_oper) )[0];
322              
323 54 50       1077 if ( not($e_info) ) {
324 0         0 cluck( 'node with insufficient data. This should not happen. '
325             . $e->getAttribute('number') );
326 0         0 next;
327             }
328              
329 54         296 my $line = $e->getAttribute('number');
330 54         535 my $direction = $e->getAttribute('direction');
331 54         449 my $valid = $e->getAttribute('valid');
332 54         429 my $type = $e_info->getAttribute('name');
333 54         421 my $mot = $e->getAttribute('motType');
334 54 100       448 my $route = ( $e_route ? $e_route->textContent : undef );
335 54 50       405 my $operator = ( $e_oper ? $e_oper->textContent : undef );
336 54         329 my $identifier = $e->getAttribute('stateless');
337              
338 54         497 push(
339             @lines,
340             Travel::Status::DE::EFA::Line->new(
341             name => $line,
342             direction => $direction,
343             valid => $valid,
344             type => $type,
345             mot => $mot,
346             route => $route,
347             operator => $operator,
348             identifier => $identifier,
349             )
350             );
351             }
352              
353 2         82 $self->{lines} = \@lines;
354              
355 2         374 return @lines;
356             }
357              
358             sub parse_route {
359 0     0 0 0 my ( $self, @nodes ) = @_;
360 0         0 my $xp_routepoint_date
361             = XML::LibXML::XPathExpression->new('./itdDateTime/itdDate');
362 0         0 my $xp_routepoint_time
363             = XML::LibXML::XPathExpression->new('./itdDateTime/itdTime');
364              
365 0         0 my @ret;
366              
367 0         0 for my $e (@nodes) {
368 0         0 my @dates = $e->findnodes($xp_routepoint_date);
369 0         0 my @times = $e->findnodes($xp_routepoint_time);
370              
371             # note that the first stop has an arrival node with an invalid
372             # timestamp and the terminal stop has a departure node with an
373             # invalid timestamp. sprintf_{date,time} return undef in these
374             # cases.
375 0         0 push(
376             @ret,
377             Travel::Status::DE::EFA::Stop->new(
378             arr_date => sprintf_date( $dates[0] ),
379             arr_time => sprintf_time( $times[0] ),
380             dep_date => sprintf_date( $dates[-1] ),
381             dep_time => sprintf_time( $times[-1] ),
382             name => $e->getAttribute('name'),
383             name_suf => $e->getAttribute('nameWO'),
384             platform => $e->getAttribute('platformName'),
385             )
386             );
387             }
388              
389 0         0 return @ret;
390             }
391              
392             sub results {
393 2     2 1 705 my ($self) = @_;
394 2         5 my @results;
395              
396 2 50       10 if ( $self->{results} ) {
397 0         0 return @{ $self->{results} };
  0         0  
398             }
399              
400 2 50       13 if ( not $self->{tree} ) {
401 0         0 return;
402             }
403              
404 2         35 my $xp_element = XML::LibXML::XPathExpression->new('//itdDeparture');
405              
406 2         13 my $xp_date = XML::LibXML::XPathExpression->new('./itdDateTime/itdDate');
407 2         14 my $xp_time = XML::LibXML::XPathExpression->new('./itdDateTime/itdTime');
408 2         16 my $xp_rdate = XML::LibXML::XPathExpression->new('./itdRTDateTime/itdDate');
409 2         11 my $xp_rtime = XML::LibXML::XPathExpression->new('./itdRTDateTime/itdTime');
410 2         9 my $xp_line = XML::LibXML::XPathExpression->new('./itdServingLine');
411 2         71 my $xp_info
412             = XML::LibXML::XPathExpression->new('./itdServingLine/itdNoTrain');
413 2         12 my $xp_prev_route
414             = XML::LibXML::XPathExpression->new('./itdPrevStopSeq/itdPoint');
415 2         34 my $xp_next_route
416             = XML::LibXML::XPathExpression->new('./itdOnwardStopSeq/itdPoint');
417              
418 2         12 $self->lines;
419              
420 2         21 for my $e ( $self->{tree}->findnodes($xp_element) ) {
421              
422 40         1589 my $e_date = ( $e->findnodes($xp_date) )[0];
423 40         1356 my $e_time = ( $e->findnodes($xp_time) )[0];
424 40         858 my $e_line = ( $e->findnodes($xp_line) )[0];
425 40         787 my $e_info = ( $e->findnodes($xp_info) )[0];
426              
427 40         779 my $e_rdate = ( $e->findnodes($xp_rdate) )[0];
428 40         741 my $e_rtime = ( $e->findnodes($xp_rtime) )[0];
429              
430 40 50 33     817 if ( not( $e_date and $e_time and $e_line ) ) {
      33        
431 0         0 cluck('node with insufficient data. This should not happen');
432 0         0 next;
433             }
434              
435 40         668 my $date = sprintf_date($e_date);
436 40         996 my $time = sprintf_time($e_time);
437              
438 40 100       654 my $rdate = $e_rdate ? sprintf_date($e_rdate) : $date;
439 40 100       289 my $rtime = $e_rtime ? sprintf_time($e_rtime) : $time;
440              
441 40         221 my $platform = $e->getAttribute('platform');
442 40         337 my $platform_name = $e->getAttribute('platformName');
443 40         330 my $countdown = $e->getAttribute('countdown');
444 40         325 my $occupancy = $e->getAttribute('occupancy');
445 40         319 my $line = $e_line->getAttribute('number');
446 40         314 my $train_no = $e_line->getAttribute('trainNum');
447 40         305 my $dest = $e_line->getAttribute('direction');
448 40         388 my $info = $e_info->textContent;
449 40         81 my $key = $e_line->getAttribute('key');
450 40         315 my $delay = $e_info->getAttribute('delay');
451 40         357 my $type = $e_info->getAttribute('name');
452 40         310 my $mot = $e_line->getAttribute('motType');
453              
454 40         296 my $platform_is_db = 0;
455              
456 40         65 my @prev_route;
457             my @next_route;
458              
459 40 50       100 if ( $self->{want_full_routes} ) {
460             @prev_route
461 0         0 = $self->parse_route( @{ [ $e->findnodes($xp_prev_route) ] } );
  0         0  
462             @next_route
463 0         0 = $self->parse_route( @{ [ $e->findnodes($xp_next_route) ] } );
  0         0  
464             }
465              
466             my @line_obj
467 2160         17724 = grep { $_->{identifier} eq $e_line->getAttribute('stateless') }
468 40         52 @{ $self->{lines} };
  40         100  
469              
470             # platform / platformName are inconsistent. The following cases are
471             # known:
472             #
473             # * platform="int", platformName="" : non-DB platform
474             # * platform="int", platformName="Bstg. int" : non-DB platform
475             # * platform="#int", platformName="Gleis int" : non-DB platform
476             # * platform="#int", platformName="Gleis int" : DB platform?
477             # * platform="", platformName="Gleis int" : DB platform
478             # * platform="DB", platformName="Gleis int" : DB platform
479             # * platform="gibberish", platformName="Gleis int" : DB platform
480              
481 40 50 66     529 if ( ( $platform_name and $platform_name =~ m{ ^ Gleis }ox )
      33        
      66        
482             and not( $platform and $platform =~ s{ ^ \# }{}ox ) )
483             {
484 0         0 $platform_is_db = 1;
485             }
486              
487 40 50 33     237 if ( $platform_name and $platform_name =~ m{ ^ (Gleis | Bstg[.])}ox ) {
    0 0        
488 40         169 $platform = ( split( / /, $platform_name ) )[1];
489             }
490             elsif ( $platform_name and not $platform ) {
491 0         0 $platform = $platform_name;
492             }
493              
494             push(
495 40   100     213 @results,
496             Travel::Status::DE::EFA::Result->new(
497             date => $rdate,
498             time => $rtime,
499             platform => $platform,
500             platform_db => $platform_is_db,
501             platform_name => $platform_name,
502             key => $key,
503             lineref => $line_obj[0] // undef,
504             line => $line,
505             train_no => $train_no,
506             destination => $dest,
507             occupancy => $occupancy,
508             countdown => $countdown,
509             info => $info,
510             delay => $delay,
511             sched_date => $date,
512             sched_time => $time,
513             type => $type,
514             mot => $mot,
515             prev_route => \@prev_route,
516             next_route => \@next_route,
517             )
518             );
519             }
520              
521 40         57 @results = map { $_->[0] }
522 136         205 sort { $a->[1] <=> $b->[1] }
523 2         94 map { [ $_, $_->countdown ] } @results;
  40         653  
524              
525 2         24 $self->{results} = \@results;
526              
527 2         31 return @results;
528             }
529              
530             # static
531             sub get_efa_urls {
532              
533             # sorted lexically by shortname
534             return (
535             {
536 0     0 1   url => 'https://bsvg.efa.de/bsvagstd/XML_DM_REQUEST',
537             name => 'Braunschweiger Verkehrs-GmbH',
538             shortname => 'BSVG',
539             },
540             {
541             url => 'https://www.ding.eu/ding3/XSLT_DM_REQUEST',
542             name => 'Donau-Iller Nahverkehrsverbund',
543             shortname => 'DING',
544             },
545             {
546             url => 'https://projekte.kvv-efa.de/sl3-alone/XSLT_DM_REQUEST',
547             name => 'Karlsruher Verkehrsverbund',
548             shortname => 'KVV',
549             },
550             {
551             url => 'https://www.linzag.at/static/XSLT_DM_REQUEST',
552             name => 'Linz AG',
553             shortname => 'LinzAG',
554             encoding => 'iso-8859-15',
555             },
556             {
557             url => 'https://efa.mvv-muenchen.de/mobile/XSLT_DM_REQUEST',
558             name => 'Münchner Verkehrs- und Tarifverbund',
559             shortname => 'MVV',
560             },
561             {
562             url => 'https://www.efa-bw.de/nvbw/XSLT_DM_REQUEST',
563             name => 'Nahverkehrsgesellschaft Baden-Württemberg',
564             shortname => 'NVBW',
565             },
566             {
567             url => 'https://efa.vagfr.de/vagfr3/XSLT_DM_REQUEST',
568             name => 'Freiburger Verkehrs AG',
569             shortname => 'VAG',
570             },
571             {
572             url => 'https://efa.vgn.de/vgnExt_oeffi/XML_DM_REQUEST',
573             name => 'Verkehrsverbund Grossraum Nuernberg',
574             shortname => 'VGN',
575             },
576              
577             # HTTPS: certificate verification fails
578             {
579             url => 'http://efa.vmv-mbh.de/vmv/XML_DM_REQUEST',
580             name => 'Verkehrsgesellschaft Mecklenburg-Vorpommern',
581             shortname => 'VMV',
582             },
583             {
584             url => 'https://www.vrn.de/mngvrn//XML_DM_REQUEST',
585             name => 'Verkehrsverbund Rhein-Neckar',
586             shortname => 'VRN',
587             },
588             {
589             url => 'https://efa.vrr.de/vrr/XSLT_DM_REQUEST',
590             name => 'Verkehrsverbund Rhein-Ruhr',
591             shortname => 'VRR',
592             },
593             {
594             url => 'https://app.vrr.de/standard/XML_DM_REQUEST',
595             name => 'Verkehrsverbund Rhein-Ruhr (alternative)',
596             shortname => 'VRR2',
597             },
598             {
599             url => 'https://efa.vrr.de/rbgstd3/XML_DM_REQUEST',
600             name => 'Verkehrsverbund Rhein-Ruhr (alternative alternative)',
601             shortname => 'VRR3',
602             },
603             {
604             url => 'https://efa.vvo-online.de/VMSSL3/XSLT_DM_REQUEST',
605             name => 'Verkehrsverbund Oberelbe',
606             shortname => 'VVO',
607             },
608             {
609             url => 'https://www2.vvs.de/vvs/XSLT_DM_REQUEST',
610             name => 'Verkehrsverbund Stuttgart',
611             shortname => 'VVS',
612             },
613              
614             );
615             }
616              
617             1;
618              
619             __END__