File Coverage

blib/lib/Travel/Status/DE/HAFAS.pm
Criterion Covered Total %
statement 140 344 40.7
branch 25 120 20.8
condition 17 101 16.8
subroutine 26 42 61.9
pod 13 21 61.9
total 221 628 35.1


line stmt bran cond sub pod time code
1             package Travel::Status::DE::HAFAS;
2              
3             # vim:foldmethod=marker
4              
5 1     1   144417 use strict;
  1         4  
  1         30  
6 1     1   7 use warnings;
  1         2  
  1         23  
7 1     1   28 use 5.014;
  1         4  
8 1     1   7 use utf8;
  1         2  
  1         17  
9              
10 1     1   730 no if $] >= 5.018, warnings => 'experimental::smartmatch';
  1         18  
  1         7  
11              
12 1     1   92 use Carp qw(confess);
  1         2  
  1         46  
13 1     1   985 use DateTime;
  1         548599  
  1         57  
14 1     1   606 use DateTime::Format::Strptime;
  1         200421  
  1         7  
15 1     1   76 use Digest::MD5 qw(md5_hex);
  1         3  
  1         60  
16 1     1   731 use Encode qw(decode encode);
  1         11057  
  1         84  
17 1     1   10 use JSON;
  1         2  
  1         14  
18 1     1   1317 use LWP::UserAgent;
  1         51181  
  1         44  
19 1     1   502 use Travel::Status::DE::HAFAS::Message;
  1         4  
  1         13  
20 1     1   486 use Travel::Status::DE::HAFAS::Polyline qw(decode_polyline);
  1         3  
  1         62  
21 1     1   498 use Travel::Status::DE::HAFAS::Journey;
  1         12  
  1         6  
22 1     1   532 use Travel::Status::DE::HAFAS::StopFinder;
  1         3  
  1         35  
23 1     1   7 use Travel::Status::DE::HAFAS::Stop;
  1         10  
  1         7  
