File Coverage

blib/lib/Travel/Status/DE/HAFAS/Journey.pm
Criterion Covered Total %
statement 140 225 62.2
branch 29 80 36.2
condition 46 120 38.3
subroutine 11 18 61.1
pod 6 9 66.6
total 232 452 51.3


line stmt bran cond sub pod time code
1             package Travel::Status::DE::HAFAS::Journey;
2              
3             # vim:foldmethod=marker
4              
5 1     1   10 use strict;
  1         2  
  1         31  
6 1     1   5 use warnings;
  1         2  
  1         24  
7 1     1   19 use 5.014;
  1         27  
8              
9 1     1   7 no if $] >= 5.018, warnings => 'experimental::smartmatch';
  1         2  
  1         12  
10              
11 1     1   74 use parent 'Class::Accessor';
  1         2  
  1         5  
12 1     1   86 use DateTime::Format::Strptime;
  1         4  
  1         21  
13 1     1   69 use List::Util qw(any);
  1         2  
  1         79  
14 1     1   508 use Travel::Status::DE::HAFAS::Stop;
  1         3  
  1         5  
15              
16             our $VERSION = '4.17';
17              
18             Travel::Status::DE::HAFAS::Journey->mk_ro_accessors(
19             qw(datetime sched_datetime rt_datetime
20             is_cancelled is_partially_cancelled
21             station station_eva platform sched_platform rt_platform operator
22             id name type type_long class number line line_no load delay
23             route_end route_start origin destination direction)
24             );
25              
26             # {{{ Constructor
27              
28             sub new {
29 30     30 1 129 my ( $obj, %opt ) = @_;
30              
31 30   50     56 my @locL = @{ $opt{common}{locL} // [] };
  30         213  
32 30   50     62 my @prodL = @{ $opt{common}{prodL} // [] };
  30         104  
33 30   50     45 my @opL = @{ $opt{common}{opL} // [] };
  30         85  
34 30   50     43 my @icoL = @{ $opt{common}{icoL} // [] };
  30         83  
35 30   50     53 my @tcocL = @{ $opt{common}{tcocL} // [] };
  30         121  
36 30   50     56 my @remL = @{ $opt{common}{remL} // [] };
  30         69  
37 30   50     45 my @himL = @{ $opt{common}{himL} // [] };
  30         100  
38              
39 30         49 my $hafas = $opt{hafas};
40 30         50 my $journey = $opt{journey};
41              
42 30         221 my $date = $journey->{date};
43              
44 30         109 my $direction = $journey->{dirTxt};
45 30         52 my $jid = $journey->{jid};
46              
47 30         51 my $is_cancelled = $journey->{isCncl};
48 30         68 my $partially_cancelled = $journey->{isPartCncl};
49              
50 30         57 my $product = $prodL[ $journey->{prodX} ];
51 30   33     122 my $name = $product->{addName} // $product->{name};
52 30         105 my $line_no = $product->{prodCtx}{line};
53 30         63 my $train_no = $product->{prodCtx}{num};
54 30         65 my $cat = $product->{prodCtx}{catOut};
55 30         70 my $catlong = $product->{prodCtx}{catOutL};
56 30 0 33     148 if ( $name and $cat and $name eq $cat and $product->{nameS} ) {
      33        
      33        
57 0         0 $name .= ' ' . $product->{nameS};
58             }
59 30 50 33     98 if ( defined $train_no and not $train_no ) {
60 0         0 $train_no = undef;
61             }
62 30 0 33     65 if (
      0        
      33        
63             not defined $line_no
64             and defined $product->{prodCtx}{matchId}
65             and
66             ( not defined $train_no or $product->{prodCtx}{matchId} ne $train_no )
67             )
68             {
69 0         0 $line_no = $product->{prodCtx}{matchId};
70             }
71              
72 30         47 my $operator;
73 30 50       70 if ( defined $product->{oprX} ) {
74 30 50       69 if ( my $opref = $opL[ $product->{oprX} ] ) {
75 30         60 $operator = $opref->{name};
76             }
77             }
78              
79 30         43 my @messages;
80 30   100     44 for my $msg ( @{ $journey->{msgL} // [] } ) {
  30         121  
81 1 50 33     13 if ( $msg->{type} eq 'REM' and defined $msg->{remX} ) {
    0 0        
82 1         7 push( @messages, $hafas->add_message( $remL[ $msg->{remX} ] ) );
83             }
84             elsif ( $msg->{type} eq 'HIM' and defined $msg->{himX} ) {
85 0         0 push( @messages, $hafas->add_message( $himL[ $msg->{himX} ], 1 ) );
86             }
87             else {
88 0         0 say "Unknown message type $msg->{type}";
89             }
90             }
91              
92 30         249 my $date_ref = ( split( qr{[|]}, $jid ) )[4];
93 30 50       116 if ( length($date_ref) < 7 ) {
94 0         0 warn("HAFAS, not even once -- midnight crossing may be bogus");
95             }
96 30 50       66 if ( length($date_ref) == 7 ) {
97 30         77 $date_ref = "0${date_ref}";
98             }
99 30         122 my $datetime_ref = DateTime::Format::Strptime->new(
100             pattern => '%d%m%Y',
101             time_zone => 'Europe/Berlin'
102             )->parse_datetime($date_ref);
103              
104 30         67997 my $class = $product->{cls};
105              
106 30         83 my @stops;
107             my $route_end;
108 30   50     44 for my $stop ( @{ $journey->{stopL} // [] } ) {
  30         214  
109 389         1379 my $loc = $locL[ $stop->{locX} ];
110 389         1077 my $sched_arr = $stop->{aTimeS};
111 389         623 my $rt_arr = $stop->{aTimeR};
112 389         644 my $sched_dep = $stop->{dTimeS};
113 389         682 my $rt_dep = $stop->{dTimeR};
114              
115             # dIn. / aOut. -> may passengers enter / exit the train?
116              
117 389   66     1254 my $sched_platform = $stop->{aPlatfS} // $stop->{dPlatfS};
118 389   33     1233 my $rt_platform = $stop->{aPlatfR} // $stop->{dPlatfR};
119 389   33     1144 my $changed_platform = $stop->{aPlatfCh} // $stop->{dPlatfCh};
120              
121 389         725 for my $timestr ( $sched_arr, $rt_arr, $sched_dep, $rt_dep ) {
122 1556 100       3169 if ( not defined $timestr ) {
123 1138         1912 next;
124             }
125              
126             $timestr = handle_day_change(
127             input => $timestr,
128             date => $date,
129             strp_obj => $hafas->{strptime_obj},
130 418         1026 ref => $datetime_ref
131             );
132              
133             }
134              
135 389 50 66     1168 my $arr_delay
136             = ( $sched_arr and $rt_arr )
137             ? ( $rt_arr->epoch - $sched_arr->epoch ) / 60
138             : undef;
139              
140 389 100 100     2973 my $dep_delay
141             = ( $sched_dep and $rt_dep )
142             ? ( $rt_dep->epoch - $sched_dep->epoch ) / 60
143             : undef;
144              
145 389         1412 my $arr_cancelled = $stop->{aCncl};
146 389         616 my $dep_cancelled = $stop->{dCncl};
147              
148 389         707 my $tco = {};
149 389   50     669 for my $tco_id ( @{ $stop->{dTrnCmpSX}{tcocX} // [] } ) {
  389         1916  
150 0         0 my $tco_kv = $tcocL[$tco_id];
151 0         0 $tco->{ $tco_kv->{c} } = $tco_kv->{r};
152             }
153              
154             push(
155             @stops,
156             {
157             loc => $loc,
158             extra => {
159             sched_arr => $sched_arr,
160             rt_arr => $rt_arr,
161             arr => $rt_arr // $sched_arr,
162             arr_delay => $arr_delay,
163             arr_cancelled => $arr_cancelled,
164             sched_dep => $sched_dep,
165             rt_dep => $rt_dep,
166             dep => $rt_dep // $sched_dep,
167             dep_delay => $dep_delay,
168             dep_cancelled => $dep_cancelled,
169             delay => $dep_delay // $arr_delay,
170             direction => $stop->{dDirTxt},
171 389   66     1375 sched_platform => $sched_platform,
      100        
      66        
      66        
172             rt_platform => $rt_platform,
173             is_changed_platform => $changed_platform,
174             platform => $rt_platform // $sched_platform,
175             load => $tco,
176             }
177             }
178             );
179 389         7736 $route_end = $loc->{name};
180             }
181              
182 30 50       105 if ( $journey->{stbStop} ) {
183 30 50       94 if ( $hafas->{arrivals} ) {
184 0         0 $route_end = $stops[0]->{name};
185 0         0 pop(@stops);
186             }
187             else {
188 30         54 shift(@stops);
189             }
190             }
191              
192 30   33     490 my $ref = {
193             id => $jid,
194             name => $name,
195             number => $train_no,
196             line => $name,
197             line_no => $line_no,
198             type => $cat,
199             type_long => $catlong,
200             class => $class,
201             operator => $operator,
202             direction => $direction,
203             is_cancelled => $is_cancelled,
204             is_partially_cancelled => $partially_cancelled,
205             route_end => $route_end // $direction,
206             messages => \@messages,
207             route => \@stops,
208             };
209              
210 30 50       89 if ( $journey->{stbStop} ) {
211 30 50       65 if ( $hafas->{arrivals} ) {
212 0         0 $ref->{origin} = $ref->{route_end};
213 0   0     0 $ref->{is_cancelled} ||= $journey->{stbStop}{aCncl};
214             }
215             else {
216 30         85 $ref->{destination} = $ref->{route_end};
217 30   66     234 $ref->{is_cancelled} ||= $journey->{stbStop}{dCncl};
218             }
219             }
220             else {
221 0         0 $ref->{route_start} = $stops[0]{loc}{name};
222             }
223              
224 30         83 bless( $ref, $obj );
225              
226 30 50       66 if ( $journey->{stbStop} ) {
227 30         136 $ref->{station} = $locL[ $journey->{stbStop}{locX} ]->{name};
228 30         78 $ref->{station_eva} = 0 + $locL[ $journey->{stbStop}{locX} ]->{extId};
229 30         90 $ref->{sched_platform} = $journey->{stbStop}{dPlatfS};
230 30         57 $ref->{rt_platform} = $journey->{stbStop}{dPlatfR};
231 30   66     125 $ref->{platform} = $ref->{rt_platform} // $ref->{sched_platform};
232              
233             my $time_s
234 30 50       106 = $journey->{stbStop}{ $hafas->{arrivals} ? 'aTimeS' : 'dTimeS' };
235             my $time_r
236 30 50       72 = $journey->{stbStop}{ $hafas->{arrivals} ? 'aTimeR' : 'dTimeR' };
237              
238 30         62 for my $timestr ( $time_s, $time_r ) {
239 60 100       143 if ( not defined $timestr ) {
240 1         4 next;
241             }
242              
243             $timestr = handle_day_change(
244             input => $timestr,
245             date => $date,
246             strp_obj => $hafas->{strptime_obj},
247 59         152 ref => $datetime_ref,
248             );
249              
250             }
251              
252 30         54 my $datetime_s = $time_s;
253 30         48 my $datetime_r = $time_r;
254              
255 30 100       94 my $delay
256             = $datetime_r
257             ? ( $datetime_r->epoch - $datetime_s->epoch ) / 60
258             : undef;
259              
260 30         544 $ref->{sched_datetime} = $datetime_s;
261 30         62 $ref->{rt_datetime} = $datetime_r;
262 30   66     79 $ref->{datetime} = $datetime_r // $datetime_s;
263 30         145 $ref->{delay} = $delay;
264              
265 30 100       78 if ( $ref->{delay} ) {
266 2         17 $ref->{datetime} = $ref->{rt_datetime};
267             }
268             else {
269 28         55 $ref->{datetime} = $ref->{sched_datetime};
270             }
271              
272 30         49 my %tco;
273 30   50     46 for my $tco_id ( @{ $journey->{stbStop}{dTrnCmpSX}{tcocX} // [] } ) {
  30         166  
274 0         0 my $tco_kv = $tcocL[$tco_id];
275 0         0 $tco{ $tco_kv->{c} } = $tco_kv->{r};
276             }
277 30 50       123 if (%tco) {
278 0         0 $ref->{load} = \%tco;
279             }
280             }
281 30 50       76 if ( $opt{polyline} ) {
282 0         0 $ref->{polyline} = $opt{polyline};
283             }
284              
285 30         520 return $ref;
286             }
287              
288             # }}}
289              
290             sub handle_day_change {
291 477     477 0 1760 my (%opt) = @_;
292 477         884 my $date = $opt{date};
293 477         701 my $timestr = $opt{input};
294 477 50       1016 if ( length($timestr) == 8 ) {
295              
296             # arrival time includes a day offset
297 0         0 my $offset_date = $opt{ref}->clone;
298 0         0 $offset_date->add( days => substr( $timestr, 0, 2, q{} ) );
299 0         0 $offset_date = $offset_date->strftime('%Y%m%d');
300 0         0 $timestr = $opt{strp_obj}->parse_datetime("${offset_date}T${timestr}");
301             }
302             else {
303 477         2498 $timestr = $opt{strp_obj}->parse_datetime("${date}T${timestr}");
304             }
305 477         406654 return $timestr;
306             }
307              
308             # {{{ Accessors
309              
310             # Legacy
311             sub station_uic {
312 0     0 0 0 my ($self) = @_;
313 0         0 return $self->{station_eva};
314             }
315              
316             sub is_changed_platform {
317 3     3 1 21267 my ($self) = @_;
318              
319 3 50 33     15 if ( defined $self->{rt_platform} and defined $self->{sched_platform} ) {
320 0 0       0 if ( $self->{rt_platform} ne $self->{sched_platform} ) {
321 0         0 return 1;
322             }
323 0         0 return 0;
324             }
325 3 50       10 if ( defined $self->{rt_platform} ) {
326 0         0 return 1;
327             }
328              
329 3         19 return 0;
330             }
331              
332             sub messages {
333 0     0 1   my ($self) = @_;
334              
335 0 0         if ( $self->{messages} ) {
336 0           return @{ $self->{messages} };
  0            
337             }
338 0           return;
339             }
340              
341             sub polyline {
342 0     0 1   my ($self) = @_;
343              
344 0 0         if ( $self->{polyline} ) {
345 0           return @{ $self->{polyline} };
  0            
346             }
347 0           return;
348             }
349              
350             sub route {
351 0     0 1   my ($self) = @_;
352              
353 0 0         if ( $self->{route} ) {
354 0 0 0       if ( $self->{route}[0] and $self->{route}[0]{extra} ) {
355             $self->{route}
356 0           = [ map { Travel::Status::DE::HAFAS::Stop->new( %{$_} ) }
  0            
357 0           @{ $self->{route} } ];
  0            
358             }
359 0           return @{ $self->{route} };
  0            
360             }
361 0           return;
362             }
363              
364             sub route_interesting {
365 0     0 1   my ( $self, $max_parts ) = @_;
366              
367 0           my @via = $self->route;
368 0           my ( @via_main, @via_show, $last_stop );
369 0   0       $max_parts //= 3;
370              
371             # Centraal: dutch main station (Hbf in .nl)
372             # HB: swiss main station (Hbf in .ch)
373             # hl.n.: czech main station (Hbf in .cz)
374 0           for my $stop (@via) {
375 0 0         if ( $stop->{name}
376             =~ m{ HB $ | hl\.n\. $ | Hbf | Hauptbahnhof | Bf | Bahnhof | Centraal | Flughafen }x
377             )
378             {
379 0           push( @via_main, $stop );
380             }
381             }
382 0           $last_stop = pop(@via);
383              
384 0 0 0       if ( @via_main and $via_main[-1]{name} eq $last_stop->{name} ) {
385 0           pop(@via_main);
386             }
387 0 0 0       if ( @via and $via[-1]{name} eq $last_stop->{name} ) {
388 0           pop(@via);
389             }
390              
391 0 0 0       if ( @via_main and @via and $via[0]{name} eq $via_main[0]{name} ) {
      0        
392 0           shift(@via_main);
393             }
394              
395 0 0         if ( @via < $max_parts ) {
396 0           @via_show = @via;
397             }
398             else {
399 0 0         if ( @via_main >= $max_parts ) {
400 0           @via_show = ( $via[0] );
401             }
402             else {
403 0           @via_show = splice( @via, 0, $max_parts - @via_main );
404             }
405              
406 0   0       while ( @via_show < $max_parts and @via_main ) {
407 0           my $stop = shift(@via_main);
408 0 0 0 0     if ( any { $_->{name} eq $stop->{name} } @via_show
  0            
409             or $stop->{name} eq $last_stop->{name} )
410             {
411 0           next;
412             }
413 0           push( @via_show, $stop );
414             }
415             }
416              
417 0           for my $stop (@via_show) {
418 0           $stop->{name} =~ s{ \s? Hbf .* }{}x;
419             }
420              
421 0           return @via_show;
422              
423             }
424              
425             sub TO_JSON {
426 0     0 0   my ($self) = @_;
427              
428 0           my $ret = { %{$self} };
  0            
429              
430 0           for my $k ( keys %{$ret} ) {
  0            
431 0 0         if ( ref( $ret->{$k} ) eq 'DateTime' ) {
432 0           $ret->{$k} = $ret->{$k}->epoch;
433             }
434             }
435 0           $ret->{route} = [ map { $_->TO_JSON } $self->route ];
  0            
436              
437 0           return $ret;
438             }
439              
440             # }}}
441              
442             1;
443              
444             __END__
445              
446             =head1 NAME
447              
448             Travel::Status::DE::HAFAS::Journey - Information about a single
449             journey received by Travel::Status::DE::HAFAS
450              
451             =head1 SYNOPSIS
452              
453             for my $departure ($status->results) {
454             printf(
455             "At %s: %s to %s from platform %s\n",
456             $departure->datetime->strftime('%H:%M'),
457             $departure->line,
458             $departure->destination,
459             $departure->platform,
460             );
461             }
462              
463             # or (depending on module setup)
464             for my $arrival ($status->results) {
465             printf(
466             "At %s: %s from %s on platform %s\n",
467             $arrival->datetime->strftime('%H:%M'),
468             $arrival->line,
469             $arrival->origin,
470             $arrival->platform,
471             );
472             }
473              
474             =head1 VERSION
475              
476             version 4.17
477              
478             =head1 DESCRIPTION
479              
480             Travel::Status::DE::HAFAS::Journey describes a single journey. It is either
481             a station-specific arrival/departure obtained by a stationboard query, or a
482             train journey that does not belong to a specific station.
483              
484             stationboard-specific accessors are annotated with "(station only)" and return
485             undef for non-station journeys.
486              
487             =head1 METHODS
488              
489             =head2 ACCESSORS
490              
491             =over
492              
493             =item $journey->name
494              
495             Returns the journey or line name, either in a format like "Bus SB16" (Bus line
496             SB16) or "RE 10111" (RegionalExpress train 10111, no line information). May
497             contain extraneous whitespace characters.
498              
499             =item $journey->type
500              
501             Returns the type of this journey, e.g. "S" for S-Bahn, "RE" for Regional Express
502             or "STR" for tram / StraE<szlig>enbahn.
503              
504             =item $journey->type_long
505              
506             Returns the long type of this journey, e.g. "S-Bahn" or "Regional-Express".
507              
508             =item $journey->class
509              
510             Returns an integer identifying the the mode of transport class.
511             Semantics depend on backend, e.g. "1" and "2" for long-distance trains and
512             "4" and "8" for regional trains.
513              
514             =item $journey->line
515              
516             Returns the journey or line name, either in a format like "Bus SB16" (Bus line
517             SB16), "RE 42" (RegionalExpress train 42) or "IC 2901" (InterCity train 2901,
518             no line information). May contain extraneous whitespace characters. Note that
519             this accessor does not return line informatikn for IC/ICE/EC services, even if
520             it is available. Use B<line_no> for those.
521              
522             =item $journey->line_no
523              
524             Returns the line identifier, or undef if it is unknown.
525             The line identifier may be a single number such as "11" (underground train
526             line U 11), a single word (e.g. "AIR") or a combination (e.g. "SB16").
527             May also provide line numbers of IC/ICE services.
528              
529             =item $journey->number
530              
531             Returns the journey number (e.g. train number), or undef if it is unknown.
532              
533             =item $journey->id
534              
535             Returns tha HAFAS-internal journey ID.
536              
537             =item $journey->rt_datetime (station only)
538              
539             DateTime object indicating the actual arrival/departure date and time.
540             undef if no real-time data is available.
541              
542             =item $journey->sched_datetime (station only)
543              
544             DateTime object indicating the scheduled arrival/departure date and time.
545             undef if no schedule data is available.
546              
547             =item $journey->datetime (station only)
548              
549             DateTime object indicating the arrival/departure date and time.
550             Real-time data if available, schedule data otherwise.
551             undef if neither is available.
552              
553             =item $journey->delay (station only)
554              
555             Returns the delay in minutes, or undef if it is unknown.
556             Also returns undef if the arrival/departure has been cancelled.
557              
558             =item $journey->is_cancelled
559              
560             True if the journey was cancelled, false otherwise.
561              
562             =item $journey->is_partially_cancelled
563              
564             True if part of the journey was cancelled, false otherwise.
565              
566             =item $journey->rt_platform (station only)
567              
568             Actual arrival/departure platform.
569             undef if no real-time data is available.
570              
571             =item $journey->sched_platform (station only)
572              
573             Scheduled arrival/departure platform.
574             undef if no scheduled platform is available.
575              
576             =item $journey->platform (station only)
577              
578             Arrival/Departure platform. Real-time data if available, schedule data
579             otherwise. May be undef.
580              
581             =item $journey->is_changed_platform (station only)
582              
583             True if the real-time platform is known and it is not the scheduled one.
584              
585             =item $journey->load (station only)
586              
587             Expected passenger load (i.e., how full the vehicle is) at the requested stop.
588             If known, returns a hashref that maps classes (typically FIRST/SECOND) to
589             load estimation numbers. The DB backend uses 1 (low to medium), 2 (high),
590             3 (very high), and 4 (exceptionally high, train is booked out).
591             Undef if unknown.
592              
593             =item $journey->messages
594              
595             Returns a list of message strings related to this journey. Messages usually are
596             service notices (e.g. "missing carriage") or detailed delay reasons
597             (e.g. "switch damage between X and Y, expect delays").
598              
599             =item $journey->operator
600              
601             Returns the operator responsible for this journey. Returns undef
602             if the backend does not provide an operator.
603              
604             =item $journey->station (station only)
605              
606             Name of the station at which this journey was requested.
607              
608             =item $journey->station_eva (station only)
609              
610             UIC/EVA ID of the station at which this journey was requested.
611              
612             =item $journey->route
613              
614             Returns a list of Travel::Status::DE::HAFAS::Stop(3pm) objects that describe
615             individual stops along the journey. In stationboard mode, the list only
616             contains arrivals prior to the requested station or departures after the
617             requested station. In journey mode, it contains the entire route.
618              
619             =item $journey->route_interesting([I<count>])
620              
621             Return up to I<count> (default: B<3>) parts of C<< $journey->route >> that may
622             be particularly helpful, e.g. main stations or airports.
623             Returns a list of hashes, see above for the layout.
624              
625             =item $journey->route_end
626              
627             Name of the last route station. In arrival mode, this is where the train
628             started; in all other cases, it is the terminus.
629              
630             =item $journey->destination
631              
632             Alias for route_end; only set when requesting departures in station mode.
633              
634             =item $journey->origin
635              
636             Alias for route_end; only set when requesting arrivals in station mode.
637              
638             =item $journey->direction
639              
640             Train direction; this is typically the text printed on the train itself.
641             May be different from destination / route_end and may change along the route,
642             see above.
643              
644             =item $journey->polyline (journey only)
645              
646             List of geocoordinates that describe the train's route. Each list entry is
647             a hash with the following keys.
648              
649             =over
650              
651             =item * lon (longitude)
652              
653             =item * lat (latitude)
654              
655             =item * name (name of stop at this location, if any. undef otherwise)
656              
657             =item * eva (EVA ID of stop at this location, if any. undef otherwise)
658              
659             =back
660              
661             Note that stop locations in B<polyline> may differ from the coordinates
662             returned in B<route>. This is a backend issue; Travel::Status::DE::HAFAS
663             simply passes the returned coordinates on.
664              
665             =back
666              
667             =head1 DIAGNOSTICS
668              
669             None.
670              
671             =head1 DEPENDENCIES
672              
673             =over
674              
675             =item Class::Accessor(3pm)
676              
677             =back
678              
679             =head1 BUGS AND LIMITATIONS
680              
681             None known.
682              
683             =head1 SEE ALSO
684              
685             Travel::Status::DE::HAFAS(3pm).
686              
687             =head1 AUTHOR
688              
689             Copyright (C) 2015-2022 by Birte Kristina Friesel E<lt>derf@finalrewind.orgE<gt>
690              
691             =head1 LICENSE
692              
693             This module is licensed under the same terms as Perl itself.