File Coverage

blib/lib/Travel/Status/DE/IRIS.pm
Criterion Covered Total %
statement 264 469 56.2
branch 72 150 48.0
condition 30 67 44.7
subroutine 31 51 60.7
pod 8 23 34.7
total 405 760 53.2


line stmt bran cond sub pod time code
1             package Travel::Status::DE::IRIS;
2              
3 7     7   4767841 use strict;
  7         74  
  7         209  
4 7     7   48 use warnings;
  7         21  
  7         158  
5 7     7   138 use 5.014;
  7         24  
6              
7 7     7   4860 no if $] >= 5.018, warnings => 'experimental::smartmatch';
  7         105  
  7         50  
8              
9             our $VERSION = '1.89';
10              
11 7     7   810 use Carp qw(confess cluck);
  7         18  
  7         399  
12 7     7   46 use DateTime;
  7         27  
  7         179  
13 7     7   5585 use DateTime::Format::Strptime;
  7         1431636  
  7         44  
14 7     7   680 use List::Util qw(first);
  7         25  
  7         540  
15 7     7   67 use List::MoreUtils qw(uniq);
  7         14  
  7         85  
16 7     7   10476 use List::UtilsBy qw(uniq_by);
  7         14418  
  7         499  
17 7     7   5217 use LWP::UserAgent;
  7         365480  
  7         275  
18 7     7   4913 use Travel::Status::DE::IRIS::Result;
  7         28  
  7         54  
19 7     7   5434 use XML::LibXML;
  7         361834  
  7         50  