24              
25             our $VERSION = '4.16';
26              
27             # {{{ Endpoint Definition
28              
29             my %hafas_instance = (
30             DB => {
31             stopfinder => 'https://reiseauskunft.bahn.de/bin/ajax-getstop.exe',
32             mgate => 'https://reiseauskunft.bahn.de/bin/mgate.exe',
33             name => 'Deutsche Bahn',
34             productbits => [qw[ice ic_ec d regio s bus ferry u tram ondemand]],
35             salt => 'bdI8UVj4' . '0K5fvxwf',
36             request => {
37             client => {
38             id => 'DB',
39             v => '20100000',
40             type => 'IPH',
41             name => 'DB Navigator',
42             },
43             ext => 'DB.R21.12.a',
44             ver => '1.15',
45             auth => {
46             type => 'AID',
47             aid => 'n91dB8Z77' . 'MLdoR0K'
48             },
49             },
50             },
51             NAHSH => {
52             mgate => 'https://nah.sh.hafas.de/bin/mgate.exe',
53             stopfinder => 'https://nah.sh.hafas.de/bin/ajax-getstop.exe',
54             name => 'Nahverkehrsverbund Schleswig-Holstein',
55             productbits => [qw[ice ice ice regio s bus ferry u tram ondemand]],
56             request => {
57             client => {
58             id => 'NAHSH',
59             v => '3000700',
60             type => 'IPH',
61             name => 'NAHSHPROD',
62             },
63             ver => '1.16',
64             auth => {
65             type => 'AID',
66             aid => 'r0Ot9FLF' . 'NAFxijLW'
67             },
68             },
69             },
70             NASA => {
71             mgate => 'https://reiseauskunft.insa.de/bin/mgate.exe',
72             stopfinder => 'https://reiseauskunft.insa.de/bin/ajax-getstop.exe',
73             name => 'Nahverkehrsservice Sachsen-Anhalt',
74             productbits => [qw[ice ice regio regio regio tram bus ondemand]],
75             request => {
76             client => {
77             id => 'NASA',
78             v => '4000200',
79             type => 'IPH',
80             name => 'nasaPROD',
81             os => 'iPhone OS 13.1.2',
82             },
83             ver => '1.18',
84             auth => {
85             type => 'AID',
86             aid => 'nasa-' . 'apps',
87             },
88             lang => 'deu',
89             },
90             },
91             NVV => {
92             mgate => 'https://auskunft.nvv.de/auskunft/bin/app/mgate.exe',
93             stopfinder =>
94             'https://auskunft.nvv.de/auskunft/bin/jp/ajax-getstop.exe',
95             name => 'Nordhessischer VerkehrsVerbund',
96             productbits =>
97             [qw[ice ic_ec regio s u tram bus bus ferry ondemand regio regio]],
98             request => {
99             client => {
100             id => 'NVV',
101             v => '5000300',
102             type => 'IPH',
103             name => 'NVVMobilPROD_APPSTORE',
104             os => 'iOS 13.1.2',
105             },
106             ext => 'NVV.6.0',
107             ver => '1.18',
108             auth => {
109             type => 'AID',
110             aid => 'Kt8eNOH7' . 'qjVeSxNA',
111             },
112             lang => 'deu',
113             },
114             },
115             'ÖBB' => {
116             mgate => 'https://fahrplan.oebb.at/bin/mgate.exe',
117             stopfinder => 'https://fahrplan.oebb.at/bin/ajax-getstop.exe',
118             name => 'Österreichische Bundesbahnen',
119             productbits =>
120             [qw[ice ice ice regio regio s bus ferry u tram ice ondemand ice]],
121             request => {
122             client => {
123             id => 'OEBB',
124             v => '6030600',
125             type => 'IPH',
126             name => 'oebbPROD-ADHOC',
127             },
128             ver => '1.41',
129             auth => {
130             type => 'AID',
131             aid => 'OWDL4fE4' . 'ixNiPBBm',
132             },
133             lang => 'deu',
134             },
135             },
136             VBB => {
137             mgate => 'https://fahrinfo.vbb.de/bin/mgate.exe',
138             stopfinder => 'https://fahrinfo.vbb.de/bin/ajax-getstop.exe',
139             name => 'Verkehrsverbund Berlin-Brandenburg',
140             productbits => [qw[s u tram bus ferry ice regio]],
141             request => {
142             client => {
143             id => 'VBB',
144             type => 'WEB',
145             name => 'VBB WebApp',
146             l => 'vs_webapp_vbb',
147             },
148             ext => 'VBB.1',
149             ver => '1.33',
150             auth => {
151             type => 'AID',
152             aid => 'hafas-vb' . 'b-webapp',
153             },
154             lang => 'deu',
155             },
156             },
157             VBN => {
158             mgate => 'https://fahrplaner.vbn.de/bin/mgate.exe',
159             stopfinder => 'https://fahrplaner.vbn.de/hafas/ajax-getstop.exe',
160             name => 'Verkehrsverbund Bremen/Niedersachsen',
161             productbits => [qw[ice ice regio regio s bus ferry u tram ondemand]],
162             salt => 'SP31mBu' . 'fSyCLmNxp',
163             micmac => 1,
164             request => {
165             client => {
166             id => 'VBN',
167             v => '6000000',
168             type => 'IPH',
169             name => 'vbn',
170             },
171             ver => '1.42',
172             auth => {
173             type => 'AID',
174             aid => 'kaoxIXLn' . '03zCr2KR',
175             },
176             lang => 'deu',
177             },
178             },
179             );
180              
181             # }}}
182             # {{{ Constructors
183              
184             sub new {
185 1     1 1 3146 my ( $obj, %conf ) = @_;
186 1         7 my $service = $conf{service};
187              
188 1         4 my $ua = $conf{user_agent};
189              
190 1 50       6 if ( not $ua ) {
191 1   50     3 my %lwp_options = %{ $conf{lwp_options} // { timeout => 10 } };
  1         12  
192 1         15 $ua = LWP::UserAgent->new(%lwp_options);
193 1         3191 $ua->env_proxy;
194             }
195              
196 1 0 33     4505 if (
      0        
      0        
197             not( $conf{station}
198             or $conf{journey}
199             or $conf{geoSearch}
200             or $conf{locationSearch} )
201             )
202             {
203 0         0 confess(
204             'station / journey / geoSearch / locationSearch must be specified');
205             }
206              
207 1 50       5 if ( not defined $service ) {
208 0         0 $service = $conf{service} = 'DB';
209             }
210              
211 1 50 33     11 if ( defined $service and not exists $hafas_instance{$service} ) {
212 0         0 confess("The service '$service' is not supported");
213             }
214              
215 1         9 my $now = DateTime->now( time_zone => 'Europe/Berlin' );
216             my $self = {
217             active_service => $service,
218             arrivals => $conf{arrivals},
219             cache => $conf{cache},
220             developer_mode => $conf{developer_mode},
221             exclusive_mots => $conf{exclusive_mots},
222             excluded_mots => $conf{excluded_mots},
223             messages => [],
224             results => [],
225             station => $conf{station},
226 1         15959 ua => $ua,
227             now => $now,
228             };
229              
230 1         6 bless( $self, $obj );
231              
232 1         2 my $req;
233              
234 1 50       10 if ( $conf{journey} ) {
    50          
    50          
235             $req = {
236             svcReqL => [
237             {
238             meth => 'JourneyDetails',
239             req => {
240             jid => $conf{journey}{id},
241             name => $conf{journey}{name} // '0',
242             getPolyline => $conf{with_polyline} ? \1 : \0,
243             },
244             }
245             ],
246 0 0 0     0 %{ $hafas_instance{$service}{request} }
  0         0  
247             };
248             }
249             elsif ( $conf{geoSearch} ) {
250             $req = {
251             svcReqL => [
252             {
253             cfg => { polyEnc => 'GPA' },
254             meth => 'LocGeoPos',
255             req => {
256             ring => {
257             cCrd => {
258             x => int( $conf{geoSearch}{lon} * 1e6 ),
259             y => int( $conf{geoSearch}{lat} * 1e6 ),
260             },
261             maxDist => -1,
262             minDist => 0,
263             },
264             locFltrL => [
265             {
266             type => "PROD",
267             mode => "INC",
268             value => $self->mot_mask
269             }
270             ],
271             getPOIs => \0,
272             getStops => \1,
273             maxLoc => $conf{results} // 30,
274             }
275             }
276             ],
277 0   0     0 %{ $hafas_instance{$service}{request} }
  0         0  
278             };
279             }
280             elsif ( $conf{locationSearch} ) {
281             $req = {
282             svcReqL => [
283             {
284             cfg => { polyEnc => 'GPA' },
285             meth => 'LocMatch',
286             req => {
287             input => {
288             loc => {
289             type => 'S',
290             name => $conf{locationSearch},
291             },
292             maxLoc => $conf{results} // 30,
293             field => 'S',
294             },
295             }
296             }
297             ],
298 0   0     0 %{ $hafas_instance{$service}{request} }
  0         0  
299             };
300             }
301             else {
302 1   33     23 my $date = ( $conf{datetime} // $now )->strftime('%Y%m%d');
303 1   33     111 my $time = ( $conf{datetime} // $now )->strftime('%H%M%S');
304              
305 1         93 my $lid;
306 1 50       11 if ( $self->{station} =~ m{ ^ [0-9]+ $ }x ) {
307 0         0 $lid = 'A=1@L=' . $self->{station} . '@';
308             }
309             else {
310 1         6 $lid = 'A=1@O=' . $self->{station} . '@';
311             }
312              
313 1   50     9 my $maxjny = $conf{results} // 30;
314 1   50     6 my $duration = $conf{lookahead} // -1;
315              
316             $req = {
317             svcReqL => [
318             {
319             meth => 'StationBoard',
320             req => {
321             type => ( $conf{arrivals} ? 'ARR' : 'DEP' ),
322             stbLoc => { lid => $lid },
323             dirLoc => undef,
324             maxJny => $maxjny,
325             date => $date,
326             time => $time,
327             dur => $duration,
328             jnyFltrL => [
329             {
330             type => "PROD",
331             mode => "INC",
332             value => $self->mot_mask
333             }
334             ]
335             },
336             },
337             ],
338 1 50       9 %{ $hafas_instance{$service}{request} }
  1         7  
339             };
340             }
341              
342 1   33     18 $self->{strptime_obj} //= DateTime::Format::Strptime->new(
343             pattern => '%Y%m%dT%H%M%S',
344             time_zone => 'Europe/Berlin',
345             );
346              
347 1         2419 my $json = $self->{json} = JSON->new->utf8;
348              
349             # The JSON request is the cache key, so if we have a cache we must ensure
350             # that JSON serialization is deterministic.
351 1 50       4 if ( $self->{cache} ) {
352 0         0 $json->canonical;
353             }
354              
355 1         29 $req = $json->encode($req);
356 1         10 $self->{post} = $req;
357              
358 1   33     7 my $url = $conf{url} // $hafas_instance{$service}{mgate};
359              
360 1 50       7 if ( my $salt = $hafas_instance{$service}{salt} ) {
361 1 50       3 if ( $hafas_instance{$service}{micmac} ) {
362 0         0 my $mic = md5_hex( $self->{post} );
363 0         0 my $mac = md5_hex( $mic . $salt );
364 0         0 $url .= "?mic=$mic&mac=$mac";
365             }
366             else {
367 1         11 $url .= '?checksum=' . md5_hex( $self->{post} . $salt );
368             }
369             }
370              
371 1 50       5 if ( $conf{async} ) {
372 0         0 $self->{url} = $url;
373 0         0 return $self;
374             }
375              
376 1 50       4 if ( $conf{json} ) {
377 1         3 $self->{raw_json} = $conf{json};
378             }
379             else {
380 0 0       0 if ( $self->{developer_mode} ) {
381 0         0 say "requesting $req from $url";
382             }
383              
384 0         0 my ( $content, $error ) = $self->post_with_cache($url);
385              
386 0 0       0 if ($error) {
387 0         0 $self->{errstr} = $error;
388 0         0 return $self;
389             }
390              
391 0 0       0 if ( $self->{developer_mode} ) {
392 0         0 say decode( 'utf-8', $content );
393             }
394              
395 0         0 $self->{raw_json} = $json->decode($content);
396             }
397              
398 1         4 $self->check_mgate;
399              
400 1 50 33     8 if ( $conf{journey} ) {
    50          
401 0         0 $self->parse_journey;
402             }
403             elsif ( $conf{geoSearch} or $conf{locationSearch} ) {
404 0         0 $self->parse_search;
405             }
406             else {
407 1         4 $self->parse_board;
408             }
409              
410 1         10 return $self;
411             }
412              
413             sub new_p {
414 0     0 1 0 my ( $obj, %conf ) = @_;
415 0         0 my $promise = $conf{promise}->new;
416              
417 0 0 0     0 if (
      0        
      0        
418             not( $conf{station}
419             or $conf{journey}
420             or $conf{geoSearch}
421             or $conf{locationSearch} )
422             )
423             {
424 0         0 return $promise->reject('station or journey flag must be passed');
425             }
426              
427 0         0 my $self = $obj->new( %conf, async => 1 );
428 0         0 $self->{promise} = $conf{promise};
429              
430             $self->post_with_cache_p( $self->{url} )->then(
431             sub {
432 0     0   0 my ($content) = @_;
433 0         0 $self->{raw_json} = $self->{json}->decode($content);
434 0         0 $self->check_mgate;
435 0 0 0     0 if ( $conf{journey} ) {
    0          
436 0         0 $self->parse_journey;
437             }
438             elsif ( $conf{geoSearch} or $conf{locationSearch} ) {
439 0         0 $self->parse_search;
440             }
441             else {
442 0         0 $self->parse_board;
443             }
444 0 0       0 if ( $self->errstr ) {
445 0         0 $promise->reject( $self->errstr, $self );
446             }
447             else {
448 0         0 $promise->resolve($self);
449             }
450 0         0 return;
451             }
452             )->catch(
453             sub {
454 0     0   0 my ($err) = @_;
455 0         0 $promise->reject($err);
456 0         0 return;
457             }
458 0         0 )->wait;
459              
460 0         0 return $promise;
461             }
462              
463             # }}}
464             # {{{ Internal Helpers
465              
466             sub mot_mask {
467 1     1 0 4 my ($self) = @_;
468              
469 1         4 my $service = $self->{active_service};
470 1         2 my $mot_mask = 2**@{ $hafas_instance{$service}{productbits} } - 1;
  1         7  
471              
472 1         3 my %mot_pos;
473 1         3 for my $i ( 0 .. $#{ $hafas_instance{$service}{productbits} } ) {
  1         8  
474 10         31 $mot_pos{ $hafas_instance{$service}{productbits}[$i] } = $i;
475             }
476              
477 1 50 50     5 if ( my @mots = @{ $self->{exclusive_mots} // [] } ) {
  1         7  
478 0         0 $mot_mask = 0;
479 0         0 for my $mot (@mots) {
480 0         0 $mot_mask |= 1 << $mot_pos{$mot};
481             }
482             }
483              
484 1 50 50     3 if ( my @mots = @{ $self->{excluded_mots} // [] } ) {
  1         7  
485 0         0 for my $mot (@mots) {
486 0         0 $mot_mask &= ~( 1 << $mot_pos{$mot} );
487             }
488             }
489              
490 1         18 return $mot_mask;
491             }
492              
493             sub post_with_cache {
494 0     0 0 0 my ( $self, $url ) = @_;
495 0         0 my $cache = $self->{cache};
496              
497 0 0       0 if ( $self->{developer_mode} ) {
498 0         0 say "POST $url";
499             }
500              
501 0 0       0 if ($cache) {
502 0         0 my $content = $cache->thaw( $self->{post} );
503 0 0       0 if ($content) {
504 0 0       0 if ( $self->{developer_mode} ) {
505 0         0 say ' cache hit';
506             }
507 0         0 return ( ${$content}, undef );
  0         0  
508             }
509             }
510              
511 0 0       0 if ( $self->{developer_mode} ) {
512 0         0 say ' cache miss';
513             }
514              
515             my $reply = $self->{ua}->post(
516             $url,
517             'Content-Type' => 'application/json',
518             Content => $self->{post}
519 0         0 );
520              
521 0 0       0 if ( $reply->is_error ) {
522 0         0 return ( undef, $reply->status_line );
523             }
524 0         0 my $content = $reply->content;
525              
526 0 0       0 if ($cache) {
527 0         0 say "freeeez";
528 0         0 $cache->freeze( $self->{post}, \$content );
529             }
530              
531 0         0 return ( $content, undef );
532             }
533              
534             sub post_with_cache_p {
535 0     0 0 0 my ( $self, $url ) = @_;
536 0         0 my $cache = $self->{cache};
537              
538 0 0       0 if ( $self->{developer_mode} ) {
539 0         0 say "POST $url";
540             }
541              
542 0         0 my $promise = $self->{promise}->new;
543              
544 0 0       0 if ($cache) {
545 0         0 my $content = $cache->thaw( $self->{post} );
546 0 0       0 if ($content) {
547 0 0       0 if ( $self->{developer_mode} ) {
548 0         0 say ' cache hit';
549             }
550 0         0 return $promise->resolve( ${$content} );
  0         0  
551             }
552             }
553              
554 0 0       0 if ( $self->{developer_mode} ) {
555 0         0 say ' cache miss';
556             }
557              
558             $self->{ua}->post_p( $url, $self->{post} )->then(
559             sub {
560 0     0   0 my ($tx) = @_;
561 0 0       0 if ( my $err = $tx->error ) {
562 0         0 $promise->reject(
563             "POST $url returned HTTP $err->{code} $err->{message}");
564 0         0 return;
565             }
566 0         0 my $content = $tx->res->body;
567 0 0       0 if ($cache) {
568 0         0 $cache->freeze( $self->{post}, \$content );
569             }
570 0         0 $promise->resolve($content);
571 0         0 return;
572             }
573             )->catch(
574             sub {
575 0     0   0 my ($err) = @_;
576 0         0 $promise->reject($err);
577 0         0 return;
578             }
579 0         0 )->wait;
580              
581 0         0 return $promise;
582             }
583              
584             sub check_mgate {
585 1     1 0 4 my ($self) = @_;
586              
587 1 50 33     12 if ( $self->{raw_json}{err} and $self->{raw_json}{err} ne 'OK' ) {
    50 33        
    50 33        
    50          
588             $self->{errstr} = $self->{raw_json}{errTxt}
589 0   0     0 // 'error code is ' . $self->{raw_json}{err};
590 0         0 $self->{errcode} = $self->{raw_json}{err};
591             }
592             elsif ( defined $self->{raw_json}{cInfo}{code}
593             and $self->{raw_json}{cInfo}{code} ne 'OK'
594             and $self->{raw_json}{cInfo}{code} ne 'VH' )
595             {
596 0         0 $self->{errstr} = 'cInfo code is ' . $self->{raw_json}{cInfo}{code};
597 0         0 $self->{errcode} = $self->{raw_json}{cInfo}{code};
598             }
599 1   50     8 elsif ( @{ $self->{raw_json}{svcResL} // [] } == 0 ) {
600 0         0 $self->{errstr} = 'svcResL is empty';
601             }
602             elsif ( $self->{raw_json}{svcResL}[0]{err} ne 'OK' ) {
603             $self->{errstr}
604 0         0 = 'svcResL[0].err is ' . $self->{raw_json}{svcResL}[0]{err};
605 0         0 $self->{errcode} = $self->{raw_json}{svcResL}[0]{err};
606             }
607              
608 1         3 return $self;
609             }
610              
611             sub add_message {
612 1     1 0 5 my ( $self, $json, $is_him ) = @_;
613              
614 1         4 my $short = $json->{txtS};
615 1         2 my $text = $json->{txtN};
616 1         3 my $code = $json->{code};
617 1         3 my $prio = $json->{prio};
618              
619 1 50       4 if ($is_him) {
620 0         0 $short = $json->{head};
621 0         0 $text = $json->{text};
622 0         0 $code = $json->{hid};
623             }
624              
625             # Some backends use remL for operator information. We don't want that.
626 1 50       6 if ( $code eq 'OPERATOR' ) {
627 0         0 return;
628             }
629              
630 1         2 for my $message ( @{ $self->{messages} } ) {
  1         6  
631 0 0 0     0 if ( $code eq $message->{code} and $text eq $message->{text} ) {
632 0         0 $message->{ref_count}++;
633 0         0 return $message;
634             }
635             }
636              
637 1         15 my $message = Travel::Status::DE::HAFAS::Message->new(
638             short => $short,
639             text => $text,
640             code => $code,
641             prio => $prio,
642             is_him => $is_him,
643             ref_count => 1,
644             );
645 1         2 push( @{ $self->{messages} }, $message );
  1         5  
646 1         4 return $message;
647             }
648              
649             sub parse_search {
650 0     0 0 0 my ($self) = @_;
651              
652 0         0 $self->{results} = [];
653              
654 0 0       0 if ( $self->{errstr} ) {
655 0         0 return $self;
656             }
657              
658 0   0     0 my @refLocL = @{ $self->{raw_json}{svcResL}[0]{res}{common}{locL} // [] };
  0         0  
659 0   0     0 my @locL = @{ $self->{raw_json}{svcResL}[0]{res}{locL} // [] };
  0         0  
660              
661 0 0       0 if ( $self->{raw_json}{svcResL}[0]{res}{match} ) {
662 0   0     0 @locL = @{ $self->{raw_json}{svcResL}[0]{res}{match}{locL} // [] };
  0         0  
663             }
664              
665 0         0 for my $loc (@locL) {
666             push(
667 0         0 @{ $self->{results} },
  0         0  
668             Travel::Status::DE::HAFAS::Stop->new( loc => $loc )
669             );
670             }
671              
672 0         0 return $self;
673             }
674              
675             sub parse_journey {
676 0     0 0 0 my ($self) = @_;
677              
678 0 0       0 if ( $self->{errstr} ) {
679 0         0 return $self;
680             }
681              
682 0   0     0 my @locL = @{ $self->{raw_json}{svcResL}[0]{res}{common}{locL} // [] };
  0         0  
683 0         0 my $journey = $self->{raw_json}{svcResL}[0]{res}{journey};
684 0         0 my @polyline;
685              
686 0 0       0 if ( $journey->{poly} ) {
687 0         0 @polyline = decode_polyline( $journey->{poly}{crdEncYX} );
688 0   0     0 for my $ref ( @{ $journey->{poly}{ppLocRefL} // [] } ) {
  0         0  
689 0         0 my $poly = $polyline[ $ref->{ppIdx} ];
690 0         0 my $loc = $locL[ $ref->{locX} ];
691              
692 0         0 $poly->{name} = $loc->{name};
693 0         0 $poly->{eva} = $loc->{extId} + 0;
694             }
695             }
696              
697             $self->{result} = Travel::Status::DE::HAFAS::Journey->new(
698             common => $self->{raw_json}{svcResL}[0]{res}{common},
699 0         0 journey => $journey,
700             polyline => \@polyline,
701             hafas => $self,
702             );
703              
704 0         0 return $self;
705             }
706              
707             sub parse_board {
708 1     1 0 4 my ($self) = @_;
709              
710 1         4 $self->{results} = [];
711              
712 1 50       3 if ( $self->{errstr} ) {
713 0         0 return $self;
714             }
715              
716 1   50     3 my @jnyL = @{ $self->{raw_json}{svcResL}[0]{res}{jnyL} // [] };
  1         10  
717              
718 1         3 for my $result (@jnyL) {
719             push(
720 30         162 @{ $self->{results} },
721             Travel::Status::DE::HAFAS::Journey->new(
722             common => $self->{raw_json}{svcResL}[0]{res}{common},
723 30         58 journey => $result,
724             hafas => $self,
725             )
726             );
727             }
728 1         19 return $self;
729             }
730              
731             # }}}
732             # {{{ Public Functions
733              
734             sub errcode {
735 1     1 1 8 my ($self) = @_;
736              
737 1         16 return $self->{errcode};
738             }
739              
740             sub errstr {
741 1     1 1 5 my ($self) = @_;
742              
743 1         6 return $self->{errstr};
744             }
745              
746             sub similar_stops {
747 0     0 1 0 my ($self) = @_;
748              
749 0         0 my $service = $self->{active_service};
750              
751 0 0 0     0 if ( $service and exists $hafas_instance{$service}{stopfinder} ) {
752              
753             my $sf = Travel::Status::DE::HAFAS::StopFinder->new(
754             url => $hafas_instance{$service}{stopfinder},
755             input => $self->{station},
756             ua => $self->{ua},
757             developer_mode => $self->{developer_mode},
758 0         0 );
759 0 0       0 if ( my $err = $sf->errstr ) {
760 0         0 $self->{errstr} = $err;
761 0         0 return;
762             }
763 0         0 return $sf->results;
764             }
765 0         0 return;
766             }
767              
768             sub similar_stops_p {
769 0     0 1 0 my ( $self, %opt ) = @_;
770              
771 0         0 my $service = $self->{active_service};
772              
773 0 0 0     0 if ( $service and exists $hafas_instance{$service}{stopfinder} ) {
774 0   0     0 $opt{user_agent} //= $self->{ua};
775 0   0     0 $opt{promise} //= $self->{promise};
776             return Travel::Status::DE::HAFAS::StopFinder->new_p(
777             url => $hafas_instance{$service}{stopfinder},
778             input => $self->{station},
779             user_agent => $opt{user_agent},
780             developer_mode => $self->{developer_mode},
781             promise => $opt{promise},
782 0         0 );
783             }
784             return $opt{promise}
785 0         0 ->reject("stopfinder not available for backend '$service'");
786             }
787              
788             sub station {
789 0     0 1 0 my ($self) = @_;
790              
791 0 0       0 if ( $self->{station_info} ) {
792 0         0 return $self->{station_info};
793             }
794              
795 0   0     0 my @locL = @{ $self->{raw_json}{svcResL}[0]{res}{common}{locL} // [] };
  0         0  
796              
797 0         0 my %prefc_by_loc;
798              
799 0         0 for my $i ( 0 .. $#locL ) {
800 0         0 my $loc = $locL[$i];
801 0 0       0 if ( $loc->{pRefL} ) {
802 0         0 $prefc_by_loc{$i} = $#{ $loc->{pRefL} };
  0         0  
803             }
804             }
805              
806 0         0 my @prefcounts = sort { $b->[0] <=> $a->[0] }
807 0         0 map { [ $_, $prefc_by_loc{$_} ] } keys %prefc_by_loc;
  0         0  
808              
809 0         0 my $loc = $locL[ $prefcounts[0][0] ];
810              
811 0 0       0 if ($loc) {
812             $self->{station_info} = {
813             name => $loc->{name},
814             eva => $loc->{extId},
815 0         0 names => [ map { $locL[ $_->[0] ]{name} } @prefcounts ],
816 0         0 evas => [ map { $locL[ $_->[0] ]{extId} } @prefcounts ],
  0         0  
817             };
818             }
819             else {
820 0         0 $self->{station_info} = {};
821             }
822              
823 0         0 return $self->{station_info};
824             }
825              
826             sub messages {
827 0     0 1 0 my ($self) = @_;
828 0         0 return @{ $self->{messages} };
  0         0  
829             }
830              
831             sub results {
832 2     2 1 6 my ($self) = @_;
833 2         5 return @{ $self->{results} };
  2         18  
834             }
835              
836             sub result {
837 0     0 1 0 my ($self) = @_;
838 0         0 return $self->{result};
839             }
840              
841             # static
842             sub get_services {
843 0     0 1 0 my @services;
844 0         0 for my $service ( sort keys %hafas_instance ) {
845 0         0 my %desc = %{ $hafas_instance{$service} };
  0         0  
846 0         0 $desc{shortname} = $service;
847 0         0 push( @services, \%desc );
848             }
849 0         0 return @services;
850             }
851              
852             # static
853             sub get_service {
854 0     0 1 0 my ($service) = @_;
855              
856 0 0 0     0 if ( defined $service and exists $hafas_instance{$service} ) {
857 0         0 return $hafas_instance{$service};
858             }
859 0         0 return;
860             }
861              
862             sub get_active_service {
863 1     1 1 4 my ($self) = @_;
864              
865 1 50       6 if ( defined $self->{active_service} ) {
866 1         7 return $hafas_instance{ $self->{active_service} };
867             }
868 0           return;
869             }
870              
871             # }}}
872              
873             1;
874              
875             __END__
876              
877             =head1 NAME
878              
879             Travel::Status::DE::HAFAS - Interface to HAFAS-based online arrival/departure
880             monitors
881              
882             =head1 SYNOPSIS
883              
884             use Travel::Status::DE::HAFAS;
885              
886             my $status = Travel::Status::DE::HAFAS->new(
887             station => 'Essen Hbf',
888             );
889              
890             if (my $err = $status->errstr) {
891             die("Request error: ${err}\n");
892             }
893              
894             for my $departure ($status->results) {
895             printf(
896             "At %s: %s to %s from platform %s\n",
897             $departure->time,
898             $departure->line,
899             $departure->destination,
900             $departure->platform,
901             );
902             }
903              
904             =head1 VERSION
905              
906             version 4.16
907              
908             =head1 DESCRIPTION
909              
910             Travel::Status::DE::HAFAS is an interface to HAFAS-based
911             arrival/departure monitors using the mgate.exe interface.
912              
913             It can report departures/arrivals at a specific station, search for stations,
914             or provide details about a specific journey. It supports non-blocking operation
915             via promises.
916              
917             =head1 METHODS
918              
919             =over
920              
921             =item my $status = Travel::Status::DE::HAFAS->new(I<%opt>)
922              
923             Requests item(s) as specified by I<opt> and returns a new
924             Travel::Status::DE::HAFAS element with the results. Dies if the wrong
925             I<opt> were passed.
926              
927             I<opt> must contain either a B<station>, B<geoSearch>, B<locationSearch>, or B<journey> flag:
928              
929             =over
930              
931             =item B<station> => I<station>
932              
933             Request station board (arrivals or departures) for I<station>, e.g. "Essen HBf" or
934             "Alfredusbad, Essen (Ruhr)". The station must be specified either by name or by
935             EVA ID (e.g. 8000080 for Dortmund Hbf).
936             Results are available via C<< $status->results >>.
937              
938             =item B<geoSearch> => B<{> B<lat> => I<latitude>, B<lon> => I<longitude> B<}>
939              
940             Search for stations near I<latitude>, I<longitude>.
941             Results are available via C<< $status->results >>.
942              
943             =item B<locationSearch> => I<query>
944              
945             Search for stations whose name is similar to I<query>.
946             Results are available via C<< $status->results >>.
947              
948             =item B<journey> => B<{> B<id> => I<tripid> [, B<name> => I<line> ] B<}>
949              
950             Request details about the journey identified by I<tripid> and I<line>.
951             The result is available via C<< $status->result >>.
952              
953             =back
954              
955             The following optional flags may be set.
956             Values in brackets indicate flags that are only relevant in certain request
957             modes, e.g. geoSearch or journey.
958              
959             =over
960              
961             =item B<arrivals> => I<bool> (station)
962              
963             Request arrivals (if I<bool> is true) rather than departures (if I<bool> is
964             false or B<arrivals> is not specified).
965              
966             =item B<cache> => I<Cache::File object>
967              
968             Store HAFAS replies in the provided cache object. This module works with
969             real-time data, so the object should be configured for an expiry of one to two
970             minutes.
971              
972             =item B<datetime> => I<DateTime object> (station)
973              
974             Date and time to report for. Defaults to now.
975              
976             =item B<excluded_mots> => [I<mot1>, I<mot2>, ...] (geoSearch, station)
977              
978             By default, all modes of transport (trains, trams, buses etc.) are returned.
979             If this option is set, all modes appearing in I<mot1>, I<mot2>, ... will
980             be excluded. The supported modes depend on B<service>, use
981             B<get_services> or B<get_service> to get the supported values.
982              
983             =item B<exclusive_mots> => [I<mot1>, I<mot2>, ...] (geoSearch, station)
984              
985             If this option is set, only the modes of transport appearing in I<mot1>,
986             I<mot2>, ... will be returned. The supported modes depend on B<service>, use
987             B<get_services> or B<get_service> to get the supported values.
988              
989             =item B<lookahead> => I<int> (station)
990              
991             Request arrivals/departures that occur up to I<int> minutes after the specified datetime.
992             Default: -1 (do not limit results by time).
993              
994             =item B<lwp_options> => I<\%hashref>
995              
996             Passed on to C<< LWP::UserAgent->new >>. Defaults to C<< { timeout => 10 } >>,
997             pass an empty hashref to call the LWP::UserAgent constructor without arguments.
998              
999             =item B<results> => I<count> (geoSearch, locationSearch, station)
1000              
1001             Request up to I<count> results.
1002             Default: 30.
1003              
1004             =item B<service> => I<service>
1005              
1006             Request results from I<service>, defaults to "DB".
1007             See B<get_services> (and C<< hafas-m --list >>) for a list of supported
1008             services.
1009              
1010             =item B<with_polyline> => I<bool> (journey)
1011              
1012             Request a polyline (series of geo-coordinates) indicating the train's route.
1013              
1014             =back
1015              
1016             =item my $status_p = Travel::Status::DE::HAFAS->new_p(I<%opt>)
1017              
1018             Returns a promise that resolves into a Travel::Status::DE::HAFAS instance
1019             ($status) on success and rejects with an error message on failure. If the
1020             failure occured after receiving a response from the HAFAS backend, the rejected
1021             promise contains a Travel::Status::DE::HAFAS instance as a second argument.
1022             This instance can be used e.g. to call similar_stops_p in case of an ambiguous
1023             location specifier. In addition to the arguments of B<new>, the following
1024             mandatory arguments must be set.
1025              
1026             =over
1027              
1028             =item B<promise> => I<promises module>
1029              
1030             Promises implementation to use for internal promises as well as B<new_p> return
1031             value. Recommended: Mojo::Promise(3pm).
1032              
1033             =item B<user_agent> => I<user agent>
1034              
1035             User agent instance to use for asynchronous requests. The object must implement
1036             a B<post_p> function. Recommended: Mojo::UserAgent(3pm).
1037              
1038             =back
1039              
1040             =item $status->errcode
1041              
1042             In case of an error in the HAFAS backend, returns the corresponding error code
1043             as string. If no backend error occurred, returns undef.
1044              
1045             =item $status->errstr
1046              
1047             In case of an error in the HTTP request or HAFAS backend, returns a string
1048             describing it. If no error occurred, returns undef.
1049              
1050             =item $status->results (geoSearch, locationSearch)
1051              
1052             Returns a list of stations. Each list element is a
1053             Travel::Status::DE::HAFAS::Stop(3pm) object.
1054              
1055             If no matching results were found or the parser / http request failed, returns
1056             an empty list.
1057              
1058             =item $status->results (station)
1059              
1060             Returns a list of arrivals/departures. Each list element is a
1061             Travel::Status::DE::HAFAS::Journey(3pm) object.
1062              
1063             If no matching results were found or the parser / http request failed, returns
1064             undef.
1065              
1066             =item $status->result (journey)
1067              
1068             Returns a single Travel::Status::DE::HAFAS::Journey(3pm) object that describes
1069             the requested journey.
1070              
1071             If no result was found or the parser / http request failed, returns undef.
1072              
1073             =item $status->messages
1074              
1075             Returns a list of Travel::Status::DE::HAFAS::Message(3pm) objects with
1076             service messages. Each message belongs to at least one arrival/departure.
1077              
1078             =item $status->station
1079              
1080             Returns a hashref describing the departure stations in all requested journeys.
1081             The hashref contains four entries: B<names> (station names), B<name> (most
1082             common name), B<evas> (UIC / EVA IDs), and B<eva> (most common UIC / EVA ID).
1083             These are subject to change.
1084              
1085             Note that the most common name and ID may be different from the station for
1086             which departures were requested, as HAFAS uses different identifiers for train
1087             stations, bus stops, and other modes of transit even if they are interlinked.
1088              
1089             Not available in journey mode.
1090              
1091             =item $status->similar_stops
1092              
1093             Returns a list of hashrefs describing stops whose name is similar to the one
1094             requested in the constructor's B<station> parameter. Returns nothing if
1095             the active service does not support this feature.
1096             This is most useful if B<errcode> returns 'LOCATION', which means that the
1097             HAFAS backend could not identify the stop.
1098              
1099             See Travel::Status::DE::HAFAS::StopFinder(3pm)'s B<results> method for details
1100             on the return value.
1101              
1102             =item $status->similar_stops_p(I<%opt>)
1103              
1104             Returns a promise resolving to a list of hashrefs describing stops whose name
1105             is similar to the one requested in the constructor's B<station> parameter.
1106             Returns nothing if the active service does not support this feature. This is
1107             most useful if B<errcode> returns 'LOCATION', which means that the HAFAS
1108             backend could not identify the stop.
1109              
1110             See Travel::Status::DE::HAFAS::StopFinder(3pm)'s B<results> method for details
1111             on the resolved values.
1112              
1113             If $status has been created using B<new_p>, this function does not require
1114             arguments. Otherwise, the caller must specify B<promise> and B<user_agent>
1115             (see B<new_p> above).
1116              
1117             =item $status->get_active_service
1118              
1119             Returns a hashref describing the active service when a service is active and
1120             nothing otherwise. The hashref contains the keys B<url> (URL to the station
1121             board service), B<stopfinder> (URL to the stopfinder service, if supported),
1122             B<name>, and B<productbits> (arrayref describing the supported modes of
1123             transport, may contain duplicates).
1124              
1125             =item Travel::Status::DE::HAFAS::get_services()
1126              
1127             Returns an array containing all supported HAFAS services. Each element is a
1128             hashref and contains all keys mentioned in B<get_active_service>.
1129             It also contains a B<shortname> key, which is the service name used by
1130             the constructor's B<service> parameter.
1131              
1132             =item Travel::Status::DE::HAFAS::get_service(I<$service>)
1133              
1134             Returns a hashref describing the service I<$service>. Returns nothing if
1135             I<$service> is not supported. See B<get_active_service> for the hashref layout.
1136              
1137             =back
1138              
1139             =head1 DIAGNOSTICS
1140              
1141             None.
1142              
1143             =head1 DEPENDENCIES
1144              
1145             =over
1146              
1147             =item * Class::Accessor(3pm)
1148              
1149             =item * DateTime(3pm)
1150              
1151             =item * DateTime::Format::Strptime(3pm)
1152              
1153             =item * LWP::UserAgent(3pm)
1154              
1155             =back
1156              
1157             =head1 BUGS AND LIMITATIONS
1158              
1159             The non-default services (anything other than DB) are not well tested.
1160              
1161             =head1 SEE ALSO
1162              
1163             Travel::Status::DE::HAFAS::Journey(3pm), Travel::Status::DE::HAFAS::StopFinder(3pm).
1164              
1165             =head1 AUTHOR
1166              
1167             Copyright (C) 2015-2022 by Birte Kristina Friesel E<lt>derf@finalrewind.orgE<gt>
1168              
1169             =head1 LICENSE
1170              
1171             This module is licensed under the same terms as Perl itself.