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. |