20              
21             sub try_load_xml {
22 47     47 0 146 my ($xml) = @_;
23              
24 47         92 my $tree;
25              
26 47         87 eval { $tree = XML::LibXML->load_xml( string => $xml ) };
  47         453  
27              
28 47 50       97904 if ($@) {
29 0         0 return ( undef, $@ );
30             }
31 47         200 return ( $tree, undef );
32             }
33              
34             # "station" parameter must be an EVA or DS100 ID.
35             sub new_p {
36 0     0 1 0 my ( $class, %opt ) = @_;
37 0         0 my $promise = $opt{promise}->new;
38              
39 0 0       0 if ( not $opt{station} ) {
40 0         0 return $promise->reject('station flag must be passed');
41             }
42              
43 0         0 my $self = $class->new( %opt, async => 1 );
44 0         0 $self->{promise} = $opt{promise};
45              
46 0         0 my $lookahead_steps = int( $self->{lookahead} / 60 );
47 0 0       0 if ( ( 60 - $self->{datetime}->minute ) < ( $self->{lookahead} % 60 ) ) {
48 0         0 $lookahead_steps++;
49             }
50 0         0 my $lookbehind_steps = int( $self->{lookbehind} / 60 );
51 0 0       0 if ( $self->{datetime}->minute < ( $self->{lookbehind} % 60 ) ) {
52 0         0 $lookbehind_steps++;
53             }
54              
55 0         0 my @candidates = $opt{get_station}( $opt{station} );
56              
57 0 0 0     0 if ( @candidates != 1 and $opt{station} =~ m{^\d+$} ) {
58             @candidates = (
59             [
60             "D$opt{station}", "Betriebsstelle nicht bekannt $opt{station}",
61             $opt{station}
62 0         0 ]
63             );
64             }
65              
66 0 0       0 if ( @candidates == 0 ) {
67 0         0 return $promise->reject('station not found');
68             }
69 0 0       0 if ( @candidates >= 2 ) {
70 0         0 return $promise->reject('station identifier is ambiguous');
71             }
72              
73             $self->{station} = {
74 0         0 ds100 => $candidates[0][0],
75             name => $candidates[0][1],
76             uic => $candidates[0][2],
77             };
78 0         0 $self->{related_stations} = [];
79              
80 0         0 my @queue = ( $self->{station}{uic} );
81 0         0 my @related_reqs;
82             my @related_stations;
83 0         0 my %seen = ( $self->{station}{uic} => 1 );
84 0         0 my $iter_depth = 0;
85              
86 0   0     0 while ( @queue and $iter_depth < 12 and $opt{with_related} ) {
      0        
87 0         0 my $eva = shift(@queue);
88 0         0 $iter_depth++;
89 0   0     0 for my $ref ( @{ $opt{meta}{$eva} // [] } ) {
  0         0  
90 0 0       0 if ( not $seen{$ref} ) {
91 0         0 push( @related_stations, $ref );
92 0         0 $seen{$ref} = 1;
93 0         0 push( @queue, $ref );
94             }
95             }
96             }
97              
98 0         0 for my $eva (@related_stations) {
99 0         0 @candidates = $opt{get_station}($eva);
100              
101 0 0       0 if ( @candidates == 1 ) {
102             push(
103 0         0 @{ $self->{related_stations} },
  0         0  
104             {
105             ds100 => $candidates[0][0],
106             name => $candidates[0][1],
107             uic => $candidates[0][2],
108             }
109             );
110             }
111             }
112              
113 0         0 my $dt_req = $self->{datetime}->clone;
114             my @timetable_reqs
115 0         0 = ( $self->get_timetable_p( $self->{station}{uic}, $dt_req ) );
116              
117 0         0 for my $eva (@related_stations) {
118 0         0 push( @timetable_reqs, $self->get_timetable_p( $eva, $dt_req ) );
119             }
120              
121 0         0 for ( 1 .. $lookahead_steps ) {
122 0         0 $dt_req->add( hours => 1 );
123             push( @timetable_reqs,
124 0         0 $self->get_timetable_p( $self->{station}{uic}, $dt_req ) );
125 0         0 for my $eva (@related_stations) {
126 0         0 push( @timetable_reqs, $self->get_timetable_p( $eva, $dt_req ) );
127             }
128             }
129              
130 0         0 $dt_req = $self->{datetime}->clone;
131 0         0 for ( 1 .. $lookbehind_steps ) {
132 0         0 $dt_req->subtract( hours => 1 );
133             push( @timetable_reqs,
134 0         0 $self->get_timetable_p( $self->{station}{uic}, $dt_req ) );
135 0         0 for my $eva (@related_stations) {
136 0         0 push( @timetable_reqs, $self->get_timetable_p( $eva, $dt_req ) );
137             }
138             }
139              
140             $self->{promise}->all(@timetable_reqs)->then(
141             sub {
142             my @realtime_reqs
143 0     0   0 = ( $self->get_realtime_p( $self->{station}{uic} ) );
144 0         0 for my $eva (@related_stations) {
145 0         0 push( @realtime_reqs, $self->get_realtime_p( $eva, $dt_req ) );
146             }
147 0         0 return $self->{promise}->all_settled(@realtime_reqs);
148             }
149             )->then(
150             sub {
151 0     0   0 my @realtime_results = @_;
152              
153 0         0 for my $realtime_result (@realtime_results) {
154 0 0       0 if ( $realtime_result->{status} eq 'rejected' ) {
155 0   0     0 $self->{warnstr} //= q{};
156             $self->{warnstr}
157 0         0 .= "Realtime data request failed: $realtime_result->{reason}. ";
158             }
159             }
160              
161 0         0 $self->postprocess_results;
162 0         0 $promise->resolve($self);
163 0         0 return;
164             }
165             )->catch(
166             sub {
167 0     0   0 my ($err) = @_;
168 0         0 $promise->reject($err);
169 0         0 return;
170             }
171 0         0 )->wait;
172              
173 0         0 return $promise;
174             }
175              
176             sub new {
177 13     13 1 125013 my ( $class, %opt ) = @_;
178              
179 13 100       65 if ( not $opt{station} ) {
180 1         315 confess('station flag must be passed');
181             }
182              
183             my $self = {
184             datetime => $opt{datetime}
185             // DateTime->now( time_zone => 'Europe/Berlin' ),
186             developer_mode => $opt{developer_mode},
187             iris_base => $opt{iris_base}
188             // 'https://iris.noncd.db.de/iris-tts/timetable',
189             keep_transfers => $opt{keep_transfers},
190             lookahead => $opt{lookahead} // ( 2 * 60 ),
191             lookbehind => $opt{lookbehind} // ( 0 * 60 ),
192             main_cache => $opt{main_cache},
193             rt_cache => $opt{realtime_cache},
194             serializable => $opt{serializable},
195             user_agent => $opt{user_agent},
196             with_related => $opt{with_related},
197             departure_by_id => {},
198 12   33     70 strptime_obj => $opt{strptime_obj} // DateTime::Format::Strptime->new(
      50        
      100        
      50        
      33        
199             pattern => '%y%m%d%H%M',
200             time_zone => 'Europe/Berlin',
201             ),
202             xp_ar => XML::LibXML::XPathExpression->new('./ar'),
203             xp_dp => XML::LibXML::XPathExpression->new('./dp'),
204             xp_tl => XML::LibXML::XPathExpression->new('./tl'),
205              
206             };
207              
208 12         24160 bless( $self, $class );
209              
210 12         94 my $lookahead_steps = int( $self->{lookahead} / 60 );
211 12 50       82 if ( ( 60 - $self->{datetime}->minute ) < ( $self->{lookahead} % 60 ) ) {
212 0         0 $lookahead_steps++;
213             }
214 12         163 my $lookbehind_steps = int( $self->{lookbehind} / 60 );
215 12 50       48 if ( $self->{datetime}->minute < ( $self->{lookbehind} % 60 ) ) {
216 0         0 $lookbehind_steps++;
217             }
218              
219 12 50       109 if ( $opt{async} ) {
220 0         0 return $self;
221             }
222              
223 12 50       48 if ( not $self->{user_agent} ) {
224 12   50     30 my %lwp_options = %{ $opt{lwp_options} // { timeout => 10 } };
  12         112  
225 12         142 $self->{user_agent} = LWP::UserAgent->new(%lwp_options);
226 12         24129 $self->{user_agent}->env_proxy;
227             }
228              
229             my ( $station, @related_stations ) = $self->get_station(
230             name => $opt{station},
231             root => 1,
232             recursive => $opt{with_related},
233 12         31793 );
234              
235 12         61 $self->{station} = $station;
236 12         43 $self->{related_stations} = \@related_stations;
237              
238 12         43 for my $ref (@related_stations) {
239              
240             # We (the parent) perform transfer processing, so child requests must not
241             # do it themselves. Otherwise, trains from child requests will be
242             # processed twice and may be lost.
243             # Similarly, child requests must not perform requests to related
244             # stations -- we're already doing that right now.
245             my $ref_status = Travel::Status::DE::IRIS->new(
246             datetime => $self->{datetime},
247             developer_mode => $self->{developer_mode},
248             iris_base => $self->{iris_base},
249             lookahead => $self->{lookahead},
250             lookbehind => $self->{lookbehind},
251             station => $ref->{uic},
252             main_cache => $self->{main_cache},
253             realtime_cache => $self->{rt_cache},
254             strptime_obj => $self->{strptime_obj},
255             user_agent => $self->{user_agent},
256 0         0 keep_transfers => 1,
257             with_related => 0,
258             );
259 0 0       0 if ( not $ref_status->errstr ) {
260 0         0 push( @{ $self->{results} }, $ref_status->results );
  0         0  
261             }
262             }
263              
264 12 100       46 if ( $self->{errstr} ) {
265 2         101 return $self;
266             }
267              
268 10         71 my $dt_req = $self->{datetime}->clone;
269 10         225 $self->get_timetable( $self->{station}{uic}, $dt_req );
270 10         53 for ( 1 .. $lookahead_steps ) {
271 20         141 $dt_req->add( hours => 1 );
272 20         28409 $self->get_timetable( $self->{station}{uic}, $dt_req );
273             }
274 10         101 $dt_req = $self->{datetime}->clone;
275 10         275 for ( 1 .. $lookbehind_steps ) {
276 0         0 $dt_req->subtract( hours => 1 );
277 0         0 $self->get_timetable( $self->{station}{uic}, $dt_req );
278             }
279              
280 10         72 $self->get_realtime;
281              
282 10         11927 $self->postprocess_results;
283              
284 10         336 return $self;
285             }
286              
287             sub postprocess_results {
288 10     10 0 34 my ($self) = @_;
289 10 50       55 if ( not $self->{keep_transfers} ) {
290              
291             # tra (transfer?) indicates a train changing its ID, so there are two
292             # results for the same train. Remove the departure-only trains from the
293             # result set and merge them with their arrival-only counterpart.
294             # This way, in case the arrival is available but the departure isn't,
295             # nothing gets lost.
296             my @merge_candidates
297 10 100       31 = grep { $_->transfer and $_->departure } @{ $self->{results} };
  1125         11841  
  10         42  
298 10         211 @{ $self->{results} }
299 1125   100     10762 = grep { not( $_->transfer and $_->departure ) }
300 10         155 @{ $self->{results} };
  10         39  
301              
302 10         53 for my $transfer (@merge_candidates) {
303             my $result
304 742 100   742   7562 = first { $_->transfer and $_->transfer eq $transfer->train_id }
305 12         39 @{ $self->{results} };
  12         42  
306 12 100       285 if ($result) {
307 10         28 $result->merge_with_departure($transfer);
308             }
309             }
310             }
311              
312 10         599 @{ $self->{results} } = grep {
313 1113   66     52278 my $d = $_->departure // $_->arrival;
314 1113   66     19904 my $s = $_->sched_arrival // $_->sched_departure // $_->arrival // $d;
      33        
      33        
315 1113         16879 $d = $d->subtract_datetime( $self->{datetime} );
316 1113         494488 $s = $s->subtract_datetime( $self->{datetime} );
317             not $d->is_negative and $s->in_units('minutes') < $self->{lookahead}
318 10 100       30 } @{ $self->{results} };
  1113         489904  
  10         42  
319              
320 10         90 @{ $self->{results} }
321 10         46 = sort { $a->{epoch} <=> $b->{epoch} } @{ $self->{results} };
  3527         5261  
  10         126  
322              
323             # wings (different departures which are coupled as one train) contain
324             # references to each other. therefore, they must be processed last.
325 10         69 $self->create_wing_refs;
326              
327             # same goes for replacement refs (the <ref> tag in the fchg document)
328 10         124 $self->create_replacement_refs;
329             }
330              
331             sub get_with_cache_p {
332 0     0 0 0 my ( $self, $cache, $url ) = @_;
333              
334 0 0       0 if ( $self->{developer_mode} ) {
335 0         0 say "GET $url";
336             }
337              
338 0         0 my $promise = $self->{promise}->new;
339              
340 0 0       0 if ($cache) {
341 0         0 my $content = $cache->thaw($url);
342 0 0       0 if ($content) {
343 0 0       0 if ( $self->{developer_mode} ) {
344 0         0 say ' cache hit';
345             }
346 0         0 return $promise->resolve($content);
347             }
348             }
349              
350 0 0       0 if ( $self->{developer_mode} ) {
351 0         0 say ' cache miss';
352             }
353              
354             my $res = $self->{user_agent}->get_p($url)->then(
355             sub {
356 0     0   0 my ($tx) = @_;
357 0 0       0 if ( my $err = $tx->error ) {
358 0         0 $promise->reject(
359             "GET $url returned HTTP $err->{code} $err->{message}");
360 0         0 return;
361             }
362 0         0 my $content = $tx->res->body;
363 0 0       0 if ($cache) {
364 0         0 $cache->freeze( $url, \$content );
365             }
366 0         0 $promise->resolve($content);
367 0         0 return;
368             }
369             )->catch(
370             sub {
371 0     0   0 my ($err) = @_;
372 0         0 $promise->reject($err);
373 0         0 return;
374             }
375 0         0 )->wait;
376              
377 0         0 return $promise;
378             }
379              
380             sub get_with_cache {
381 52     52 0 2864 my ( $self, $cache, $url ) = @_;
382              
383 52 50       192 if ( $self->{developer_mode} ) {
384 0         0 say "GET $url";
385             }
386              
387 52 50       146 if ($cache) {
388 0         0 my $content = $cache->thaw($url);
389 0 0       0 if ($content) {
390 0 0       0 if ( $self->{developer_mode} ) {
391 0         0 say ' cache hit';
392             }
393 0         0 return ( ${$content}, undef );
  0         0  
394             }
395             }
396              
397 52 50       166 if ( $self->{developer_mode} ) {
398 0         0 say ' cache miss';
399             }
400              
401 52         128 my $ua = $self->{user_agent};
402 52         293 my $res = $ua->get($url);
403              
404 52 100       368076 if ( $res->is_error ) {
405 5         56 return ( undef, $res->status_line );
406             }
407 47         692 my $content = $res->decoded_content;
408              
409 47 50       52769 if ($cache) {
410 0         0 $cache->freeze( $url, \$content );
411             }
412              
413 47         607 return ( $content, undef );
414             }
415              
416             sub get_station_p {
417 0     0 0 0 my ( $self, %opt ) = @_;
418              
419 0         0 my $promise = $self->{promise}->new;
420 0         0 my $station = $opt{name};
421              
422             $self->get_with_cache_p( $self->{main_cache},
423             $self->{iris_base} . '/station/' . $station )->then(
424             sub {
425 0     0   0 my ($raw) = @_;
426 0         0 my ( $xml_st, $xml_err ) = try_load_xml($raw);
427 0 0       0 if ($xml_err) {
428 0         0 $promise->reject('Failed to parse station data: Invalid XML');
429 0         0 return;
430             }
431 0         0 my $station_node = ( $xml_st->findnodes('//station') )[0];
432              
433 0 0       0 if ( not $station_node ) {
434 0         0 $promise->reject(
435             "Station '$station' has no associated timetable");
436 0         0 return;
437             }
438             $promise->resolve(
439             {
440 0         0 uic => $station_node->getAttribute('eva'),
441             name => $station_node->getAttribute('name'),
442             ds100 => $station_node->getAttribute('ds100'),
443             }
444             );
445 0         0 return;
446             }
447             )->catch(
448             sub {
449 0     0   0 my ($err) = @_;
450 0         0 $promise->reject($err);
451 0         0 return;
452             }
453 0         0 )->wait;
454              
455 0         0 return $promise;
456             }
457              
458             sub get_station {
459 12     12 1 93 my ( $self, %opt ) = @_;
460              
461 12         33 my $iter_depth = 0;
462 12         29 my @ret;
463 12         44 my @queue = ( $opt{name} );
464              
465             # @seen holds station IDs which were already seen during recursive
466             # 'meta' descent. This avoids infinite loops of 'meta' references.
467             # Additionally, we use it to skip stations shat should not be referenced.
468             # This includes Norddeich / Norddeich Mole (different stations commonly used
469             # by identical trains with different departure times), and Essen-Dellwig /
470             # Essen-Dellwig Ost (different stations used by different trains, but with
471             # identical platform numbers).
472 12         39 my @seen = ( 8007768, 8004449, 8001903, 8001904 );
473              
474 12   66     88 while ( @queue and $iter_depth < 12 ) {
475 12         43 my $station = shift(@queue);
476 12         38 push( @seen, $station );
477 12         29 $iter_depth++;
478              
479             my ( $raw, $err )
480             = $self->get_with_cache( $self->{main_cache},
481 12         87 $self->{iris_base} . '/station/' . $station );
482 12 100       87 if ($err) {
483 1 50       8 if ( $opt{root} ) {
484 1         6 $self->{errstr} = "Failed to fetch station data: $err";
485 1         51 return;
486             }
487             else {
488             $self->{warnstr}
489 0         0 = "Failed to fetch station data for '$station': $err\n";
490 0         0 next;
491             }
492             }
493              
494 11         67 my ( $xml_st, $xml_err ) = try_load_xml($raw);
495 11 50       51 if ($xml_err) {
496 0         0 $self->{errstr} = 'Failed to parse station data: Invalid XML';
497 0         0 return;
498             }
499              
500 11         115 my $station_node = ( $xml_st->findnodes('//station') )[0];
501              
502 11 100       1161 if ( not $station_node ) {
503 1 50       6 if ( $self->{developer_mode} ) {
504 0         0 say ' no timetable';
505             }
506 1 50       5 if ( $opt{root} ) {
507             $self->{errstr}
508 1         6 = "Station '$station' has no associated timetable";
509 1         9 return;
510             }
511             else {
512             $self->{warnstr}
513 0         0 = "Station '$station' has no associated timetable";
514 0         0 next;
515             }
516 0         0 next;
517             }
518              
519 10         119 push( @seen, $station_node->getAttribute('eva') );
520              
521 10 50       191 if ( $station_node->getAttribute('name') =~ m{ ZOB} ) {
522              
523             # There are no departures from a ZOB ("Zentraler Omnibus-Bahnhof" /
524             # Central Omnibus Station). Ignore it entirely.
525 0         0 next;
526             }
527              
528 10 50       218 if ( $station_node->getAttribute('ds100') =~ m{ ^ D \d+ $ }x ) {
529              
530             # This used to indicate an invalid DS100 code, at least from DB
531             # perspective. It typically referred to subway stations which do not
532             # have IRIS departures.
533             # However, since Fahrplanwechsel 2022 / 2023, this does not seem
534             # to be the case anymore. There are some stations whose DS100 code
535             # IRIS does not know, for whatever reason. So for now, accept these
536             # stations as well.
537              
538             #next;
539             }
540              
541             push(
542 10         184 @ret,
543             {
544             uic => $station_node->getAttribute('eva'),
545             name => $station_node->getAttribute('name'),
546             ds100 => $station_node->getAttribute('ds100'),
547             }
548             );
549              
550 10 50       304 if ( $self->{developer_mode} ) {
551 0         0 printf( " -> %s (%s / %s)\n", @{ $ret[-1] }{qw{name uic ds100}} );
  0         0  
552             }
553              
554 10 50 33     87 if ( $opt{recursive} and defined $station_node->getAttribute('meta') ) {
555             my @refs
556 0         0 = uniq( split( m{ \| }x, $station_node->getAttribute('meta') ) );
557 0   0     0 @refs = grep { not( $_ ~~ \@seen or $_ ~~ \@queue ) } @refs;
  0         0  
558 0         0 push( @queue, @refs );
559 0         0 $opt{root} = 0;
560             }
561             }
562              
563 10 50       328 if (@queue) {
564 0         0 cluck( "Reached $iter_depth iterations when tracking station IDs. "
565             . "This is probably a bug" );
566             }
567              
568 10     10   103 @ret = uniq_by { $_->{uic} } @ret;
  10         109  
569              
570 10         161 return @ret;
571             }
572              
573             sub add_result {
574 1140     1140 0 2857 my ( $self, $station_name, $station_uic, $s ) = @_;
575              
576 1140         2730 my $id = $s->getAttribute('id');
577 1140         15645 my $e_tl = ( $s->findnodes( $self->{xp_tl} ) )[0];
578 1140         58178 my $e_ar = ( $s->findnodes( $self->{xp_ar} ) )[0];
579 1140         26748 my $e_dp = ( $s->findnodes( $self->{xp_dp} ) )[0];
580              
581 1140 50       24894 if ( not $e_tl ) {
582 0         0 return;
583             }
584              
585             my %data = (
586             raw_id => $id,
587             classes => $e_tl->getAttribute('f'), # D N S F
588             operator => $e_tl->getAttribute('o'), # coded operator: 03/80/R2/...
589             train_no => $e_tl->getAttribute('n'), # dep number
590             type => $e_tl->getAttribute('c'), # S/ICE/ERB/...
591             station => $station_name,
592             station_uic => $station_uic + 0, # UIC IDs are numbers
593             strptime_obj => $self->{strptime_obj},
594              
595             #unknown_t => $e_tl->getAttribute('t'), # p
596 1140         7216 );
597              
598 1140 100       39421 if ($e_ar) {
599 985         5554 $data{arrival_ts} = $e_ar->getAttribute('pt');
600 985         10037 $data{line_no} = $e_ar->getAttribute('l');
601 985         8527 $data{platform} = $e_ar->getAttribute('pp'); # string, not number!
602 985         8368 $data{route_pre} = $e_ar->getAttribute('ppth');
603 985         9282 $data{route_start} = $e_ar->getAttribute('pde');
604 985         8163 $data{transfer} = $e_ar->getAttribute('tra');
605 985         7876 $data{arrival_hidden} = $e_ar->getAttribute('hi');
606 985         7690 $data{arrival_wing_ids} = $e_ar->getAttribute('wings');
607             }
608              
609 1140 100       9381 if ($e_dp) {
610 939         5033 $data{departure_ts} = $e_dp->getAttribute('pt');
611 939         8657 $data{line_no} = $e_dp->getAttribute('l');
612 939         7441 $data{platform} = $e_dp->getAttribute('pp'); # string, not number!
613 939         7659 $data{route_post} = $e_dp->getAttribute('ppth');
614 939         8530 $data{route_end} = $e_dp->getAttribute('pde');
615 939         7845 $data{transfer} = $e_dp->getAttribute('tra');
616 939         7105 $data{departure_hidden} = $e_dp->getAttribute('hi');
617 939         7150 $data{departure_wing_ids} = $e_dp->getAttribute('wings');
618             }
619              
620 1140 100       8439 if ( $data{arrival_wing_ids} ) {
621 20         159 $data{arrival_wing_ids} = [ split( /\|/, $data{arrival_wing_ids} ) ];
622             }
623 1140 100       2239 if ( $data{departure_wing_ids} ) {
624             $data{departure_wing_ids}
625 13         53 = [ split( /\|/, $data{departure_wing_ids} ) ];
626             }
627              
628 1140         7089 my $result = Travel::Status::DE::IRIS::Result->new(%data);
629              
630             # if scheduled departure and current departure are not within the
631             # same hour, trains are reported twice. Don't add duplicates in
632             # that case.
633 1140 100       5441 if ( not $self->{departure_by_id}{$id} ) {
634 1125         1660 push( @{ $self->{results} }, $result, );
  1125         2650  
635 1125         4371 $self->{departure_by_id}{$id} = $result;
636             }
637              
638 1140         7740 return $result;
639             }
640              
641             sub get_timetable_p {
642 0     0 0 0 my ( $self, $eva, $dt ) = @_;
643              
644 0         0 my $promise = $self->{promise}->new;
645              
646             $self->get_with_cache_p( $self->{main_cache},
647             $dt->strftime( $self->{iris_base} . "/plan/${eva}/%y%m%d/%H" ) )->then(
648             sub {
649 0     0   0 my ($raw) = @_;
650 0         0 my ( $xml, $xml_err ) = try_load_xml($raw);
651 0 0       0 if ($xml_err) {
652 0         0 $promise->reject(
653             'Failed to parse a schedule part: Invalid XML');
654 0         0 return;
655             }
656 0         0 my $station
657             = ( $xml->findnodes('/timetable') )[0]->getAttribute('station');
658              
659 0         0 for my $s ( $xml->findnodes('/timetable/s') ) {
660              
661 0         0 $self->add_result( $station, $eva, $s );
662             }
663 0         0 $promise->resolve;
664 0         0 return;
665             }
666             )->catch(
667             sub {
668 0     0   0 my ($err) = @_;
669 0         0 $promise->reject($err);
670 0         0 return;
671             }
672 0         0 )->wait;
673 0         0 return $promise;
674             }
675              
676             sub get_timetable {
677 30     30 0 105 my ( $self, $eva, $dt ) = @_;
678              
679             my ( $raw, $err )
680             = $self->get_with_cache( $self->{main_cache},
681 30         239 $dt->strftime( $self->{iris_base} . "/plan/${eva}/%y%m%d/%H" ) );
682              
683 30 100       205 if ($err) {
684 4         17 $self->{warnstr} = "Failed to fetch a schedule part: $err";
685 4         12 return $self;
686             }
687              
688 26         116 my ( $xml, $xml_err ) = try_load_xml($raw);
689              
690 26 50       120 if ($xml_err) {
691 0         0 $self->{warnstr} = 'Failed to parse a schedule part: Invalid XML';
692 0         0 return $self;
693             }
694              
695 26         122 my $station = ( $xml->findnodes('/timetable') )[0]->getAttribute('station');
696              
697 26         1437 for my $s ( $xml->findnodes('/timetable/s') ) {
698              
699 1019         29647 $self->add_result( $station, $eva, $s );
700             }
701              
702 26 50 33     766 if ( $self->{developer_mode}
703             and not scalar $xml->findnodes('/timetable/s') )
704             {
705 0         0 say ' no scheduled trains';
706             }
707              
708 26         9436 return $self;
709             }
710              
711             sub get_realtime_p {
712 0     0 0 0 my ( $self, $eva ) = @_;
713              
714 0         0 my $promise = $self->{promise}->new;
715              
716             $self->get_with_cache_p( $self->{rt_cache},
717             $self->{iris_base} . "/fchg/${eva}" )->then(
718             sub {
719 0     0   0 my ($raw) = @_;
720 0         0 my ( $xml, $xml_err ) = try_load_xml($raw);
721 0 0       0 if ($xml_err) {
722 0         0 $promise->reject(
723             'Failed to parse a schedule part: Invalid XML');
724 0         0 return;
725             }
726 0         0 $self->parse_realtime( $eva, $xml );
727 0         0 $promise->resolve;
728 0         0 return;
729             }
730             )->catch(
731             sub {
732 0     0   0 my ($err) = @_;
733 0         0 $promise->reject("Failed to fetch realtime data: $err");
734 0         0 return;
735             }
736 0         0 )->wait;
737 0         0 return $promise;
738             }
739              
740             sub get_realtime {
741 10     10 0 35 my ($self) = @_;
742              
743 10         40 my $eva = $self->{station}{uic};
744              
745             my ( $raw, $err )
746             = $self->get_with_cache( $self->{rt_cache},
747 10         83 $self->{iris_base} . "/fchg/${eva}" );
748              
749 10 50       58 if ($err) {
750 0         0 $self->{warnstr} = "Failed to fetch realtime data: $err";
751 0         0 return $self;
752             }
753              
754 10         55 my ( $xml, $xml_err ) = try_load_xml($raw);
755              
756 10 50       55 if ($xml_err) {
757 0         0 $self->{warnstr} = 'Failed to parse realtime data: Invalid XML';
758 0         0 return $self;
759             }
760              
761 10         65 $self->parse_realtime( $eva, $xml );
762             }
763              
764             sub parse_realtime {
765 10     10 0 38 my ( $self, $eva, $xml ) = @_;
766 10         51 my $station = ( $xml->findnodes('/timetable') )[0]->getAttribute('station');
767              
768 10         642 for my $s ( $xml->findnodes('/timetable/s') ) {
769 2547         102413 my $id = $s->getAttribute('id');
770 2547         34038 my $e_ar = ( $s->findnodes( $self->{xp_ar} ) )[0];
771 2547         77844 my $e_dp = ( $s->findnodes( $self->{xp_dp} ) )[0];
772 2547         51780 my @e_refs = $s->findnodes('./ref/tl');
773 2547         62339 my @e_ms = $s->findnodes('.//m');
774              
775 2547         56309 my %messages;
776              
777 2547         7715 my $result = $self->{departure_by_id}{$id};
778              
779             # add_result will return nothing if no ./tl node is present. The ./tl
780             # check here is for optimization purposes.
781 2547 100 100     8592 if ( not $result and ( $s->findnodes( $self->{xp_tl} ) )[0] ) {
782 121         3549 $result = $self->add_result( $station, $eva, $s );
783 121 50       3667 if ($result) {
784 121         406 $result->set_unscheduled(1);
785             }
786             }
787 2547 100       37401 if ( not $result ) {
788 1720         5466 next;
789             }
790              
791 827 50       2871 if ( not $self->{serializable} ) {
792 827         2537 $result->set_realtime($s);
793             }
794              
795 827         1727 for my $e_m (@e_ms) {
796 3945         8152 my $type = $e_m->getAttribute('t');
797 3945         35724 my $value = $e_m->getAttribute('c');
798 3945         31339 my $msgid = $e_m->getAttribute('id');
799 3945         30825 my $ts = $e_m->getAttribute('ts');
800              
801             # 0 and 1 (with key "f") are related to canceled trains and
802             # do not appear to hold information (or at least none we can access).
803             # All observed cases of message ID 900 were related to bus
804             # connections ("Anschlussbus wartet"). We can't access which bus
805             # it refers to, so we don't show that either.
806             # ID 1000 is a generic free text message, which (as we lack access
807             # to the text itself) is not helpful either.
808 3945 100 100     40044 if ( defined $value and $value > 1 and $value < 100 ) {
      66        
809 3069         13413 $messages{$msgid} = [ $ts, $type, $value ];
810             }
811             }
812              
813 827         3564 $result->set_messages(%messages);
814              
815             # note: A departure may also have a ./tl attribute. However, we do
816             # not need to process it because it only matters for departures which
817             # are not planned (or not in the plans we requested). However, in
818             # those cases we already called add_result earlier, which reads ./tl
819             # by itself.
820 827         1715 for my $e_ref (@e_refs) {
821 1         4 $result->add_raw_ref(
822             class => $e_ref->getAttribute('f'), # D N S F
823             train_no => $e_ref->getAttribute('n'), # dep number
824             type => $e_ref->getAttribute('c'), # S/ICE/ERB/...
825             line_no => $e_ref->getAttribute('l'), # 1 -> S1, ...
826              
827             #unknown_t => $e_ref->getAttribute('t'), # p
828             #unknown_o => $e_ref->getAttribute('o'), # owner: 03/80/R2/...
829             # TODO ps='a' -> rerouted and normally unscheduled train?
830             );
831             }
832 827 100       2296 if ($e_ar) {
833 760         4317 $result->set_ar(
834             arrival_ts => $e_ar->getAttribute('ct'),
835             plan_arrival_ts => $e_ar->getAttribute('pt'),
836             platform => $e_ar->getAttribute('cp'),
837             route_pre => $e_ar->getAttribute('cpth'),
838             sched_route_pre => $e_ar->getAttribute('ppth'),
839             status => $e_ar->getAttribute('cs'),
840             status_since => $e_ar->getAttribute('clt'),
841             arrival_hidden => $e_ar->getAttribute('hi'),
842              
843             # TODO ps='a' -> rerouted and normally unscheduled train?
844             );
845             }
846 827 100       3396 if ($e_dp) {
847 686         4269 $result->set_dp(
848             departure_ts => $e_dp->getAttribute('ct'),
849             plan_departure_ts => $e_dp->getAttribute('pt'),
850             platform => $e_dp->getAttribute('cp'),
851             route_post => $e_dp->getAttribute('cpth'),
852             sched_route_post => $e_dp->getAttribute('ppth'),
853             status => $e_dp->getAttribute('cs'),
854             departure_hidden => $e_dp->getAttribute('hi'),
855             );
856             }
857              
858             }
859              
860 10         230 return $self;
861             }
862              
863             sub get_result_by_id {
864 22     22 0 60 my ( $self, $id ) = @_;
865              
866 22     1090   138 my $res = first { $_->wing_id eq $id } @{ $self->{results} };
  1090         9926  
  22         136  
867 22         361 return $res;
868             }
869              
870             sub get_result_by_train {
871 0     0 0 0 my ( $self, $type, $train_no ) = @_;
872              
873 0 0   0   0 my $res = first { $_->type eq $type and $_->train_no eq $train_no }
874 0         0 @{ $self->{results} };
  0         0  
875 0         0 return $res;
876             }
877              
878             sub create_wing_refs {
879 10     10 0 49 my ($self) = @_;
880              
881 10         53 for my $r ( $self->results ) {
882 743 100       1781 if ( $r->{departure_wing_ids} ) {
883 7         23 for my $wing_id ( @{ $r->{departure_wing_ids} } ) {
  7         39  
884 8         39 my $wingref = $self->get_result_by_id($wing_id);
885 8 50       36 if ($wingref) {
886 8         36 $r->add_departure_wingref($wingref);
887             }
888             }
889             }
890 743 100       1851 if ( $r->{arrival_wing_ids} ) {
891 13         45 for my $wing_id ( @{ $r->{arrival_wing_ids} } ) {
  13         49  
892 14         54 my $wingref = $self->get_result_by_id($wing_id);
893 14 50       54 if ($wingref) {
894 14         73 $r->add_arrival_wingref($wingref);
895             }
896             }
897             }
898             }
899              
900             }
901              
902             sub create_replacement_refs {
903 10     10 0 38 my ($self) = @_;
904              
905 10         39 for my $r ( $self->results ) {
906 743   50     1017 for my $ref_hash ( @{ $r->{refs} // [] } ) {
  743         2361  
907             my $ref = $self->get_result_by_train( $ref_hash->{type},
908 0         0 $ref_hash->{train_no} );
909 0 0       0 if ($ref) {
910 0         0 $r->add_reference($ref);
911             }
912             }
913             }
914             }
915              
916             sub station {
917 0     0 1 0 my ($self) = @_;
918              
919 0         0 return $self->{station};
920             }
921              
922             sub related_stations {
923 0     0 1 0 my ($self) = @_;
924              
925 0         0 return @{ $self->{related_stations} };
  0         0  
926             }
927              
928             sub errstr {
929 3     3 1 2897 my ($self) = @_;
930              
931 3         35 return $self->{errstr};
932             }
933              
934             sub results {
935 28     28 1 3553 my ($self) = @_;
936              
937 28   50     44 return @{ $self->{results} // [] };
  28         225  
938             }
939              
940             sub warnstr {
941 1     1 1 4173 my ($self) = @_;
942              
943 1         13 return $self->{warnstr};
944             }
945              
946             1;
947              
948             __END__
949              
950             =head1 NAME
951              
952             Travel::Status::DE::IRIS - Interface to IRIS based web departure monitors.
953              
954             =head1 SYNOPSIS
955              
956             Blocking variant:
957              
958             use Travel::Status::DE::IRIS;
959            
960             my $status = Travel::Status::DE::IRIS->new(station => "Essen Hbf");
961             for my $r ($status->results) {
962             printf(
963             "%s %s +%-3d %10s -> %s\n",
964             $r->date, $r->time, $r->delay || 0, $r->line, $r->destination
965             );
966             }
967              
968             Non-blocking variant (EXPERIMENTAL):
969              
970             use Mojo::Promise;
971             use Mojo::UserAgent;
972             use Travel::Status::DE::IRIS;
973             use Travel::Status::DE::IRIS::Stations;
974            
975             Travel::Status::DE::IRIS->new_p(station => "Essen Hbf",
976             promise => 'Mojo::Promise', user_agent => Mojo::UserAgent->new,
977             get_station => \&Travel::Status::DE::IRIS::Stations::get_station,
978             meta => Travel::Status::DE::IRIS::Stations::get_meta())->then(sub {
979             my ($status) = @_;
980             for my $r ($status->results) {
981             printf(
982             "%s %s +%-3d %10s -> %s\n",
983             $r->date, $r->time, $r->delay || 0, $r->line, $r->destination
984             );
985             }
986             })->wait;
987              
988             =head1 VERSION
989              
990             version 1.89
991              
992             =head1 DESCRIPTION
993              
994             Travel::Status::DE::IRIS is an unofficial interface to IRIS based web
995             departure monitors such as
996             L<https://iris.noncd.db.de/wbt/js/index.html?typ=ab&style=qrab&bhf=EE&SecLang=&Zeilen=20&footer=0&disrupt=0>.
997              
998             =head1 METHODS
999              
1000             =over
1001              
1002             =item my $status = Travel::Status::DE::IRIS->new(I<%opt>)
1003              
1004             Requests schedule and realtime data for a specific station at a specific
1005             point in time. Returns a new Travel::Status::DE::IRIS object.
1006              
1007             Arguments:
1008              
1009             =over
1010              
1011             =item B<datetime> => I<datetime-obj>
1012              
1013             A DateTime(3pm) object specifying the point in time. Optional, defaults to the
1014             current date and time.
1015              
1016             =item B<iris_base> => I<url>
1017              
1018             IRIS base url, defaults to C<< http://iris.noncd.db.de/iris-tts/timetable >>.
1019              
1020             =item B<keep_transfers> => I<bool>
1021              
1022             A train may change its ID and number at a station, indicating that although the
1023             previous logical train ends here, the physical train will continue its journey
1024             under a new number to a new destination. A notable example is the Berlin
1025             Ringbahn, which travels round and round from Berlin SE<uuml>dkreuz to Berlin
1026             SE<uuml>dkreuz. Each train number corresponds to a single revolution, but the
1027             actual trains just keep going.
1028              
1029             The IRIS backend returns two results for each transfer train: An arrival-only
1030             result using the old ID (linked to the new one) and a departure-only result
1031             using the new ID (linked to the old one). By default, this library merges these
1032             into a single result with both arrival and departure time. Train number, ID,
1033             and route are taken from the departure only. The original train ID and number
1034             are available using the B<old_train_id> and B<old_train_no> accessors.
1035              
1036             In case this is not desirable (e.g. because you intend to track a single
1037             train to its destination station and do not want to implement special cases
1038             for transfer trains), set B<keep_transfers> to a true value. In this case,
1039             backend data will be reported as-is and transfer trains will not be merged.
1040              
1041             =item B<lookahead> => I<int>
1042              
1043             Compute only results which are scheduled less than I<int> minutes in the
1044             future.
1045             Default: 120 (2 hours).
1046              
1047             Note that the DeutscheBahn IRIS backend only provides schedules up to four to
1048             five hours into the future. So in most cases, setting this to a value above 240
1049             minutes will have little effect. However, as the IRIS occasionally contains
1050             unscheduled departures or qos messages known far in advance (e.g. 12 hours from
1051             now), any non-negative integer is accepted.
1052              
1053             =item B<lookbehind> => I<int>
1054              
1055             Also check trains whose scheduled departure lies up to I<int> minutes in the
1056             past. Default: 0.
1057              
1058             This is useful when requesting departures shortly after a full hour. If,
1059             for example, a train was scheduled to depart on 11:59 and has 5 minutes delay,
1060             it will not be shown when requesting departures on or after 12:00 unless
1061             B<lookbehind> is set to a value greater than zero.
1062              
1063             Note that trains with significant delay (e.g. +30) may still be shown in this
1064             case regardless of the setting of B<lookbehind>, since these receive special
1065             treatment by the IRIS backend.
1066              
1067             =item B<lwp_options> => I<\%hashref>
1068              
1069             Passed on to C<< LWP::UserAgent->new >>. Defaults to C<< { timeout => 10 } >>,
1070             you can use an empty hashref to unset the default.
1071              
1072             =item B<main_cache> => I<$ojj>
1073              
1074             A Cache::File(3pm) object used to cache station and timetable requests. Optional.
1075              
1076             =item B<realtime_cache> => I<$ojj>
1077              
1078             A Cache::File(3pm) object used to cache realtime data requests. Optional.
1079              
1080             =item B<station> => I<stationcode>
1081              
1082             Mandatory: Which station to return departures for. Note that this is not a
1083             station name, but a station code, such as "EE" (for Essen Hbf) or "KA"
1084             (for Aachen Hbf). See Travel::Status::DE::IRIS::Stations(3pm) for a
1085             name to code mapping.
1086              
1087             =item B<with_related> => I<bool>
1088              
1089             Sometimes, Deutsche Bahn splits up major stations in the IRIS interface. For
1090             instance, "KE<ouml>ln Messe/Deutz" actually consists of "KE<ouml>ln
1091             Messe/Deutz" (KKDZ), "KE<ouml>ln Messe/Deutz Gl. 9-10" (KKDZB) and "KE<ouml>ln
1092             Messe/Deutz (tief)" (KKDT).
1093              
1094             By default, Travel::Status::DE::IRIS only returns departures for the specified
1095             station. When this option is set to a true value, it will also return
1096             departures for all related stations.
1097              
1098             =back
1099              
1100             =item my $promise = Travel::Status::DE::IRIS->new_p(I<%opt>) (B<EXPERIMENTAL>)
1101              
1102             Return a promise yielding a Travel::Status::DE::IRIS instance (C<< $status >>)
1103             on success, or an error message (same as C<< $status->errstr >>) on failure.
1104             This function is experimental and may be changed or remove without warning.
1105              
1106             In addition to the arguments of B<new>, the following mandatory arguments must
1107             be set:
1108              
1109             =over
1110              
1111             =item B<promise> => I<promises module>
1112              
1113             Promises implementation to use for internal promises as well as B<new_p> return
1114             value. Recommended: Mojo::Promise(3pm).
1115              
1116             =item B<get_station> => I<get_station ref>
1117              
1118             Reference to Travel::Status::DE::IRIS::Stations::get_station().
1119              
1120             =item B<meta> => I<meta dict>
1121              
1122             The dictionary returned by Travel::Status::DE::IRIS::Stations::get_meta().
1123              
1124             =item B<user_agent> => I<user agent>
1125              
1126             User agent instance to use for asynchronous requests. The object must support
1127             promises (i.e., it must implement a C<< get_p >> function). Recommended:
1128             Mojo::UserAgent(3pm).
1129              
1130             =back
1131              
1132             =item $status->errstr
1133              
1134             In case of a fatal HTTP request or IRIS error, returns a string describing it.
1135             Returns undef otherwise.
1136              
1137             =item $status->related_stations
1138              
1139             Returns a list of hashes describing related stations whose
1140             arrivals/departures are included in B<results>. Only useful when setting
1141             B<with_related> to a true value, see its documentation above for details.
1142              
1143             Each hash contains the keys B<uic> (EVA number; often same as UIC station ID),
1144             B<name> (station name), and B<ds100> (station code). Note that stations
1145             returned by B<related_stations> are not necessarily known to
1146             Travel::Status::DE::IRIS::Stations(3pm).
1147              
1148             =item $status->results
1149              
1150             Returns a list of Travel::Status::DE::IRIS::Result(3pm) objects, each one describing
1151             one arrival and/or departure.
1152              
1153             =item $status->warnstr
1154              
1155             In case of a (probably) non-fatal HTTP request or IRIS error, returns a string
1156             describing it. Returns undef otherwise.
1157              
1158             =back
1159              
1160             =head1 DIAGNOSTICS
1161              
1162             None.
1163              
1164             =head1 DEPENDENCIES
1165              
1166             =over
1167              
1168             =item * DateTime(3pm)
1169              
1170             =item * List::Util(3pm)
1171              
1172             =item * LWP::UserAgent(3pm)
1173              
1174             =item * XML::LibXML(3pm)
1175              
1176             =back
1177              
1178             =head1 BUGS AND LIMITATIONS
1179              
1180             Some backend features are not yet exposed.
1181              
1182             =head1 SEE ALSO
1183              
1184             db-iris(1), Travel::Status::DE::IRIS::Result(3pm),
1185             Travel::Status::DE::IRIS::Stations(3pm)
1186              
1187             =head1 REPOSITORY
1188              
1189             L<https://github.com/derf/Travel-Status-DE-IRIS>
1190              
1191             =head1 AUTHOR
1192              
1193             Copyright (C) 2013-2023 by Birte Kristina Friesel E<lt>derf@finalrewind.orgE<gt>
1194              
1195             =head1 LICENSE
1196              
1197             This module is licensed under the same terms as Perl itself.