File Coverage

blib/lib/Travel/Status/DE/HAFAS/StopFinder.pm
Criterion Covered Total %
statement 26 94 27.6
branch 0 22 0.0
condition 0 9 0.0
subroutine 9 15 60.0
pod 4 4 100.0
total 39 144 27.0


line stmt bran cond sub pod time code
1             package Travel::Status::DE::HAFAS::StopFinder;
2              
3 1     1   8 use strict;
  1         2  
  1         31  
4 1     1   6 use warnings;
  1         2  
  1         22  
5 1     1   16 use 5.014;
  1         3  
6 1     1   17 use utf8;
  1         3  
  1         10  
7              
8 1     1   53 no if $] >= 5.018, warnings => 'experimental::smartmatch';
  1         2  
  1         6  
9              
10 1     1   88 use Carp qw(confess);
  1         3  
  1         97  
11 1     1   7 use Encode qw(decode);
  1         2  
  1         57  
12 1     1   7 use JSON;
  1         2  
  1         11  
13 1     1   163 use LWP::UserAgent;
  1         2  
  1         1070  
14              
15             our $VERSION = '4.15';
16              
17             # {{{ Constructors
18              
19             sub new {
20 0     0 1   my ( $obj, %conf ) = @_;
21              
22 0   0       my $lang = $conf{language} // 'd';
23 0           my $ua = $conf{ua};
24              
25 0 0 0       if ( not $ua and not $conf{async} ) {
26 0   0       my %lwp_options = %{ $conf{lwp_options} // { timeout => 10 } };
  0            
27 0           $ua = LWP::UserAgent->new(%lwp_options);
28 0           $ua->env_proxy;
29             }
30              
31 0           my $reply;
32              
33 0 0         if ( not $conf{input} ) {
34 0           confess('You need to specify an input value');
35             }
36 0 0         if ( not $conf{url} ) {
37 0           confess('You need to specify a URL');
38             }
39              
40             my $ref = {
41             developer_mode => $conf{developer_mode},
42             post => {
43             getstop => 1,
44             REQ0JourneyStopsS0A => 255,
45             REQ0JourneyStopsS0G => $conf{input},
46             },
47 0           };
48              
49 0           bless( $ref, $obj );
50              
51 0 0         if ( $conf{async} ) {
52 0           return $ref;
53             }
54              
55 0           my $url = $conf{url} . "/${lang}n";
56              
57 0           $reply = $ua->post( $url, $ref->{post} );
58              
59 0 0         if ( $reply->is_error ) {
60 0           $ref->{errstr} = $reply->status_line;
61 0           return $ref;
62             }
63              
64 0           $ref->{raw_reply} = $reply->decoded_content;
65              
66 0           $ref->{raw_reply} =~ s{ ^ SLs [.] sls = }{}x;
67 0           $ref->{raw_reply} =~ s{ ; SLs [.] showSuggestion [(] [)] ; $ }{}x;
68              
69 0 0         if ( $ref->{developer_mode} ) {
70 0           say $ref->{raw_reply};
71             }
72              
73 0           $ref->{json} = from_json( $ref->{raw_reply} );
74              
75 0           return $ref;
76             }
77              
78             sub new_p {
79 0     0 1   my ( $obj, %conf ) = @_;
80 0           my $promise = $conf{promise}->new;
81              
82 0 0         if ( not $conf{input} ) {
83 0           return $promise->reject('You need to specify an input value');
84             }
85 0 0         if ( not $conf{url} ) {
86 0           return $promise->reject('You need to specify a URL');
87             }
88              
89 0           my $self = $obj->new( %conf, async => 1 );
90 0           $self->{promise} = $conf{promise};
91              
92 0   0       my $lang = $conf{language} // 'd';
93 0           my $url = $conf{url} . "/${lang}n";
94             $conf{user_agent}->post_p( $url, form => $self->{post} )->then(
95             sub {
96 0     0     my ($tx) = @_;
97 0 0         if ( my $err = $tx->error ) {
98 0           $promise->reject(
99             "POST $url returned HTTP $err->{code} $err->{message}");
100 0           return;
101             }
102 0           my $content = $tx->res->body;
103              
104 0           $self->{raw_reply} = $content;
105              
106 0           $self->{raw_reply} =~ s{ ^ SLs [.] sls = }{}x;
107 0           $self->{raw_reply} =~ s{ ; SLs [.] showSuggestion [(] [)] ; $ }{}x;
108              
109 0 0         if ( $self->{developer_mode} ) {
110 0           say $self->{raw_reply};
111             }
112              
113 0           $self->{json} = from_json( $self->{raw_reply} );
114              
115 0           $promise->resolve( $self->results );
116 0           return;
117             }
118             )->catch(
119             sub {
120 0     0     my ($err) = @_;
121 0           $promise->reject($err);
122 0           return;
123             }
124 0           )->wait;
125              
126 0           return $promise;
127             }
128              
129             # }}}
130              
131             sub errstr {
132 0     0 1   my ($self) = @_;
133              
134 0           return $self->{errstr};
135             }
136              
137             sub results {
138 0     0 1   my ($self) = @_;
139              
140 0           $self->{results} = [];
141              
142 0           for my $result ( @{ $self->{json}->{suggestions} } ) {
  0            
143 0 0         if ( $result->{typeStr} eq '[Bhf/Hst]' ) {
144             push(
145 0           @{ $self->{results} },
146             {
147             name => decode( 'iso-8859-15', $result->{value} ),
148             id => $result->{extId}
149             }
150 0           );
151             }
152             }
153              
154 0           return @{ $self->{results} };
  0            
155             }
156              
157             1;
158              
159             __END__
160              
161             =head1 NAME
162              
163             Travel::Status::DE::HAFAS::StopFinder - Interface to HAFAS-based online stop
164             finder services
165              
166             =head1 SYNOPSIS
167              
168             use Travel::Status::DE::HAFAS::StopFinder;
169              
170             my $sf = Travel::Status::DE::HAFAS::StopFinder->new(
171             url => 'https://reiseauskunft.bahn.de/bin/ajax-getstop.exe',
172             input => 'Borbeck',
173             );
174              
175             if (my $err = $sf->errstr) {
176             die("Request error: ${err}\n");
177             }
178              
179             for my $candidate ($sf->results) {
180             printf("%s (%s)\n", $candidate->{name}, $candidate->{id});
181             }
182              
183             =head1 VERSION
184              
185             version 4.15
186              
187             =head1 DESCRIPTION
188              
189             Travel::Status::DE::HAFAS::StopFinder is an interface to the stop finder
190             service of HAFAS based arrival/departure monitors, for instance the one
191             available at L<https://reiseauskunft.bahn.de/bin/ajax-getstop.exe/dn>.
192              
193             It takes a string (usually a location or station name) and reports all
194             stations and stops which are lexically similar to it.
195              
196             =head1 METHODS
197              
198             =over
199              
200             =item my $stopfinder = Travel::Status::DE::HAFAS::StopFinder->new(I<%opts>)
201              
202             Looks up stops as specified by I<opts> and teruns a new
203             Travel::Status::DE::HAFAS::StopFinder element with the results. Dies if the
204             wrong I<opts> were passed.
205              
206             Supported I<opts> are:
207              
208             =over
209              
210             =item B<input> => I<string>
211              
212             string to look up, e.g. "Borbeck" or "Koeln Bonn Flughafen". Mandatory.
213              
214             =item B<url> => I<url>
215              
216             Base I<url> of the stop finder service, without the language and mode
217             suffix ("/dn" and similar). Mandatory. See Travel::Status::DE::HAFAS(3pm)'s
218             B<get_services> method for a list of URLs.
219              
220             =item B<language> => I<language>
221              
222             Set language. Accepted arguments are B<d>eutsch, B<e>nglish, B<i>talian and
223             B<n> (dutch), depending on the used service.
224              
225             It is unknown if this option has any effect.
226              
227             =item B<lwp_options> => I<\%hashref>
228              
229             Passed on to C<< LWP::UserAgent->new >>. Defaults to C<< { timeout => 10 } >>,
230             you can use an empty hashref to override it.
231              
232             =back
233              
234             =item my $stopfinder_p = Travel::Status::DE::HAFAS::StopFinder->new_p(I<%opt>)
235              
236             Return a promise that resolves into a list of
237             Travel::Status::DE::HAFAS::StopFinder results ($stopfinder->results) on success
238             and rejects with an error message ($stopfinder->errstr) on failure. In addition
239             to the arguments of B<new>, the following mandatory arguments must be set.
240              
241             =over
242              
243             =item B<promise> => I<promises module>
244              
245             Promises implementation to use for internal promises as well as B<new_p> return
246             value. Recommended: Mojo::Promise(3pm).
247              
248             =item B<user_agent> => I<user agent>
249              
250             User agent instance to use for asynchronous requests. The object must implement
251             a B<post_p> function. Recommended: Mojo::UserAgent(3pm).
252              
253             =back
254              
255             =item $stopfinder->errstr
256              
257             In case of an error in the HTTP request, returns a string describing it. If
258             no error occurred, returns undef.
259              
260             =item $stopfinder->results
261              
262             Returns a list of stop candidates. Each list element is a hash reference. The
263             hash keys are B<id> (IBNR / EVA / UIC station code) and B<name> (stop name).
264             Both can be used as input for the Travel::Status::DE::HAFAS(3pm) constructor.
265              
266             If no matching results were found or the parser / HTTP request failed, returns
267             the empty list.
268              
269             =back
270              
271             =head1 DIAGNOSTICS
272              
273             None.
274              
275             =head1 DEPENDENCIES
276              
277             =over
278              
279             =item * LWP::UserAgent(3pm)
280              
281             =item * JSON(3pm)
282              
283             =back
284              
285             =head1 BUGS AND LIMITATIONS
286              
287             Unknown.
288              
289             =head1 SEE ALSO
290              
291             Travel::Status::DE::HAFAS(3pm).
292              
293             =head1 AUTHOR
294              
295             Copyright (C) 2015-2017 by Birte Kristina Friesel E<lt>derf@finalrewind.orgE<gt>
296              
297             =head1 LICENSE
298              
299             This module is licensed under the same terms as Perl itself.