File Coverage

lib/DateTime/Format/Intl.pm
Criterion Covered Total %
statement 1065 1420 75.0
branch 385 728 52.8
condition 365 845 43.2
subroutine 112 157 71.3
pod 17 18 94.4
total 1944 3168 61.3


line stmt bran cond sub pod time code
1             ##----------------------------------------------------------------------------
2             ## DateTime Format Intl - ~/lib/DateTime/Format/Intl.pm
3             ## Version v0.1.8
4             ## Copyright(c) 2025 DEGUEST Pte. Ltd.
5             ## Author: Jacques Deguest <jack@deguest.jp>
6             ## Created 2024/09/16
7             ## Modified 2025/01/05
8             ## All rights reserved
9             ##
10             ##
11             ## This program is free software; you can redistribute it and/or modify it
12             ## under the same terms as Perl itself.
13             ##----------------------------------------------------------------------------
14             package DateTime::Format::Intl;
15             BEGIN
16             {
17 11     11   4700571 use v5.10.1;
  11         46  
18 11     11   59 use strict;
  11         19  
  11         341  
19 11     11   56 use warnings;
  11         29  
  11         704  
20 11     11   57 use warnings::register;
  11         33  
  11         991  
21 11         1136 use vars qw(
22             $VERSION $DEBUG $ERROR $FATAL_EXCEPTIONS
23             $CACHE $LAST_CACHE_CLEAR $MAX_CACHE_SIZE $BROWSER_DEFAULTS
24 11     11   68 );
  11         19  
25 11     11   10731 use DateTime;
  11         3559746  
  11         511  
26 11     11   14421 use DateTime::Locale::FromCLDR;
  11         1600187  
  11         557  
27 11     11   9801 use DateTime::Format::Unicode;
  11         168702  
  11         662  
28 11     11   8974 use Locale::Intl;
  11         105413  
  11         492  
29 11     11   94 use Locale::Unicode::Data;
  11         23  
  11         252  
30 11     11   53 use Scalar::Util ();
  11         20  
  11         178  
31 11     11   6507 use Want;
  11         24126  
  11         1242  
32 11     11   36 our $VERSION = 'v0.1.8';
33 11         29 our $CACHE = {};
34 11         80 our $LAST_CACHE_CLEAR = time();
35 11         391 our $MAX_CACHE_SIZE = 30;
36             };
37              
38 11     11   75 use strict;
  11         25  
  11         301  
39 11     11   111 use warnings;
  11         25  
  11         75255  
40              
41             sub new
42             {
43 437     437 1 5336613 my $that = shift( @_ );
44 437   33     3166 my $self = bless( {} => ( ref( $that ) || $that ) );
45 437         973 my $this = shift( @_ );
46 437         2130 my $opts = $self->_get_args_as_hash( @_ );
47 437         2958 $opts = {%$opts};
48 437 50       1988 $self->{debug} = delete( $opts->{debug} ) if( exists( $opts->{debug} ) );
49 437   33     3807 $self->{fatal} = ( delete( $opts->{fatal} ) // $FATAL_EXCEPTIONS // 0 );
      50        
50 437 50 33     2532 return( $self->error( "No locale was provided." ) ) if( !defined( $this ) || !length( $this ) );
51 437   50     3241 my $cldr = $self->{_cldr} = Locale::Unicode::Data->new ||
52             return( $self->pass_error( Locale::Unicode::Data->error ) );
53 437 100 100     176782 my $test_locales = ( Scalar::Util::reftype( $this ) // '' ) eq 'ARRAY' ? $this : [$this];
54 437         1024 my $locale;
55             # Test for the locale data availability
56 437         1419 LOCALE_AVAILABILITY: foreach my $loc ( @$test_locales )
57             {
58 437   50     2169 my $tree = $cldr->make_inheritance_tree( $loc ) ||
59             return( $self->pass_error( $cldr->error ) );
60             # We remove the last 'und' special fallback locale
61 437         5955486 pop( @$tree );
62 437         1579 foreach my $l ( @$tree )
63             {
64 437         2473 my $ref = $cldr->calendar_formats_l10n(
65             locale => $l,
66             calendar => 'gregorian',
67             );
68 437 50 33     313514 return( $self->pass_error( $cldr->error ) ) if( !defined( $ref ) && $cldr->error );
69 437 50       1647 if( $ref )
70             {
71 437 50 33     1956 if( Scalar::Util::blessed( $loc ) && ref( $loc ) eq 'Locale::Intl' )
72             {
73 0         0 $locale = $loc;
74             }
75             else
76             {
77 437   50     3792 $locale = Locale::Intl->new( $loc ) ||
78             return( $self->pass_error( Locale::Intl->error ) );
79             }
80 437         361893 last LOCALE_AVAILABILITY;
81             }
82             }
83             }
84             # Choice of locales provided do not have a supported match, so we fall back to the default 'en'
85 437 50       1934 $locale = Locale::Intl->new( 'en' ) if( !defined( $locale ) );
86 437   50     4191 my $unicode = $self->{_unicode} = DateTime::Locale::FromCLDR->new( $locale ) ||
87             return( $self->pass_error( DateTime::Locale::FromCLDR->error ) );
88 437         2907719 $self->{locale} = $locale;
89              
90 437         3108 my @component_options = qw( weekday era year month day dayPeriod hour minute second fractionalSecondDigits timeZoneName timeStyle dateStyle );
91 437         1347 my @core_options = grep{ exists( $opts->{ $_ } ) } @component_options;
  5681         10241  
92 437         1045 my $check = {};
93 437         2781 @$check{ @core_options } = (1) x scalar( @core_options );
94              
95             # Default values if no options was provided.
96 437 100       2038 if( !scalar( keys( %$check ) ) )
97             {
98             # The Mozilla documentation states that "The default value for each date-time component option is undefined, but if all component properties are undefined, then year, month, and day default to "numeric"."
99             # However, in reality, this is more nuanced.
100 7   50     47 my $defaults = $self->_get_default_options_for_locale ||
101             return( $self->pass_error );
102 7         30 @core_options = qw( day month year );
103 7         38 @$opts{ @core_options } = @$defaults{ @core_options };
104 7         37 undef( $defaults );
105             }
106             else
107             {
108             # RangeError: invalid value "plop" for option month
109 430         17468 my %valid_options =
110             (
111             localeMatcher => ['lookup', 'best fit'],
112             # calendar is processed separately
113             # numberingSystem is processed separately
114             calendar => qr/[a-zA-Z][a-zA-Z0-9]+(?:\-[a-zA-Z][a-zA-Z0-9]+)*/,
115             numberingSystem => qr/[a-zA-Z][a-zA-Z0-9]+/,
116             timeZone => qr/[a-zA-Z0-9\/\_\-\+]+/,
117             year => [qw( numeric 2-digit )],
118             month => [qw( numeric 2-digit long short narrow )],
119             day => [qw( numeric 2-digit )],
120             hour => [qw( numeric 2-digit )],
121             minute => [qw( numeric 2-digit )],
122             second => [qw( numeric 2-digit )],
123             hour12 => [qw( 1 0 ), undef],
124             # short: 12/20/2012, GMT+9
125             # 12/19/2012, PST
126             # long: 12/20/2012, Japan Standard Time
127             # 12/19/2012, Pacific Standard Time
128             # shortOffset: 12/20/2012, GMT+9
129             # 12/19/2012, GMT-8
130             # longOffset: 12/20/2012, GMT+09:00
131             # 12/19/2012, GMT-08:00
132             # shortGeneric: 12/20/2012, Japan Time
133             # 12/19/2012, PT
134             # longGeneric: 12/20/2012, Japan Standard Time
135             # 12/19/2012, Pacific Time
136             timeZoneName => [qw( short long shortOffset longOffset shortGeneric longGeneric )],
137             era => [qw( narrow short long )],
138             weekday => [qw( narrow short long )],
139             hourCycle => [qw( h11 h12 h23 h24)],
140             # timeZone is processed separately
141             dayPeriod => [qw( narrow short long )],
142             fractionalSecondDigits => [0..3], # 0, 1, 2, or 3 digits
143             dateStyle => [qw( full long medium short )],
144             timeStyle => [qw( full long medium short )],
145             );
146            
147 430         2158 foreach my $key ( keys( %$opts ) )
148             {
149 1640 50       3941 unless( exists( $valid_options{ $key } ) )
150             {
151 0         0 return( $self->error({
152             type => 'RangeError',
153             message => "Invalid option \"${key}\"",
154             }) );
155             }
156 1640         3141 my $value = $opts->{ $key };
157 1640 100       4991 if( ref( $valid_options{ $key} ) eq 'ARRAY' )
    50          
158             {
159 1350 50 100     1909 if( !scalar( grep { ( $_ // '' ) eq ( $value // '' ) } @{$valid_options{ $key }} ) )
  4029   50     16216  
  1350         2680  
160             {
161 0 0       0 if( $key eq 'fractionalSecondDigits' )
162             {
163 0         0 return( $self->error({
164             type => 'RangeError',
165             message => "Invalid value \"${value}\" for option ${key}. Expected an integer between 0 and 3.",
166             }) );
167             }
168             else
169             {
170             return( $self->error({
171             type => 'RangeError',
172 0         0 message => "Invalid value \"${value}\" for option ${key}. Expected one of: " . @{$valid_options{ $key }},
  0         0  
173             }) );
174             }
175             }
176             }
177             elsif( ref( $valid_options{ $key} ) eq 'Regexp' )
178             {
179 290 50       4886 if( $value !~ /^$valid_options{ $key}$/ )
180             {
181 0         0 return( $self->error({
182             type => 'RangeError',
183             message => "Invalid value \"${value}\" for option ${key}.",
184             }) );
185             }
186             }
187             }
188             }
189              
190 437   100     3587 my $has_style = ( $opts->{dateStyle} || $opts->{timeStyle} );
191             # my $other_options = scalar( grep{ $opts->{ $_ } } grep{ !/^(date|time)Style$/ } @component_options );
192 437 50 33     1484 if( $has_style && (
      66        
193             $opts->{weekday} ||
194             $opts->{era} ||
195             $opts->{year} ||
196             $opts->{month} ||
197             $opts->{day} ||
198             $opts->{hour} ||
199             $opts->{minute} ||
200             $opts->{second} ||
201             $opts->{fractionalSecondDigits} ||
202             $opts->{timeZoneName}
203             ) )
204             {
205 0         0 return( $self->error( "You cannot specify any date-time option while using either dateStyle or timeStyle" ) );
206             }
207              
208 437         1440 my $resolved =
209             {
210             locale => $locale,
211             };
212 437         2218 @$resolved{ @core_options } = @$opts{ @core_options };
213 437         1060 my $calendar = $opts->{calendar};
214 437         1069 my $tz = $opts->{timeZone};
215 437         881 my $tzNameOpt = $opts->{timeZoneName};
216 437         936 my $date_style = $opts->{dateStyle};
217 437         853 my $time_style = $opts->{timeStyle};
218              
219 437         925 my $hc = $opts->{hourCycle};
220 437         917 my $h12 = $opts->{hour12};
221 437         780 my $pattern;
222              
223 437         846 my $num_sys = $opts->{numberingSystem};
224              
225 437 100       1273 if( !$calendar )
226             {
227 287 100       1757 if( $calendar = $locale->calendar )
228             {
229 3         403 $opts->{calendar} = $calendar;
230             }
231             else
232             {
233 284         52878 $opts->{calendar} = $calendar = 'gregorian';
234             }
235             }
236 437 100       1484 $calendar = 'gregorian' if( $calendar eq 'gregory' );
237 437 50 33     2949 if( lc( $calendar ) ne 'gregory' &&
238             lc( $calendar ) ne 'gregorian' )
239             {
240 0 0       0 warn( "The local provided has the calendar attribute set to \"${calendar}\", but this API only supports \"gregory\" or \"gregorian\"." ) if( warnings::enabled() );
241 0         0 $calendar = 'gregorian';
242             }
243 437         1301 $resolved->{calendar} = $calendar;
244              
245             # NOTE: timeStyle or hour is define, we do some check and processing for interdependency
246 437 100 100     3442 if( length( $time_style // '' ) || $opts->{hour} )
      100        
247             {
248             # Surprisingly, the 'hour12' option takes precedence over the 'hourCycle' even though the latter is more specific.
249             # I tried it in browser console:
250             # const date = new Date(Date.UTC(2012, 11, 20, 3, 0, 0));
251             # hour12: true, hour: "numeric", hourCycle: "h24"
252             # console.log( new Intl.DateTimeFormat('en-US', { hour12: true, hour: "numeric", hourCycle: "h24" }).resolvedOptions() );
253             # results in the following resolvedOptions:
254             # {
255             # calendar: "gregory",
256             # hour: "2-digit",
257             # hour12: false,
258             # hourCycle: "h23",
259             # locale: "en-US",
260             # numberingSystem: "latn",
261             # timeZone: "Asia/Tokyo
262             # }
263             # "When true, this option sets hourCycle to either "h11" or "h12", depending on the locale. When false, it sets hourCycle to "h23". hour12 overrides both the hc locale extension tag and the hourCycle option, should either or both of those be present." (Mozilla documentation)
264 159 100       938 if( defined( $h12 ) )
    100          
    50          
265             {
266             # There are 156 occurrences of 'H', and 115 occurrences of 'h', so we default to 'H'
267 54   50     386 my $pref_hour_cycle = $unicode->time_format_preferred || 'H';
268 54         575255 $resolved->{hour12} = $h12;
269             # Our implementation is more locale sensitive than the browsers' one where the browser would simply revert to h23 if h12 is false, and h12 if hour12 is true
270 54 50 33     700 $resolved->{hourCycle} = $h12
    50 33        
    100          
271             ? ( ( $pref_hour_cycle eq 'H' || $pref_hour_cycle eq 'K' ) ? 'h11' : 'h12' )
272             : ( ( $pref_hour_cycle eq 'h' || $pref_hour_cycle eq 'k' ) ? 'h24' : 'h23' );
273             }
274             # "The hour cycle to use. Possible values are "h11", "h12", "h23", and "h24". This option can also be set through the hc Unicode extension key; if both are provided, this options property takes precedence." (Mozilla documentation)
275             elsif( $hc )
276             {
277 48         174 $resolved->{hourCycle} = $hc;
278 48 100 66     407 $resolved->{hour12} = ( $hc eq 'h12' || $hc eq 'h11' ) ? 1 : 0;
279             }
280             elsif( $hc = $locale->hc )
281             {
282 0         0 $resolved->{hourCycle} = $hc;
283 0 0 0     0 $resolved->{hour12} = ( $hc eq 'h12' || $hc eq 'h11' ) ? 1 : 0;
284             }
285             else
286             {
287 57   50     6279 my $pref_hour_cycle = $unicode->time_format_preferred || 'H';
288 57 100       644723 if( $pref_hour_cycle eq 'h' )
    50          
    0          
    0          
289             {
290 55         233 $resolved->{hourCycle} = 'h12';
291 55         188 $resolved->{hour12} = 1;
292             }
293             elsif( $pref_hour_cycle eq 'H' )
294             {
295 2         9 $resolved->{hourCycle} = 'h23';
296 2         6 $resolved->{hour12} = 0;
297             }
298             # Although in the Unicode CLDR data for preferred time format, the 'k', or 'K' value is never used, we put it just in case in the future it might be.
299             elsif( $pref_hour_cycle eq 'k' )
300             {
301 0         0 $resolved->{hourCycle} = 'h24';
302 0         0 $resolved->{hour12} = 0;
303             }
304             elsif( $pref_hour_cycle eq 'K' )
305             {
306 0         0 $resolved->{hourCycle} = 'h11';
307 0         0 $resolved->{hour12} = 1;
308             }
309             }
310             # 2-digit is more specific than 'numeric', and if it is specified, we do not override it. However, if it is 'numeric', we may override it.
311 159 100 100     1330 if( $opts->{hour} && $opts->{hour} ne '2-digit' )
312             {
313 144 100 100     1026 $resolved->{hour} = ( $resolved->{hourCycle} eq 'h23' || $resolved->{hourCycle} eq 'h24' ) ? '2-digit' : 'numeric';
314             }
315             }
316              
317 437         3062 my $systems = $unicode->number_systems;
318 437         4149550 my $ns_default = $unicode->number_system;
319 437   50     4116003 my $ns_default_def = $cldr->number_system( number_system => $ns_default ) ||
320             return( $self->pass_error( $cldr->error ) );
321 437 50       168408 undef( $ns_default ) unless( $ns_default_def->{type} eq 'numeric' );
322             # NOTE: number system check
323 437 50       1673 if( $num_sys )
324             {
325 0         0 my $num_sys_def = $cldr->number_system( number_system => $num_sys );
326 0 0 0     0 return( $self->pass_error( $cldr->error ) ) if( !defined( $num_sys_def ) && $cldr->error );
327             # The proper behaviour is to ignore bad value and fall back to 'latn'
328 0 0       0 if( !$num_sys_def )
329             {
330 0 0       0 warn( "Warning only: invalid numbering system provided \"${num_sys}\"." ) if( warnings::enabled() );
331 0         0 undef( $num_sys );
332 0         0 $num_sys_def = {};
333             }
334             # 'latn' is always supported by all locale as per the LDML specifications
335             # We reject the specified if it is not among the locale's default, and if it is not 'numeric' (e.g. if it is algorithmic)
336 0 0 0     0 if( !( $num_sys eq 'latn' || scalar( grep( ( $systems->{ $_ } // '' ) eq $num_sys, qw( number_system native ) ) ) ) && $num_sys_def->{type} ne 'numeric' )
      0        
337             {
338 0 0       0 warn( "Warning only: unsupported numbering system provided \"${num_sys}\" for locale \"${locale}\"." ) if( warnings::enabled() );
339 0         0 undef( $num_sys );
340             }
341             }
342 437 100 66     4290 if( !defined( $num_sys ) && ( my $locale_num_sys = $locale->number ) )
343             {
344 3         361 my $num_sys_def = $cldr->number_system( number_system => $locale_num_sys );
345 3 50 33     1083 return( $self->pass_error( $cldr->error ) ) if( !defined( $num_sys_def ) && $cldr->error );
346 3   50     11 $num_sys_def ||= {};
347 3 50 100     52 if( $locale_num_sys eq 'latn' ||
      66        
      33        
348             (
349             scalar( grep( ( $systems->{ $_ } // '' ) eq $locale_num_sys, qw( number_system native ) ) ) &&
350             $num_sys_def->{type} ne 'numeric'
351             ) )
352             {
353 0         0 $num_sys = $locale_num_sys;
354             }
355             else
356             {
357 3 50       492 warn( "Warning only: unsupported numbering system provided (${locale_num_sys}) via the locale \"nu\" extension (${locale})." ) if( warnings::enabled() );
358             }
359             }
360             # Still have not found anything
361 437 50 50     50952 if( !length( $num_sys // '' ) )
362             {
363 437   50     2767 $num_sys //= $ns_default || 'latn';
      33        
364             }
365 437         1829 $resolved->{numberingSystem} = $num_sys;
366              
367             # NOTE: time zone check
368 437 100 100     3779 if( length( $tz // '' ) )
    100          
369             {
370 141   50     1015 my $actual = $cldr->timezone_canonical( $tz ) ||
371             return( $self->pass_error( $cldr->error ) );
372 141         164098 my $ref = $cldr->timezones( timezone => $actual );
373 141 50 33     3005407 return( $self->pass_error( $cldr->error ) ) if( !defined( $ref ) && $cldr->error );
374 141 50       147074 if( !$ref )
375             {
376 0         0 return( $self->error({
377             message => "Invalid time zone in " . ref( $self ) . ": ${tz}",
378             type => 'RangeError',
379             }) );
380             }
381             # elsif( lc( $tz ) ne lc( $actual ) )
382             # {
383             # $tz = $actual;
384             # }
385             }
386             elsif( my $bcp47_tz = $locale->timezone )
387             {
388 2         207 my $all = $cldr->timezones( tz_bcpid => $bcp47_tz );
389 2 50 33     1946 return( $self->pass_error( $cldr->error ) ) if( !defined( $all ) && $cldr->error );
390 2 50 50     22 if( $all &&
      33        
391             scalar( @$all ) &&
392             $all->[0]->{timezone} )
393             {
394 2         16 $tz = $all->[0]->{timezone};
395             }
396             else
397             {
398 0         0 warn( "No time zone could be found for the locale's time zone extension value '${bcp47_tz}'" );
399             }
400             }
401             # If we still have not a time zone defined, as a last resort
402 437 100 100     33235 if( !length( $tz // '' ) )
403             {
404             # Calling DateTime time_zone with 'local' might die if not found on the system, so we catch it with eval
405             my $dt = eval
406 294         666 {
407 294         3016 DateTime->now( time_zone => 'local' );
408             };
409 294 50       684126 if( $@ )
410             {
411 294         853 $tz = 'UTC';
412             }
413             else
414             {
415 0         0 $tz = $dt->time_zone->name;
416             }
417             }
418 437         3354 $resolved->{timeZone} = $tz;
419              
420             # NOTE: time zone name
421 437 100 100     3583 if( length( $tzNameOpt // '' ) )
422             {
423 44         176 $resolved->{timeZoneName} = $tzNameOpt;
424             }
425              
426             # NOTE: era
427             # long, short, narrow
428 437 100       2025 if( my $era = $opts->{era} )
429             {
430             # Only supported values are: long, short and narrow
431 93         474 my $width_map =
432             {
433             'abbreviated' => 'short',
434             'wide' => 'long',
435             };
436 93   50     656 my $tree = $cldr->make_inheritance_tree( $locale ) ||
437             return( $self->pass_error( $cldr->error ) );
438 93         792071 my $width;
439 93         313 my $supported = {};
440 93         317 LOCALE: foreach my $loc ( @$tree )
441             {
442 93         587 my $all = $cldr->calendar_eras_l10n(
443             locale => $loc,
444             calendar => $calendar,
445             );
446 93 50 33     65719 return( $self->pass_error( $cldr->error ) ) if( !defined( $all ) && $cldr->error );
447 93 50       449 if( $all )
448             {
449 93         316 foreach my $this ( @$all )
450             {
451 930   66     3081 $supported->{ ( $width_map->{ $this->{era_width} } // $this->{era_width} ) }++;
452             }
453              
454 93 50 0     376 if( exists( $supported->{ $era } ) )
    0          
455             {
456 93         226 $width = $era;
457             }
458             elsif( $era eq 'short' && exists( $supported->{abbreviated} ) )
459             {
460 0         0 $width = 'abbreviated';
461             }
462 93         1427 last LOCALE;
463             }
464             }
465 93 50       430 unless( defined( $width ) )
466             {
467             $width = exists( $supported->{long} )
468             ? 'long'
469             : exists( $supported->{short} )
470 0 0       0 ? 'short'
    0          
471             : undef;
472             }
473 93         572 $resolved->{era} = $width;
474             }
475              
476             # NOTE month, weekday check
477             my $values_to_check =
478             {
479             # CLDR data type => [option value, resolvedOption property]
480             month => [$opts->{month}, 'month'],
481 437         3620 day => [$opts->{weekday}, 'weekday'],
482             };
483 437         1959 foreach my $prop ( keys( %$values_to_check ) )
484             {
485             # long, short, narrow
486 874         2193 my $val = $values_to_check->{ $prop }->[0];
487 874 100 100     4559 next if( !length( $val // '' ) );
488             # This is already ok
489 373 100 66     3405 next if( $prop eq 'month' && ( $val eq '2-digit' || $val eq 'numeric' ) );
      100        
490             # Only supported values are: long, short and narrow
491 261         1363 my $width_map =
492             {
493             'abbreviated' => 'short',
494             'wide' => 'long',
495             };
496 261   50     2249 my $tree = $cldr->make_inheritance_tree( $locale ) ||
497             return( $self->pass_error( $cldr->error ) );
498 261         2328245 my $width;
499 261         880 my $supported = {};
500 261         813 LOCALE: foreach my $loc ( @$tree )
501             {
502 262         1752 my $all = $cldr->calendar_terms(
503             locale => $loc,
504             calendar => $calendar,
505             term_type => $prop,
506             term_context => 'format',
507             );
508 262 50 33     279418 return( $self->pass_error( $cldr->error ) ) if( !defined( $all ) && $cldr->error );
509 262 100 50     2208 if( $all && scalar( @$all ) )
510             {
511 261         898 foreach my $this ( @$all )
512             {
513 8477   66     23953 $supported->{ ( $width_map->{ $this->{term_width} } // $this->{term_width} ) }++;
514             }
515              
516 261 50 0     1105 if( exists( $supported->{ $val } ) )
    0          
517             {
518 261         635 $width = $val;
519             }
520             elsif( $val eq 'short' && exists( $supported->{abbreviated} ) )
521             {
522 0         0 $width = 'abbreviated';
523             }
524 261         12018 last LOCALE;
525             }
526             }
527 261 50       1134 unless( defined( $width ) )
528             {
529             $width = exists( $supported->{long} )
530             ? 'long'
531             : exists( $supported->{short} )
532 0 0       0 ? 'short'
    0          
533             : undef;
534             }
535 261         1963 $resolved->{ $values_to_check->{ $prop }->[1] } = $width;
536             }
537              
538             # NOTE: minute check; minute always end up being 2-digit, even if the user explicitly set it to numeric
539 437 100       2207 if( $opts->{minute} )
540             {
541 126         466 $resolved->{minute} = '2-digit';
542             }
543             # NOTE: second; same as minute
544 437 100       1626 if( $opts->{second} )
545             {
546 41         169 $resolved->{second} = '2-digit';
547             }
548 437         1594 $self->{resolvedOptions} = $resolved;
549              
550             # NOTE: Getting pattern
551 437         3970 my $cache_key = join( '|', map{ $_ . ';' . $resolved->{ $_ } } sort( keys( %$resolved ) ) );
  3335         50969  
552 437         3535 $pattern = $self->_get_cached_pattern( $locale, $cache_key );
553 437 100       2648 unless( $pattern )
554             {
555             # Now, get the most suitable pattern and cache it.
556 297         878 my $dateStyle = $resolved->{dateStyle};
557 297         595 my $timeStyle = $resolved->{timeStyle};
558 297         1884 my $mode2number =
559             {
560             full => 4,
561             medium => 3,
562             long => 2,
563             short => 1,
564             };
565             # NOTE: dateStyle or timeStyle was selected with a value of: full, medium, long, short
566 297 100 100     1484 if( $dateStyle || $timeStyle )
567             {
568 2         10 my @mode_keys = keys( %$mode2number );
569 2         4 my $number2mode = {};
570 2         21 @$number2mode{ @$mode2number{ @mode_keys } } = @mode_keys;
571 2         7 my( $date_pattern, $time_pattern );
572 2 100       10 if( $dateStyle )
573             {
574 1   50     12 my $code_date = $unicode->can( "date_format_${dateStyle}" ) ||
575             return( $self->error( "No method date_format_${dateStyle} found in ", ref( $unicode ) ) );
576 1         7 $date_pattern = $code_date->( $unicode );
577 1 50 33     18046 return( $self->pass_error( $unicode->error ) ) if( !defined( $date_pattern ) && $unicode->error );
578 1 50 50     6 return( $self->error( "date_format_${dateStyle}() in class ", ref( $unicode ), " returned an empty value." ) ) if( !length( $date_pattern // '' ) );
579             }
580 2 100       9 if( $timeStyle )
581             {
582 1   50     16 my $code_time = $unicode->can( "time_format_${timeStyle}" ) ||
583             return( $self->error( "No method time_format_${timeStyle} found in ", ref( $unicode ) ) );
584 1         8 $time_pattern = $code_time->( $unicode );
585 1 50 33     11281 return( $self->pass_error( $unicode->error ) ) if( !defined( $date_pattern ) && $unicode->error );
586 1 50 50     17 return( $self->error( "time_format_${timeStyle}() in class ", ref( $unicode ), " returned an empty value." ) ) if( !length( $time_pattern // '' ) );
587             }
588              
589 2 50 66     29 if( defined( $date_pattern ) && defined( $time_pattern ) )
590             {
591             # Define the combine mode as the most comprehensive mode of either date or time style specified
592 0         0 my $datetime_mode = $number2mode->{ _max( $mode2number->{ $dateStyle }, $mode2number->{ $timeStyle } ) };
593 0   0     0 my $code_datetime = $unicode->can( "datetime_format_${datetime_mode}" ) ||
594             return( $self->error( "No method datetime_format_${datetime_mode} found in ", ref( $unicode ) ) );
595 0         0 $pattern = $code_datetime->( $unicode );
596 0 0 0     0 return( $self->pass_error( $unicode->error ) ) if( !defined( $date_pattern ) && $unicode->error );
597 0 0 0     0 return( $self->error( "datetime_format_${datetime_mode}() in class ", ref( $unicode ), " returned an empty value." ) ) if( !length( $pattern // '' ) );
598 0         0 $pattern =~ s/\{1\}/$date_pattern/g;
599 0         0 $pattern =~ s/\{0\}/$time_pattern/g;
600             }
601             else
602             {
603 2   66     23 $pattern = ( $date_pattern // $time_pattern );
604             }
605             }
606             # NOTE: user has specified either no options or some options other than dateStyle and timeStyle
607             # We check the options provided
608             else
609             {
610             # If there is no option provided, the fallback is a short date
611 295         1376 my $patterns = $self->_get_available_format_patterns;
612             # NOTE: Calling _select_best_pattern
613 295   50     2260 my $score_object = $self->_select_best_pattern(
614             patterns => $patterns,
615             options => $resolved,
616             ) || return( $self->pass_error );
617 295         955 $pattern = $score_object->pattern_object->pattern;
618 295         778 my $skeleton = $score_object->pattern_object->skeleton;
619              
620 295         17347 $self->{_skeleton} = $skeleton;
621             }
622 297 50       2010 $self->_set_cached_pattern( $locale, $cache_key, $pattern ) unless( !defined( $pattern ) );
623             }
624 437         5196 $self->{_pattern} = $pattern;
625 437         12665 return( $self );
626             }
627              
628             sub error
629             {
630 0     0 1 0 my $self = shift( @_ );
631 0 0       0 if( @_ )
632             {
633 0         0 my $def = {};
634 0 0 0     0 if( @_ == 1 &&
      0        
      0        
635             defined( $_[0] ) &&
636             ref( $_[0] ) eq 'HASH' &&
637             exists( $_[0]->{message} ) )
638             {
639 0         0 $def = shift( @_ );
640             }
641             else
642             {
643 0 0       0 $def->{message} = join( '', map( ( ref( $_ ) eq 'CODE' ) ? $_->() : $_, @_ ) );
644             }
645 0 0       0 $def->{skip_frames} = 1 unless( exists( $def->{skip_frames} ) );
646 0         0 $self->{error} = $ERROR = DateTime::Format::Intl::Exception->new( $def );
647 0 0       0 if( $self->fatal )
648             {
649 0         0 die( $self->{error} );
650             }
651             else
652             {
653 0 0       0 warn( $def->{message} ) if( warnings::enabled() );
654 0 0       0 if( Want::want( 'ARRAY' ) )
    0          
655             {
656 0         0 rreturn( [] );
657             }
658             elsif( Want::want( 'OBJECT' ) )
659             {
660 0         0 rreturn( DateTime::Format::Intl::NullObject->new );
661             }
662 0         0 return;
663             }
664             }
665 0 0       0 return( ref( $self ) ? $self->{error} : $ERROR );
666             }
667              
668 0     0 1 0 sub fatal { return( shift->_set_get_prop( 'fatal', @_ ) ); }
669              
670             sub format
671             {
672 46     46 1 42708 my $self = shift( @_ );
673 46 50       252 return( $self->error( "format() must be called with an object, and not as a class function." ) ) if( !ref( $self ) );
674 46         126 my $this = shift( @_ );
675 46 50 33     495 if( !defined( $this ) || !length( $this // '' ) )
    50 33        
676             {
677 0         0 $this = DateTime->now;
678             }
679             elsif( !( Scalar::Util::blessed( $this ) && $this->isa( 'DateTime' ) ) )
680             {
681 0         0 return( $self->error({
682             type => 'RangeError',
683             message => "Date value provided is not a DateTime object."
684             }) );
685             }
686 46         3270 my $dt = $this->clone;
687 46         1199 my $opts = $self->resolvedOptions;
688 46         86 my $tz;
689 46 50       187 if( $opts->{timeZone} )
    0          
690             {
691 46         277 $dt->set_time_zone( $tz = $opts->{timeZone} );
692             }
693             elsif( $tz eq 'floating' )
694             {
695 0         0 $dt->set_time_zone( $tz = 'UTC' );
696             }
697             else
698             {
699 0         0 $tz = $dt->time_zone->name;
700             }
701 46   50     1030 my $cldr = $self->{_cldr} || die( "The Locale::Unicode::Data object is gone." );
702 46   50     229 my $unicode = $self->{_unicode} || die( "The DateTime::Locale::FromCLDR object is gone." );
703 46   50     397 my $locale = $self->{locale} || die( "Our Locale::Unicode object is gone!" );
704             # We share our DateTime::Locale::FromCLDR object with DateTime, because this module fares much better than the DateTime::Locale::FromData one
705 46         377 $dt->set_locale( $unicode );
706              
707             # This is built upon object instantiation, so that format(9 can be called multiple times and run more rapidly.
708             # my $pattern = $self->{_pattern} || die( "Saved pattern is gone!" );
709             # my $fmt = DateTime::Format::Unicode->new(
710             # locale => $locale,
711             # pattern => $pattern,
712             # time_zone => $tz,
713             # );
714             # my $str = $fmt->format_datetime( $dt );
715             # return( $self->error( "Error formatting CLDR pattern \"${pattern}\" for locale ${locale}: ", $fmt->error ) ) if( !defined( $str ) && $fmt->error );
716             # return( $str );
717              
718              
719 46   50     15188 my $parts = $self->format_to_parts( $this,
720             datetime => $dt,
721             ) || return( $self->pass_error );
722 46 50       164 if( !scalar( @$parts ) )
723             {
724 0         0 return( $self->error( "Error formatting datetime to parts. No data received!" ) );
725             }
726              
727 46         461 my $str = join( '', map( $_->{value}, @$parts ) );
728 46         748 return( $str );
729             }
730              
731             sub format_range
732             {
733 150     150 1 202233 my $self = shift( @_ );
734 150         456 my( $this1, $this2 ) = @_;
735 150 50 33     2510 if( !( Scalar::Util::blessed( $this1 ) && $this1->isa( 'DateTime' ) ) )
    50 33        
736             {
737 0         0 return( $self->error({
738             type => 'RangeError',
739             message => "Start datetime value provided is not a DateTime object."
740             }) );
741             }
742             elsif( !( Scalar::Util::blessed( $this2 ) && $this2->isa( 'DateTime' ) ) )
743             {
744 0         0 return( $self->error({
745             type => 'RangeError',
746             message => "End datetime value provided is not a DateTime object."
747             }) );
748             }
749 150         882 my $dt1 = $this1->clone;
750 150         2998 my $dt2 = $this2->clone;
751 150         2127 my $opts = $self->resolvedOptions;
752 150   50     637 my $cldr = $self->{_cldr} || die( "The Locale::Unicode::Data object is gone." );
753 150   50     1041 my $unicode = $self->{_unicode} || die( "The DateTime::Locale::FromCLDR object is gone." );
754 150   50     1486 my $locale = $self->{locale} || die( "Our Locale::Unicode object is gone!" );
755             # We share our DateTime::Locale::FromCLDR object with DateTime, because this module fares much better than the DateTime::Locale::FromData one
756 150         1428 $dt1->set_locale( $unicode );
757 150         49687 $dt2->set_locale( $unicode );
758             # Get the greatest difference between those two datetime
759             # Possible greatest diff: [qw( a B d G h H m M y )]
760 150 100       31368 my $diff = $unicode->interval_greatest_diff( $dt1, $dt2, ( $opts->{dayPeriod} ? ( day_period_first => 1 ) : () ) );
761 150 50 33     2852610 return( $self->pass_error( $unicode->error ) ) if( !defined( $diff ) && $unicode->error );
762             # If both dates are identical, we return the value from format() instead
763 150 50       623 if( !$diff )
764             {
765 0         0 return( $self->format( $this1 ) );
766             }
767 150   50     1022 my $parts = $self->format_range_to_parts( $this1, $this2,
768             diff => $diff,
769             datetime1 => $dt1,
770             datetime2 => $dt2,
771             ) || return( $self->pass_error );
772 150 50       533 if( !scalar( @$parts ) )
773             {
774 0         0 return( $self->error( "Error formatting datetime range to parts. No data received!" ) );
775             }
776              
777 150         2337 my $str = join( '', map( $_->{value}, @$parts ) );
778 150         3912 return( $str );
779             }
780              
781             sub format_range_to_parts
782             {
783 225     225 1 66300 my $self = shift( @_ );
784 225         756 my( $this1, $this2 ) = @_;
785 225 50 33     3415 if( !( Scalar::Util::blessed( $this1 ) && $this1->isa( 'DateTime' ) ) )
    50 33        
786             {
787 0         0 return( $self->error({
788             type => 'RangeError',
789             message => "Start datetime value provided is not a DateTime object."
790             }) );
791             }
792             elsif( !( Scalar::Util::blessed( $this2 ) && $this2->isa( 'DateTime' ) ) )
793             {
794 0         0 return( $self->error({
795             type => 'RangeError',
796             message => "End datetime value provided is not a DateTime object."
797             }) );
798             }
799 225         730 splice( @_, 0 , 2 );
800 225         1104 my $args = $self->_get_args_as_hash( @_ );
801 225         866 my $opts = $self->resolvedOptions;
802 225   50     1032 my $cldr = $self->{_cldr} || die( "The Locale::Unicode::Data object is gone." );
803 225   50     1328 my $unicode = $self->{_unicode} || die( "The DateTime::Locale::FromCLDR object is gone." );
804 225   50     4751 my $locale = $self->{locale} || die( "Our Locale::Unicode object is gone!" );
805 225         1548 my( $dt1, $dt2 );
806             # Save computational time; if it was provided (internally used), then let's use them.
807 225 100 66     893 if( $args->{datetime1} && $args->{datetime2} )
808             {
809 150         2121 $dt1 = $args->{datetime1};
810 150         279 $dt2 = $args->{datetime2};
811             }
812             else
813             {
814 75         523 $dt1 = $this1->clone;
815 75         1806 $dt2 = $this2->clone;
816             # We share our DateTime::Locale::FromCLDR object with DateTime, because this module fares much better than the DateTime::Locale::FromData one
817 75         1312 $dt1->set_locale( $unicode );
818 75         25258 $dt2->set_locale( $unicode );
819             }
820              
821             # Get the greatest difference between those two datetime
822             # Possible greatest diff: [qw( a B d G h H m M y )]
823 225         17056 my $diff;
824             # Save computational power, and share with us the already computed greatest difference
825 225 100 66     1263 if( exists( $args->{diff} ) && defined( $args->{diff} ) )
826             {
827 150         418 $diff = $args->{diff};
828             }
829             else
830             {
831 75 100       588 $diff = $unicode->interval_greatest_diff( $dt1, $dt2, ( $opts->{dayPeriod} ? ( day_period_first => 1 ) : () ) );
832 75 50 33     1693867 return( $self->pass_error( $unicode->error ) ) if( !defined( $diff ) && $unicode->error );
833             }
834             # If both dates are identical, we return the value from format() instead
835 225 50       804 if( !$diff )
836             {
837 0         0 return( $self->format_to_parts( $this1 ) );
838             }
839             # Adjust the greatest difference if it is 'h' or 'H' and we have the optionCycle set, meaning the user has selected some hour-related options
840 225 50 66     1667 if( ( $diff eq 'h' || $diff eq 'H' ) &&
      66        
      33        
841             exists( $opts->{hourCycle} ) &&
842             $opts->{hourCycle} )
843             {
844 39 100 66     357 my $should_be_diff = ( $opts->{hourCycle} eq 'h23' || $opts->{hourCycle} eq 'h24' ) ? 'H' : 'h';
845 39         104 $diff = $should_be_diff;
846             }
847             # NOTE: Getting patterns
848 225         2163 my $cache_key = "interval_${diff}_" . join( '|', map{ $_ . ';' . $opts->{ $_ } } sort( keys( %$opts ) ) );
  1683         9057  
849 225         1420 my $def = $self->_get_cached_pattern( $locale, $cache_key );
850 225 100       745 unless( $def )
851             {
852             # Hash reference of format_id to hash of properties
853 216         849 my $all = $self->_get_available_interval_patterns( $diff );
854 216 50 33     1313 if( !defined( $all ) || !scalar( keys( %$all ) ) )
855             {
856 0         0 return( $self->error( "No interval patterns found for locale \"${locale}\"." ) );
857             }
858 216         462 my $patterns = {};
859 216         2459 foreach my $skel ( sort( keys( %$all ) ) )
860             {
861 2667         5314 my $pat = $all->{ $skel }->{format_pattern};
862 2667 50 50     6101 if( !length( $pat // '' ) )
863             {
864 0 0       0 warn( "Empty pattern for skeleton '${skel}' for locale '${locale}' and greatest difference '${diff}'." ) if( warnings::enabled() );
865 0         0 next;
866             }
867 2667         4366 my $repeating_pattern = $all->{ $skel }->{repeating_field};
868 2667         4698 my $pos_start = index( $pat, $repeating_pattern );
869 2667 100       4382 if( $pos_start != -1 )
870             {
871 2553         5845 substr( $pat, $pos_start, length( $repeating_pattern ), '' );
872             }
873 2667         7060 $patterns->{ $skel } = $pat;
874             }
875              
876             # my $patterns = $unicode->available_format_patterns;
877 216   50     1741 my $score_object = $self->_select_best_pattern(
878             patterns => $patterns,
879             options => $opts,
880             diff => $diff,
881             ) || return( $self->pass_error );
882              
883 216         725 my $pattern = $score_object->pattern_object->pattern;
884 216         631 my $interval_skeleton = $score_object->pattern_object->skeleton;
885 216         621 my $has_missing_components = $score_object->has_missing;
886             # If the result has some missing components, well, we're screwed, because the LDML does not explain how to deal with it
887              
888 216         393 my $ref;
889             # "Once a best match is found between requested skeleton and dateFormatItem id, the corresponding dateFormatItem pattern is used, but with adjustments primarily to make the pattern field lengths match the skeleton field lengths."
890             # <https://www.unicode.org/reports/tr35/tr35-dates.html#Matching_Skeletons>
891             # No need to bother calling this method, if there is no need for adjustment
892 216 100       514 if( $score_object->need_adjustment )
893             {
894             # $ref has a structure like: [ $part1, $sep, $part2, $best ]
895 18   50     135 $ref = $cldr->split_interval(
896             greatest_diff => $diff,
897             pattern => $pattern,
898             ) || return( $self->pass_error( $cldr->error ) );
899             }
900             else
901             {
902 198         836 my $data = $all->{ $interval_skeleton };
903 198         1315 $ref = [@$data{qw( part1 separator part2 )}];
904             }
905              
906 216         9924 $def =
907             {
908             parts => $ref,
909             # Possibly adjusted pattern
910             pattern => $pattern,
911             skeleton => $interval_skeleton,
912             };
913 216         945 $self->_set_cached_pattern( $locale, $cache_key, $def );
914             }
915 225         18580 $self->{_interval_pattern} = $def->{pattern};
916 225         737 $self->{_interval_skeleton} = $def->{skeleton};
917 225         888 $self->{_greatest_diff} = $diff;
918 225         492 my $parts = [];
919              
920             my $parts1 = $self->_format_to_parts(
921 225   50     1183 pattern => $def->{parts}->[0],
922             datetime => $dt1,
923             ) || return( $self->pass_error );
924 225         969 for( @$parts1 )
925             {
926 1008         2214 $_->{source} = 'startRange';
927             }
928 225         815 push( @$parts, @$parts1 );
929             # Add the separator
930             push( @$parts, {
931             type => 'literal',
932 225         1632 value => $def->{parts}->[1],
933             source => 'shared',
934             });
935             my $parts2 = $self->_format_to_parts(
936 225   50     1234 pattern => $def->{parts}->[2],
937             datetime => $dt2,
938             ) || return( $self->pass_error );
939 225         1077 for( @$parts2 )
940             {
941 1239         2737 $_->{source} = 'endRange';
942             }
943 225         1116 push( @$parts, @$parts2 );
944 225         3190 return( $parts );
945             }
946              
947             sub format_to_parts
948             {
949 92     92 1 54377 my $self = shift( @_ );
950 92 50       372 return( $self->error( "format() must be called with an object, and not as a class function." ) ) if( !ref( $self ) );
951 92         179 my $this = shift( @_ );
952 92 50 33     873 if( !defined( $this ) || !length( $this // '' ) )
    50 33        
953             {
954 0         0 $this = DateTime->now;
955             }
956             elsif( !( Scalar::Util::blessed( $this ) && $this->isa( 'DateTime' ) ) )
957             {
958 0         0 return( $self->error({
959             type => 'RangeError',
960             message => "Date value provided is not a DateTime object."
961             }) );
962             }
963 92         5503 my $args = {};
964 92 50 0     901 $args = $self->_get_args_as_hash( @_ ) if( ( scalar( @_ ) == 1 && ref( $_[0] // '' ) eq 'HASH' ) || !( @_ % 2 ) );
      33        
      33        
965 92         329 my $opts = $self->resolvedOptions;
966 92   50     440 my $unicode = $self->{_unicode} || die( "The DateTime::Locale::FromCLDR object is gone." );
967             # This is built upon object instantiation, so that format(9 can be called multiple times and run more rapidly.
968 92   50     742 my $pattern = $self->{_pattern} || die( "Saved pattern is gone!" );
969 92         171 my $dt;
970             # Save computational time; if it was provided (internally used), then let's use them.
971 92 100       384 if( $args->{datetime} )
972             {
973 46         313 $dt = $args->{datetime};
974             }
975             else
976             {
977 46         178 $dt = $this->clone;
978             # We share our DateTime::Locale::FromCLDR object with DateTime, because this module fares much better than the DateTime::Locale::FromData one
979 46         1037 $dt->set_locale( $unicode );
980             }
981              
982 92         16745 my $tz;
983 92 50       310 if( $opts->{timeZone} )
    0          
984             {
985 92         422 $dt->set_time_zone( $tz = $opts->{timeZone} );
986             }
987             elsif( $tz eq 'floating' )
988             {
989 0         0 $dt->set_time_zone( $tz = 'UTC' );
990             }
991             else
992             {
993 0         0 $tz = $dt->time_zone->name;
994             }
995              
996 92   50     1798 my $parts = $self->_format_to_parts(
997             pattern => $pattern,
998             datetime => $dt,
999             ) || return( $self->pass_error );
1000 92         971 return( $parts );
1001             }
1002              
1003 0     0 1 0 sub formatRange { return( shift->format_range( @_ ) ); }
1004              
1005 0     0 1 0 sub formatRangeToParts { return( shift->format_range_to_parts( @_ ) ); }
1006              
1007 0     0 1 0 sub formatToParts { return( shift->format_to_parts( @_ ) ); }
1008              
1009 150     150 1 1051 sub greatest_diff { return( shift->{_greatest_diff} ); }
1010              
1011 150     150 1 2557 sub interval_pattern { return( shift->{_interval_pattern} ); }
1012              
1013 150     150 1 991 sub interval_skeleton { return( shift->{_interval_skeleton} ); }
1014              
1015             sub pass_error
1016             {
1017 0     0 0 0 my $self = shift( @_ );
1018 0   0     0 my $pack = ref( $self ) || $self;
1019 0         0 my $opts = {};
1020 0         0 my( $err, $class, $code );
1021 11     11   104 no strict 'refs';
  11         20  
  11         183976  
1022 0 0       0 if( scalar( @_ ) )
1023             {
1024             # Either an hash defining a new error and this will be passed along to error(); or
1025             # an hash with a single property: { class => 'Some::ExceptionClass' }
1026 0 0 0     0 if( scalar( @_ ) == 1 && ref( $_[0] ) eq 'HASH' )
1027             {
1028 0         0 $opts = $_[0];
1029             }
1030             else
1031             {
1032 0 0 0     0 if( scalar( @_ ) > 1 && ref( $_[-1] ) eq 'HASH' )
1033             {
1034 0         0 $opts = pop( @_ );
1035             }
1036 0         0 $err = $_[0];
1037             }
1038             }
1039 0 0 0     0 $err = $opts->{error} if( !defined( $err ) && CORE::exists( $opts->{error} ) && defined( $opts->{error} ) && CORE::length( $opts->{error} ) );
      0        
      0        
1040             # We set $class only if the hash provided is a one-element hash and not an error-defining hash
1041 0 0 0     0 $class = $opts->{class} if( CORE::exists( $opts->{class} ) && defined( $opts->{class} ) && CORE::length( $opts->{class} ) );
      0        
1042 0 0 0     0 $code = $opts->{code} if( CORE::exists( $opts->{code} ) && defined( $opts->{code} ) && CORE::length( $opts->{code} ) );
      0        
1043            
1044             # called with no argument, most likely from the same class to pass on an error
1045             # set up earlier by another method; or
1046             # with an hash containing just one argument class => 'Some::ExceptionClass'
1047 0 0 0     0 if( !defined( $err ) && ( !scalar( @_ ) || defined( $class ) ) )
    0 0        
      0        
      0        
      0        
1048             {
1049             # $error is a previous erro robject
1050 0 0       0 my $error = ref( $self ) ? $self->{error} : length( ${ $pack . '::ERROR' } ) ? ${ $pack . '::ERROR' } : undef;
  0 0       0  
  0         0  
1051 0 0       0 if( !defined( $error ) )
1052             {
1053 0         0 warn( "No error object provided and no previous error set either! It seems the previous method call returned a simple undef" );
1054             }
1055             else
1056             {
1057 0 0       0 $err = ( defined( $class ) ? bless( $error => $class ) : $error );
1058 0 0       0 $err->code( $code ) if( defined( $code ) );
1059             }
1060             }
1061             elsif( defined( $err ) &&
1062             Scalar::Util::blessed( $err ) &&
1063             ( scalar( @_ ) == 1 ||
1064             ( scalar( @_ ) == 2 && defined( $class ) )
1065             ) )
1066             {
1067 0 0       0 $self->{error} = ${ $pack . '::ERROR' } = ( defined( $class ) ? bless( $err => $class ) : $err );
  0         0  
1068 0 0 0     0 $self->{error}->code( $code ) if( defined( $code ) && $self->{error}->can( 'code' ) );
1069            
1070 0 0 0     0 if( $self->{fatal} || ( defined( ${"${class}\::FATAL_EXCEPTIONS"} ) && ${"${class}\::FATAL_EXCEPTIONS"} ) )
  0   0     0  
  0         0  
1071             {
1072 0         0 die( $self->{error} );
1073             }
1074             }
1075             # If the error provided is not an object, we call error to create one
1076             else
1077             {
1078 0         0 return( $self->error( @_ ) );
1079             }
1080            
1081 0 0       0 if( Want::want( 'OBJECT' ) )
1082             {
1083 0         0 rreturn( DateTime::Format::Intl::NullObject->new );
1084             }
1085 0         0 return;
1086             }
1087              
1088 65     65 1 66318 sub pattern { return( shift->{_pattern} ); }
1089              
1090 1109     1109 1 50661 sub resolvedOptions { return( shift->_set_get_prop( 'resolvedOptions', @_ ) ); }
1091              
1092 65     65 1 447 sub skeleton { return( shift->{_skeleton} ); }
1093              
1094             sub supportedLocalesOf
1095             {
1096 1     1 1 365303 my $self = shift( @_ );
1097 1         3 my $locales = shift( @_ );
1098 1         6 my $opts = $self->_get_args_as_hash( @_ );
1099 1         2 my $res = [];
1100 1 50 33     20 if( !defined( $locales ) || !length( $locales ) || ( ( Scalar::Util::reftype( $locales ) // '' ) eq 'ARRAY' && !scalar( @$locales ) ) )
      50        
      33        
      33        
1101             {
1102 0         0 return( $res );
1103             }
1104 1 50 50     5 $locales = ( Scalar::Util::reftype( $locales ) // '' ) eq 'ARRAY' ? $locales : [$locales];
1105 1   50     6 my $cldr = $self->_cldr || return( $self->pass_error );
1106 1         8 LOCALE: for( my $i = 0; $i < scalar( @$locales ); $i++ )
1107             {
1108 3   50     31 my $locale = Locale::Intl->new( $locales->[$i] ) ||
1109             return( $self->pass_error( Locale::Intl->error ) );
1110 3   50     17572 my $tree = $cldr->make_inheritance_tree( $locale->core ) ||
1111             return( $self->pass_error( $cldr->error ) );
1112             # Remove the last one, which is 'und', a.k.a 'root'
1113 3         94201 pop( @$tree );
1114 3         10 foreach my $loc ( @$tree )
1115             {
1116 3         14 my $ref = $cldr->locale( locale => $loc );
1117 3 50 33     1345 if( $ref && ref( $ref ) eq 'HASH' && scalar( keys( %$ref ) ) )
      50        
1118             {
1119 3         12 push( @$res, $loc );
1120 3         90 next LOCALE;
1121             }
1122             }
1123             }
1124 1         12 return( $res );
1125             }
1126              
1127             # Adjust pattern to match the specified format for each component:
1128             # "Once a best match is found between requested skeleton and dateFormatItem id, the corresponding dateFormatItem pattern is used, but with adjustments primarily to make the pattern field lengths match the skeleton field lengths."
1129             # <https://www.unicode.org/reports/tr35/tr35-dates.html#Matching_Skeletons>
1130             sub _adjust_pattern
1131             {
1132 81     81   203 my $self = shift( @_ );
1133 81         328 my $args = $self->_get_args_as_hash( @_ );
1134 81   50     419 my $pattern = $args->{pattern} || die( "No pattern was provided." );
1135 81   50     344 my $opts = $args->{options} || die( "No resolved options hash was provided." );
1136 81 50 33     667 if( ref( $pattern ) && !overload::Method( $pattern => '""' ) )
    50          
1137             {
1138 0         0 return( $self->error( "Pattern provided (", overload::StrVal( $pattern ), ") is a reference, but does not stringify." ) );
1139             }
1140             elsif( ref( $opts ) ne 'HASH' )
1141             {
1142 0   0     0 return( $self->error( "Resolved options provided (", overload::StrVal( $opts // 'undef' ), ") is not an hash reference." ) );
1143             }
1144 81   50     339 my $request_object = $args->{request_object} || die( "Missing the request object." );
1145             # Might not be provided.
1146 81         244 my $pattern_object = $args->{pattern_object};
1147 81 50 33     1678 if( !ref( $request_object ) || ( ref( $request_object ) && !$request_object->isa( 'DateTime::Format::Intl::Skeleton' ) ) )
    50 33        
      33        
      33        
1148             {
1149 0   0     0 return( $self->error( "The request object provided (", overload::StrVal( $request_object // 'undef' ), ") is not a DateTime::Format::Intl::Skeleton object." ) );
1150             }
1151             elsif( defined( $pattern_object ) &&
1152             ( !ref( $pattern_object ) || ( ref( $pattern_object ) && !$pattern_object->isa( 'DateTime::Format::Intl::Skeleton' ) ) ) )
1153             {
1154 0   0     0 return( $self->error( "The pattern object provided (", overload::StrVal( $pattern_object // 'undef' ), ") is not a DateTime::Format::Intl::Skeleton object." ) );
1155             }
1156 81   50     480 my $unicode = $self->{_unicode} || die( "The DateTime::Locale::FromCLDR object is gone." );
1157 81         703 my $component_precision = {};
1158 81         387 my $options_map = $self->_get_options_map;
1159              
1160             my $component_to_match =
1161             {
1162             # Those are not related to pattern, but because they are in our options we add them here to avoid an error, but discard them later
1163             calendar => undef,
1164             numberingSystem => undef,
1165             # This option is used as an ancillary value to hourCycle option
1166             hour12 => undef,
1167             # hourCycle itself is only present if the option 'hour' is set
1168             hourCycle => undef,
1169             locale => undef,
1170             timeZone => undef,
1171             era => sub
1172             {
1173 1     1   7 return( ['G' => 'G' x $options_map->{type_to_length}->{ $opts->{era} } ] );
1174             },
1175             year => 'y',
1176             # Possible values: numeric, 2-digit, long, short, narrow
1177             month => sub
1178             {
1179             # We respect the locale's choice for month display, whether it is 'L' or 'M'
1180             return({
1181             'L' => ( 'L' x $options_map->{month}->{ $opts->{month} } ),
1182 34     34   289 'M' => ( 'M' x $options_map->{month}->{ $opts->{month} } ),
1183             });
1184             },
1185             day => 'd',
1186             # Possible values are 'narrow', 'short' and 'long'
1187             dayPeriod => sub
1188             {
1189             return({
1190             'a' => ( 'a' x $options_map->{type_to_length}->{ $opts->{dayPeriod} } ),
1191             'b' => ( 'b' x $options_map->{type_to_length}->{ $opts->{dayPeriod} } ),
1192 0     0   0 'B' => ( 'B' x $options_map->{type_to_length}->{ $opts->{dayPeriod} } ),
1193             });
1194             },
1195             # For hours, whatever the pattern, be it 'h', 'H', 'k', or 'K', it is overriden by the user's explicit preference
1196             hour => sub
1197             {
1198 43 50 33 43   382 if( !exists( $opts->{hourCycle} ) || !defined( $opts->{hourCycle} ) )
1199             {
1200 0         0 my $pref = $unicode->time_format_preferred;
1201 0 0       0 if( $pref eq 'h' )
    0          
    0          
1202             {
1203 0         0 $opts->{hourCycle} = 'h11';
1204             }
1205             elsif( $pref eq 'H' )
1206             {
1207 0         0 $opts->{hourCycle} = 'h23';
1208             }
1209             elsif( $pref eq 'k' )
1210             {
1211 0         0 $opts->{hourCycle} = 'h23';
1212             }
1213             }
1214 43 50 66     429 if( $opts->{hourCycle} eq 'h11' )
    100 0        
    100 33        
    50          
1215             {
1216 0 0       0 return( [ [qw( h H k K )] => $opts->{hour} eq '2-digit' ? 'KK' : 'K' ] );
1217             }
1218             elsif( $opts->{hourCycle} eq 'h12' || $opts->{hour12} )
1219             {
1220 30 100       281 return( [ [qw( h H k K )] => $opts->{hour} eq '2-digit' ? 'hh' : 'h' ] );
1221             }
1222             elsif( $opts->{hourCycle} eq 'h23' )
1223             {
1224 1 50       7 return( [ [qw( h H k K )] => $opts->{hour} eq '2-digit' ? 'HH' : 'H' ] );
1225             }
1226             elsif( $opts->{hourCycle} eq 'h24' || ( exists( $opts->{hour12} ) && !$opts->{hour12} ) )
1227             {
1228 12 50       92 return( [ [qw( h H k K )] => $opts->{hour} eq '2-digit' ? 'kk' : 'k' ] );
1229             }
1230             },
1231             minute => 'm',
1232             # NOTE: also: "Finally: If the requested skeleton included both seconds and fractional seconds and the dateFormatItem skeleton included seconds but not fractional seconds, then the seconds field of the corresponding pattern should be adjusted by appending the locale’s decimal separator, followed by the sequence of ‘S’ characters from the requested skeleton."
1233             # <https://www.unicode.org/reports/tr35/tr35-dates.html#Matching_Skeletons>
1234             second => sub
1235             {
1236 12 50   12   96 my $seconds = ( $opts->{second} eq '2-digit' ? ( 's' x 2 ) : 's' );
1237 12 50 33     81 if( $opts->{second} && $opts->{fractionalSecondDigits} )
1238             {
1239 0         0 my @parts = split( /(?:'(?:(?:[^']|'')*)')/, $pattern );
1240 0 0       0 my $has_fractional_seconds = scalar( grep( /S/, @parts ) ) ? 1 : 0;
1241 0 0       0 if( $has_fractional_seconds )
1242             {
1243 0         0 return( [['s'] => $seconds] );
1244             }
1245             else
1246             {
1247 0   0     0 my $symbols = $unicode->number_symbols || die( $unicode->error );
1248 0   0     0 my $sep = $symbols->{decimal} || '.';
1249 0         0 return( [['s'] => $seconds . $sep . ( 'S' x $opts->{fractionalSecondDigits} )] );
1250             }
1251             }
1252             else
1253             {
1254 12         52 return( [['s'] => $seconds] );
1255             }
1256             },
1257             fractionalSecondDigits => sub
1258             {
1259             return(['S', sub
1260             {
1261 0         0 my( $token, $length ) = @_;
1262             # Remove fractional seconds if 0; we do not return undef; undef implies we leave the original string untouched
1263 0 0       0 return( '' ) if( $opts->{fractionalSecondDigits} == 0 );
1264 0         0 return( 'S' x $opts->{fractionalSecondDigits} );
1265 0     0   0 }]);
1266             },
1267             weekday => sub
1268             {
1269             return([ [qw( c e E )], sub
1270             {
1271 10         34 my( $token, $length ) = @_;
1272             # If the pattern component found is 'c' or 'e', and is less or equal to 2 characters, we leave it untouched, because it would translate into the week day number, and we deal only with the week day name, and we do not want to interfere with the locale's preferred pattern
1273 10 50 33     70 if( $token eq 'E' || ( ( $token eq 'c' || $token eq 'e' ) && $length >= 3 ) )
    0 33        
      66        
      0        
      0        
1274             {
1275 10         58 return( 'E' x $options_map->{type_to_length}->{ $opts->{weekday} } );
1276             }
1277             # The week day in word starts at 3 characters. Below that it is the week day as a number
1278             elsif( ( $token eq 'c' || $token eq 'e' ) && $length >= 3 )
1279             {
1280 0         0 return( $token x ( $options_map->{weekday}->{ $opts->{weekday} } + 2 ) );
1281             }
1282 0         0 return;
1283 12     12   112 }]);
1284             },
1285             # Like for hours, the user preference takes precedence over the pattern component found in the locale's pattern
1286             timeZoneName => sub
1287             {
1288 30     30   186 return( [ [qw( O v V z Z )] => $options_map->{timezone}->{ $opts->{timeZoneName} } ] );
1289             },
1290 81         3823 };
1291              
1292 81         831 foreach my $option ( sort( keys( %$opts ) ) )
1293             {
1294 624 50       1328 if( exists( $component_to_match->{ $option } ) )
1295             {
1296 624         980 my $val = $component_to_match->{ $option };
1297 624 100       1517 next if( !defined( $val ) );
1298 188 100       415 if( ref( $val ) )
1299             {
1300 132 50       373 if( ref( $val ) eq 'CODE' )
    0          
1301             {
1302 132         300 my $rv = $val->();
1303             # It returned an array reference.
1304             # The first part are the LDML pattern components applicable
1305             # The second part is how we deal with them when we find them: either we have a string, or a code reference to execute.
1306 132 100       458 if( ref( $rv ) eq 'ARRAY' )
    50          
1307             {
1308             # If the first element is an array, it is because there are multiple pattern components to catch
1309             # $rv->[1] can be a string, or a code for finer granularity
1310 98 100       297 if( ref( $rv->[0] ) eq 'ARRAY' )
    50          
1311             {
1312 97         163 foreach my $comp ( @{$rv->[0]} )
  97         337  
1313             {
1314 370         1070 $component_precision->{ $comp } = $rv->[1];
1315             }
1316             }
1317             # This should not be happening
1318             elsif( ref( $rv->[0] ) )
1319             {
1320 0         0 die( "The first array element returned for option \"${option}\" is a reference, and I do not know what to do with it: '", overload::StrVal( $rv->[0] ), "'" );
1321             }
1322             else
1323             {
1324 1         7 $component_precision->{ $rv->[0] } = $rv->[1];
1325             }
1326             }
1327             # It returns an hash reference of key-value pairs we add to the final hash
1328             elsif( ref( $rv ) eq 'HASH' )
1329             {
1330 34         170 my @keys = keys( %$rv );
1331             # Add the given hash keys to our option to pattern component hash reference
1332 34         248 @$component_precision{ @keys } = @$rv{ @keys };
1333             }
1334             else
1335             {
1336 0         0 die( "Unsupported value of type '" . ref( $rv ) . "' returned from code reference execution for option \"${option}\"." );
1337             }
1338             }
1339             elsif( ref( $val ) eq 'HASH' )
1340             {
1341 0         0 my @keys = keys( %$val );
1342             }
1343             else
1344             {
1345 0         0 die( "Unsupported value '", overload::StrVal( $val ), "' returned for option \"${option}\"." );
1346             }
1347             }
1348             else
1349             {
1350 56 100       316 $component_precision->{ $val } = ( $opts->{ $option } eq '2-digit' ? ( $val x 2 ) : $val );
1351             }
1352             }
1353             else
1354             {
1355 0         0 die( "Missing the option \"${option}\" in our configuration!" );
1356             }
1357             }
1358              
1359             # "When the pattern field corresponds to an availableFormats skeleton with a field length that matches the field length in the requested skeleton, the pattern field length should not be adjusted. This permits locale data to override a requested field length"
1360             # <https://www.unicode.org/reports/tr35/tr35-dates.html#Matching_Skeletons>
1361             # We need the following to perform this LDML check.
1362             # Character to length. For example: M => 3
1363 81         231 my $request_len = {};
1364 81         150 my $pattern_len = {};
1365 81         304 my $request_tokens = $request_object->tokens;
1366 81         251 foreach my $def ( @$request_tokens )
1367             {
1368 188         627 $request_len->{ $def->{component} } = $def->{len};
1369             }
1370 81 50       242 if( defined( $pattern_object ) )
1371             {
1372 81         222 my $pattern_tokens = $pattern_object->skeleton_tokens;
1373 81         3072 foreach my $def ( @$pattern_tokens )
1374             {
1375 185         563 $pattern_len->{ $def->{component} } = $def->{len};
1376             }
1377             }
1378             # TODO: An additional rule stipulates that:
1379             # "Pattern field lengths for hour, minute, and second should by default not be adjusted to match the requested field length (i.e. locale data takes priority)."
1380             # <https://www.unicode.org/reports/tr35/tr35-dates.html#Matching_Skeletons>
1381             # However, I am pondering whether to implement it or not.
1382              
1383 81         770 $pattern =~ s{
1384             \G
1385             (?:
1386             '((?:[^']|'')*)' # quote escaped bit of text
1387             # it needs to end with one
1388             # quote not followed by
1389             # another
1390             |
1391             (([a-zA-Z])\3*) # could be a pattern
1392             |
1393             (.) # anything else
1394             )
1395             }
1396             {
1397 368 100       1448 if( defined( $1 ) )
    100          
    50          
1398             {
1399 3         22 "'" . $1 . "'";
1400             }
1401             elsif( defined( $2 ) )
1402             {
1403 218         452 my $token = $2;
1404 218         517 my $component = $3;
1405 218 100       485 if( exists( $component_precision->{ $component } ) )
1406             {
1407             # either a string or a code reference
1408 188         409 my $this = $component_precision->{ $component };
1409             # "adjustments should never convert a numeric element in the pattern to an alphabetic element, or the opposite."
1410             # <https://www.unicode.org/reports/tr35/tr35-dates.html#Matching_Skeletons>
1411             # For example: skeleton 'yMMM' and pattern actually is 'y年M月'
1412             # This allows the locale to override
1413             # The above rule only materialise for the 'month' option, so we check for it here:
1414 188 50 100     2369 if( ( $component eq 'L' || $component eq 'M' ) &&
    100 100        
    100 66        
    50 33        
      100        
      100        
1415             length( $token ) <= 2 &&
1416             $opts->{month} ne 'numeric' &&
1417             $opts->{month} ne '2-digit' )
1418             {
1419 0         0 $token;
1420             }
1421             elsif( exists( $pattern_len->{ $component } ) &&
1422             exists( $request_len->{ $component } ) &&
1423             $pattern_len->{ $component } == $request_len->{ $component } )
1424             {
1425 40         201 $token;
1426             }
1427             elsif( ref( $this ) eq 'CODE' )
1428             {
1429 10         45 my $rv = $this->( $component, length( $token ) );
1430             # If the result is undefined, we leave the original untouched
1431 10 50       71 defined( $rv ) ? $rv : $token;
1432             }
1433             elsif( ref( $this ) )
1434             {
1435 0         0 die( "The value returned for token \"${token}\" is a reference, but I do not know what to do with it: '", overload::StrVal( $this ), "'" );
1436             }
1437             else
1438             {
1439 138         622 $this;
1440             }
1441             }
1442             # we leave it untouched
1443             else
1444             {
1445 30         108 $token;
1446             }
1447             }
1448             elsif( defined( $4 ) )
1449             {
1450 147         598 $4;
1451             }
1452             # Should not get here
1453             else
1454             {
1455 0         0 undef;
1456             }
1457             }sgex;
1458              
1459 81         4490 return( $pattern );
1460             }
1461              
1462             sub _append_components
1463             {
1464 3     3   7 my $self = shift( @_ );
1465 3         12 my $args = $self->_get_args_as_hash( @_ );
1466 3   50     16 my $pattern = $args->{pattern} || die( "No format pattern was provided." );
1467 3   50     13 my $missing = $args->{missing} || die( "No array reference of missing components was provided." );
1468             # Possible values: wide (Monday), abbreviated (Mon), short (Mo) and narrow (M)
1469             # my $width = $args->{width} || die( "No width value provided." );
1470 3 50 33     40 if( ref( $pattern ) && !overload::Method( $pattern => '""' ) )
    50          
1471             {
1472 0         0 die( "The pattern value provided (", overload::StrVal( $pattern ), ") is a reference (", ref( $pattern ), "), but it does not stringify." );
1473             }
1474             elsif( ref( $missing ) ne 'ARRAY' )
1475             {
1476 0         0 die( "The value provided for missing components (", overload::StrVal( $missing ), ") is not an array reference." );
1477             }
1478 3   50     20 my $cldr = $self->{_cldr} || die( "The Locale::Unicode::Data object is gone." );
1479 3   50     20 my $locale = $self->{locale} || die( "The locale value is gone!" );
1480 3   50     41 my $calendar = $self->{calendar} || 'gregorian';
1481 3         31 my $alias =
1482             {
1483             'c' => 'E',
1484             'e' => 'E',
1485             'H' => 'h',
1486             'k' => 'h',
1487             'K' => 'h',
1488             'L' => 'M',
1489             'v' => 'Z',
1490             };
1491 3   33     10 my $missing_hash = +{ map{ ( $alias->{ $_ } // $_ ) => $_ } @$missing };
  3         29  
1492              
1493             # my @ordered_options = qw( era year month weekday day dayPeriod hour minute second timeZoneName );
1494             # becomes:
1495 3         19 my @ordered_options = qw( G y M E d B h m s Z );
1496             # Possible components found in skeleton in CLDR data: [qw( B E G H M Q W Z c d h m s v w y )]
1497             # All possible format ID known in the CLDR calendar_append_formats table
1498 3         92 my $map =
1499             {
1500             # 'B' has no correspondence in table calendar_append_formats, but has in table date_terms
1501             'c' => ['Day-Of-Week' => 'weekday'],
1502             'd' => ['Day' => 'day'],
1503             'e' => ['Day-Of-Week' => 'weekday'],
1504             'E' => ['Day-Of-Week' => 'weekday'],
1505             'G' => ['Era' => 'era'],
1506             'h' => ['Hour' => 'hour'],
1507             'H' => ['Hour' => 'hour'],
1508             'k' => ['Hour' => 'hour'],
1509             'K' => ['Hour' => 'hour'],
1510             'L' => ['Month' => 'month'],
1511             'm' => ['Minute' => 'minute'],
1512             'M' => ['Month' => 'month'],
1513             # We put it here, but it is actually not used
1514             'Q' => ['Quarter' => 'quarter'],
1515             's' => ['Second' => 'second'],
1516             'v' => ['Timezone' => 'zone'],
1517             # We put it here, but it is actually not used
1518             'w' => ['Week' => 'week'],
1519             'W' => ['Week' => 'week'],
1520             'y' => ['Year' => 'year'],
1521             'Z' => ['Timezone' => 'zone'],
1522             };
1523 3   50     32 my $tree = $cldr->make_inheritance_tree( $locale ) ||
1524             return( $self->pass_error( $cldr->error ) );
1525             my $get_append_pattern = sub
1526             {
1527 3     3   52 my $elem = shift( @_ );
1528             # e.g.: {0} {1}
1529             # or: {0} ({2}: {1})
1530 3         7 my $pat;
1531 3         8 foreach my $loc ( @$tree )
1532             {
1533 3         18 my $ref = $cldr->calendar_append_format(
1534             format_id => $elem,
1535             locale => $loc,
1536             calendar => $calendar,
1537             );
1538 3 50 33     2030 return( $self->pass_error( $cldr->error ) ) if( !defined( $ref ) && $cldr->error );
1539 3 50       12 if( $ref )
1540             {
1541 3         11 $pat = $ref->{format_pattern};
1542 3         14 last;
1543             }
1544             }
1545 3   50     15 return( $pat // '' );
1546 3         31830 };
1547             # day
1548             # dayperiod
1549             # month
1550             # quarter
1551             my $get_term = sub
1552             {
1553 0     0   0 my $elem = shift( @_ );
1554 0         0 my $str;
1555 0         0 foreach my $loc ( @$tree )
1556             {
1557 0         0 my $ref = $cldr->date_term(
1558             locale => $loc,
1559             term_type => $elem,
1560             # Possible choices are 'standard' and 'narrow', but 'narrow' is relatively rare (11.70%).
1561             term_length => 'standard',
1562             );
1563 0 0 0     0 return( $self->pass_error( $cldr->error ) ) if( !defined( $ref ) && $cldr->error );
1564 0 0       0 if( $ref )
1565             {
1566 0         0 $str = $ref->{display_name};
1567 0         0 last;
1568             }
1569             }
1570 0   0     0 return( $str // '' );
1571 3         17 };
1572              
1573 3         9 local $" = ', ';
1574 3         11 foreach my $comp ( @ordered_options )
1575             {
1576 30 100       80 next unless( exists( $missing_hash->{ $comp } ) );
1577 3 50       13 if( !exists( $map->{ $comp } ) )
1578             {
1579 0         0 warn( "Unsupported component (${comp}) requested." );
1580             }
1581 3         7 my $def = $map->{ $comp };
1582 3         12 my $format = $get_append_pattern->( $def->[0] );
1583 3 50       15 if( !defined( $format ) )
    50          
1584             {
1585 0         0 return( $self->pass_error );
1586             }
1587             elsif( !length( $format ) )
1588             {
1589 0         0 return( $self->error( "Unable to find an append format pattern for component '${comp}' corresponding to append item '", $def->[0], "' for the locale tree @$tree" ) );
1590             }
1591 3         21 $format =~ s/\{0\}/$pattern/;
1592 3         23 $format =~ s/\{1\}/$missing_hash->{ $comp }/;
1593 3 50       15 if( index( $format, '{2}' ) != -1 )
1594             {
1595 0         0 my $term = $get_term->( $def->[1] );
1596 0 0       0 if( !defined( $term ) )
    0          
1597             {
1598 0         0 return( $self->pass_error );
1599             }
1600             elsif( !length( $term ) )
1601             {
1602 0         0 return( $self->error( "Unable to find a date term for element '", $def->[1], "' for the locale tree @$tree" ) );
1603             }
1604             # Since this is a litteral term, we need to surround it with single quote.
1605 0         0 $format =~ s/\{2\}/\'$term\'/;
1606             }
1607 3         21 $pattern = $format;
1608             }
1609 3         111 return( $pattern );
1610             }
1611              
1612             sub _cldr
1613             {
1614 552     552   1252 my $self = shift( @_ );
1615 552         1081 my $cldr;
1616 552 100       1505 if( ref( $self ) )
1617             {
1618             $cldr = $self->{_cldr} ||
1619 551   50     2056 return( $self->error( "The Locale::Unicode::Data object is gone!" ) );
1620             }
1621             else
1622             {
1623 1   50     17 $cldr = Locale::Unicode::Data->new ||
1624             return( $self->pass_error( Locale::Unicode::Data->error ) );
1625             }
1626 552         11603 return( $cldr );
1627             }
1628              
1629             sub _clear_cache
1630             {
1631 662     662   1306 my $self = shift( @_ );
1632 662         1405 my $current_time = time();
1633 662 50 33     5148 if( $current_time - $LAST_CACHE_CLEAR > 86400 || keys( %$CACHE ) > $MAX_CACHE_SIZE )
1634             {
1635 0         0 %$CACHE = ();
1636 0         0 $LAST_CACHE_CLEAR = $current_time;
1637             }
1638             }
1639              
1640             # Takes a pattern, break it down into pieces of information as an hash reference and return an array of those hash references
1641             sub _format_to_parts
1642             {
1643 542     542   1159 my $self = shift( @_ );
1644 542         1952 my $args = $self->_get_args_as_hash( @_ );
1645 542   50     2276 my $pat = $args->{pattern} || die( "No pattern was provided." );
1646 542   50     4194 my $dt = $args->{datetime} || die( "No DateTime object was provided." );
1647 542   50     15433 my $locale = $self->{locale} || die( "Our Locale::Unicode object is gone!" );
1648 542         5177 my $opts = $self->resolvedOptions;
1649 542 50       2554 unless( $opts->{numberingSystem} eq 'latn' )
1650             {
1651 0   0     0 my $clone = Locale::Intl->new( "$locale" ) ||
1652             return( $self->pass_error( Locale::Intl->error ) );
1653 0         0 $clone->number( $opts->{numberingSystem} );
1654 0         0 $locale = $clone;
1655             }
1656 542   50     4794 my $fmt = DateTime::Format::Unicode->new( locale => $locale, time_zone => $opts->{timeZone} ) ||
1657             return( $self->pass_error( DateTime::Format::Unicode->error ) );
1658 542   50     11075595 my $map = $fmt->_get_helper_methods ||
1659             return( $self->pass_error );
1660 542         44505 my $comp_map =
1661             {
1662             'a' => 'dayPeriod',
1663             # Non-standard
1664             'A' => 'millisecond',
1665             'b' => 'dayPeriod',
1666             'B' => 'dayPeriod',
1667             'c' => 'weekday',
1668             'C' => 'hour',
1669             'd' => 'day',
1670             # Non-standard
1671             'D' => 'dayOfYear',
1672             'e' => 'weekday',
1673             'E' => 'weekday',
1674             # Non-standard
1675             'F' => 'dayOfWeekMonth',
1676             'g' => 'day',
1677             'G' => 'era',
1678             'h' => 'hour',
1679             'H' => 'hour',
1680             'j' => 'hour',
1681             'J' => 'hour',
1682             'k' => 'hour',
1683             'K' => 'hour',
1684             'L' => 'month',
1685             'M' => 'month',
1686             'm' => 'minute',
1687             'O' => 'timeZoneName',
1688             'q' => 'quarter',
1689             'Q' => 'quarter',
1690             'r' => 'year',
1691             's' => 'second',
1692             'S' => 'secondFractional',
1693             'u' => 'year',
1694             # Non-standard
1695             'U' => 'cyclicYear',
1696             'v' => 'timeZoneName',
1697             'V' => 'timeZoneName',
1698             'w' => 'week',
1699             'W' => 'week',
1700             'x' => 'timeZoneName',
1701             'X' => 'timeZoneName',
1702             'y' => 'year',
1703             'Y' => 'year',
1704             'z' => 'timeZoneName',
1705             'Z' => 'timeZoneName',
1706             };
1707              
1708             my $unescape = sub
1709             {
1710 1216     1216   2497 my $str = shift( @_ );
1711 1216         2745 $str =~ s/\'\'/\'/g;
1712 1216         4641 return( $str );
1713 542         4008 };
1714              
1715             my $cldr_pattern = sub
1716             {
1717 1473     1473   3143 my $pattern = shift( @_ );
1718 1473         4119 my $component = substr( $pattern, 0, 1 );
1719 1473 50       4137 if( exists( $map->{ $component } ) )
1720             {
1721 1473 50       4148 die( "Unknown component '${component}' in our component to type map." ) if( !exists( $comp_map->{ $component } ) );
1722 1473         2597 my $code = $map->{ $component };
1723 1473         6637 my $str = $code->( $fmt, $component, length( $pattern ), $dt );
1724             return({
1725 1473   50     8915437 type => $comp_map->{ $component },
1726             value => ( $str // '' ),
1727             });
1728             }
1729             # Unknown, we return the pattern as-is
1730             else
1731             {
1732             return({
1733 0         0 type => 'literal',
1734             value => $unescape->( $pattern ),
1735             });
1736             }
1737 542         3387 };
1738              
1739 542         1419 my $parts = [];
1740             # try-catch
1741             eval
1742 542         1389 {
1743 542         5563 $pat =~ s{
1744             \G
1745             (?:
1746             '((?:[^']|'')*)' # quote escaped bit of text
1747             # it needs to end with one
1748             # quote not followed by
1749             # another
1750             |
1751             (([a-zA-Z])\3*) # could be a pattern
1752             |
1753             (.) # anything else
1754             )
1755             }
1756             {
1757 2689 50       11491 if( defined( $1 ) )
    100          
    50          
1758             {
1759 0         0 push( @$parts, { value => $unescape->( $1 ), type => 'literal' });
1760 0         0 $1;
1761             }
1762             elsif( defined( $2 ) )
1763             {
1764 1473         3759 push( @$parts, $cldr_pattern->( $2 ) );
1765 1473         10867 $2;
1766             }
1767             elsif( defined( $4 ) )
1768             {
1769 1216         3021 push( @$parts, { value => $unescape->( $4 ), type => 'literal' });
1770 1216         5096 $4;
1771             }
1772             else
1773             {
1774 0         0 undef;
1775             }
1776             }sgex;
1777             };
1778 542 50       2280 if( $@ )
1779             {
1780 0         0 return( $self->error( "Error formatting CLDR pattern for locale $locale: $@" ) );
1781             }
1782 542         29907 return( $parts );
1783             }
1784              
1785             sub _get_args_as_hash
1786             {
1787 24045     24045   34798 my $self = shift( @_ );
1788 24045         33819 my $ref = {};
1789 24045 100 66     103410 if( scalar( @_ ) == 1 &&
    50 50        
      66        
1790             defined( $_[0] ) &&
1791             ( ref( $_[0] ) || '' ) eq 'HASH' )
1792             {
1793 436         1432 $ref = shift( @_ );
1794             }
1795             elsif( !( scalar( @_ ) % 2 ) )
1796             {
1797 23609         81170 $ref = { @_ };
1798             }
1799             else
1800             {
1801 0         0 die( "Uneven number of parameters provided." );
1802             }
1803 24045         42370 return( $ref );
1804             }
1805              
1806             sub _get_available_format_patterns
1807             {
1808 295     295   733 my $self = shift( @_ );
1809 295   50     1207 my $cldr = $self->{_cldr} || die( "The Locale::Unicode::Data object is gone." );
1810 295   50     1205 my $locale = $self->{locale} || die( "The locale value is gone!" );
1811 295   50     2766 my $calendar = $self->{calendar} || 'gregorian';
1812             # "The dateFormatItems inherit from their parent locale, so the inherited items need to be considered when processing."
1813             # <https://www.unicode.org/reports/tr35/tr35-dates.html#Mapping_Requested_Time_Skeletons_To_Patterns>
1814 295   50     1398 my $tree = $cldr->make_inheritance_tree( $locale ) ||
1815             return( $self->pass_error( $cldr->error ) );
1816             # Keep track of the format skeleton already found, so we do not replace them while going up the tree
1817 295         2567668 my $patterns = {};
1818 295         1006 local $" = ', ';
1819 295         923 foreach my $loc ( @$tree )
1820             {
1821 598         3579 my $all = $cldr->calendar_available_formats(
1822             locale => $loc,
1823             calendar => $calendar,
1824             alt => undef,
1825             # count might contain some value
1826             );
1827 598 50 33     617759 return( $self->pass_error ) if( !defined( $all ) && $cldr->error );
1828 598 100 50     3351 if( $all && scalar( @$all ) )
1829             {
1830 591         1850 for( @$all )
1831             {
1832 31834 100       93048 next if( exists( $patterns->{ $_->{format_id} } ) );
1833 15653         42857 $patterns->{ $_->{format_id} } = $_->{format_pattern};
1834             }
1835             # We do not stop here even though we may have a match, because we want to collect all the possible pattern throughout the locale's tree.
1836             }
1837             }
1838 295         1639 return( $patterns );
1839             }
1840              
1841             sub _get_available_interval_patterns
1842             {
1843 216     216   467 my $self = shift( @_ );
1844 216   50     684 my $diff = shift( @_ ) || die( "No greatest difference component was provided." );
1845 216   50     787 my $cldr = $self->{_cldr} || die( "The Locale::Unicode::Data object is gone." );
1846 216   50     724 my $locale = $self->{locale} || die( "The locale value is gone!" );
1847 216   50     2006 my $calendar = $self->{calendar} || 'gregorian';
1848             # Get all the interval patterns for the given greatest difference
1849             # "The dateFormatItems inherit from their parent locale, so the inherited items need to be considered when processing."
1850             # <https://www.unicode.org/reports/tr35/tr35-dates.html#Mapping_Requested_Time_Skeletons_To_Patterns>
1851 216   50     1241 my $tree = $cldr->make_inheritance_tree( $locale ) ||
1852             return( $self->pass_error( $cldr->error ) );
1853 216         1893196 my $patterns = {};
1854 216         782 local $" = ', ';
1855 216         645 foreach my $loc ( @$tree )
1856             {
1857 432         2297 my $all = $cldr->calendar_interval_formats(
1858             locale => $loc,
1859             calendar => $calendar,
1860             greatest_diff_id => $diff,
1861             );
1862 432 50 50     332171 if( $all && scalar( @$all ) )
1863             {
1864 432         1256 for( @$all )
1865             {
1866 5334 100       16308 next if( exists( $patterns->{ $_->{format_id} } ) );
1867 2667         7224 $patterns->{ $_->{format_id} } = $_;
1868             }
1869             # We do not stop here even though we may have a match, because we want to collect all the possible pattern throughout the locale's tree.
1870             }
1871             }
1872 216         1182 return( $patterns );
1873             }
1874              
1875             sub _get_cached_pattern
1876             {
1877 662     662   1557 my $self = shift( @_ );
1878 662         1888 my( $locale, $key ) = @_;
1879 662         3507 $self->_clear_cache;
1880 662 100 66     2133 if( exists( $CACHE->{ $locale } ) &&
      100        
1881             ref( $CACHE->{ $locale } ) eq 'HASH' &&
1882             exists( $CACHE->{ $locale }->{ $key } ) )
1883             {
1884 149         4492 return( $CACHE->{ $locale }->{ $key } );
1885             }
1886 513         13299 return;
1887             }
1888              
1889             sub _get_datetime_format
1890             {
1891 20     20   43 my $self = shift( @_ );
1892 20         88 my $opts = $self->_get_args_as_hash( @_ );
1893 20   50     71 my $width = $opts->{width} || die( "No datetime format width was provided." );
1894 20   50     106 my $type = $opts->{type} || 'atTime';
1895 20 50 33     74 die( "Bad datetime format '${type}'" ) if( $type ne 'atTime' && $type ne 'standard' );
1896 20   50     109 my $cldr = $self->{_cldr} || die( "The Locale::Unicode::Data object is gone." );
1897 20   50     128 my $locale = $self->{locale} || die( "Our Locale::Unicode object is gone!" );
1898 20   50     421 my $locales = $cldr->make_inheritance_tree( $locale ) ||
1899             return( $self->pass_error( $cldr->error ) );
1900 20   50     196704 my $calendar = $self->{calendar} || 'gregorian';
1901 20         44 my $pattern;
1902 20         62 foreach my $loc ( @$locales )
1903             {
1904 20         148 my $ref = $cldr->calendar_datetime_format(
1905             locale => $loc,
1906             calendar => $calendar,
1907             format_type => $type,
1908             format_length => $width,
1909             );
1910 20 50 33     10466 return( $self->pass_error ) if( !defined( $ref ) && $cldr->error );
1911 20 50 33     151 if( $ref && $ref->{format_pattern} )
1912             {
1913 20         51 $pattern = $ref->{format_pattern};
1914 20         94 last;
1915             }
1916             }
1917 20   50     144 return( $pattern // '' );
1918             }
1919              
1920             sub _get_default_options_for_locale
1921             {
1922 7     7   17 my $self = shift( @_ );
1923             my $locale = shift( @_ ) || $self->{locale} ||
1924 7   50     104 return( $self->error( "No locale was provided to get default options." ) );
1925             # We want to know basically if the day, and month should be either numeric (i.e. 1 digit), or 2-digit
1926             # For this, we use the short date locale format and we check for d or d{2} and M and M{2} or L and L{2}
1927 7   50     86 my $cldr = $self->{_cldr} || die( "The Locale::Unicode::Data object is gone!" );
1928             # my $unicode = $self->{_unicode} || die( "The DateTime::Locale::FromCLDR object is gone!" );
1929 7   50     39 my $tree = $cldr->make_inheritance_tree( $locale ) ||
1930             return( $self->pass_error( $cldr->error ) );
1931 7         111458 my $opts =
1932             {
1933             day => 'numeric',
1934             month => 'numeric',
1935             year => 'numeric',
1936             hour => 'numeric',
1937             minute => 'numeric',
1938             second => 'numeric',
1939             };
1940 7         19 my $defaults;
1941 7         22 foreach my $loc ( @$tree )
1942             {
1943 14 100       61 if( exists( $BROWSER_DEFAULTS->{ $loc } ) )
1944             {
1945 7         17 $defaults = $BROWSER_DEFAULTS->{ $loc };
1946 7         19 last;
1947             }
1948             }
1949 7 50       63 $defaults = $BROWSER_DEFAULTS->{en} if( !defined( $defaults ) );
1950 7         33 my @keys = keys( %$defaults );
1951 7         32 @$opts{ @keys } = @$defaults{ @keys };
1952             # $opts->{numberingSystem} = $unicode->number_system;
1953 7         77 return( $opts );
1954             }
1955              
1956             # Function to get locale-specific preferences for scoring
1957             sub _get_locale_preferences
1958             {
1959 551     551   1055 my $self = shift( @_ );
1960 551   50     28587 my $locale = $self->{locale} || die( "Locale::Intl object is gone!" );
1961 551   50     6109 my $cldr = $self->_cldr || return( $self->pass_error );
1962            
1963             # Define common preference groups
1964 551         2165 my $eastern_europe =
1965             {
1966             dayPeriod => 3,
1967             timeZone => 2
1968             };
1969            
1970 551         1623 my $western_europe =
1971             {
1972             dayPeriod => 3,
1973             timeZone => 1
1974             };
1975              
1976 551         2259 my $middle_east =
1977             {
1978             weekday => 5,
1979             era => 1,
1980             dayPeriod => 4,
1981             timeZone => 3
1982             };
1983            
1984 551         1569 my $indian_subcontinent =
1985             {
1986             dayPeriod => 3,
1987             timeZone => 2
1988             };
1989              
1990 551         1920 my $east_asia =
1991             {
1992             weekday => 5,
1993             era => 5,
1994             dayPeriod => 1,
1995             timeZone => 1
1996             };
1997              
1998 551         1995 my $south_east_asia =
1999             {
2000             dayPeriod => 3,
2001             timeZone => 2
2002             };
2003              
2004             # Locale-specific preferences with finer granularity
2005 551         39518 my %locale_preferences =
2006             (
2007             # English locales with finer granularity
2008             'en-US' => { dayPeriod => 4, timeZone => 1 }, # US uses h12
2009             'en-GB' => { dayPeriod => 4, timeZone => 1 }, # GB uses h23
2010             'en-CA' => { dayPeriod => 4, timeZone => 1 }, # Canada uses h12
2011             'en-AU' => { dayPeriod => 4, timeZone => 1 }, # Australia uses h23
2012             'en-IN' => { dayPeriod => 4, timeZone => 2 }, # India uses h12
2013             'en-NZ' => { dayPeriod => 4, timeZone => 1 }, # New Zealand uses h23
2014            
2015             # French locales with finer granularity
2016             'fr-FR' => { dayPeriod => 2, timeZone => 1 }, # France uses h24
2017             'fr-CA' => { dayPeriod => 2, timeZone => 1 }, # Quebec uses h12
2018             'fr-BE' => { dayPeriod => 2, timeZone => 1 }, # Belgium uses h24
2019             'fr-CH' => { dayPeriod => 2, timeZone => 1 }, # Switzerland uses h24
2020              
2021             # Spanish locales with finer granularity
2022             'es-ES' => { dayPeriod => 3, timeZone => 1 }, # Spain uses h24
2023             'es-MX' => { dayPeriod => 3, timeZone => 1 }, # Mexico uses h12
2024             'es-US' => { dayPeriod => 3, timeZone => 1 }, # US Spanish uses h12
2025             'es-AR' => { dayPeriod => 3, timeZone => 1 }, # Argentina uses h12
2026              
2027             # Chinese locales with finer granularity
2028             'zh-CN' => { weekday => 5, era => 5, dayPeriod => 2, timeZone => 1 }, # China uses h24
2029             'zh-TW' => { weekday => 5, era => 5, dayPeriod => 2, timeZone => 1 }, # Taiwan uses h24
2030             'zh-HK' => { weekday => 5, era => 5, dayPeriod => 2, timeZone => 1 }, # Hong Kong uses h12
2031              
2032             # Russian locale with h24 format
2033             'ru' => { dayPeriod => 3, timeZone => 2 }, # Russia uses h24
2034              
2035             # Eastern European locales
2036             'be' => $eastern_europe,
2037             'bg' => $eastern_europe,
2038             'cs' => $eastern_europe,
2039             'hr' => $eastern_europe,
2040             'hu' => $eastern_europe,
2041             'lt' => $eastern_europe,
2042             'lv' => $eastern_europe,
2043             'pl' => $eastern_europe,
2044             'ro' => $eastern_europe,
2045             'ru' => $eastern_europe,
2046             'sk' => $eastern_europe,
2047             'sl' => $eastern_europe,
2048             'uk' => $eastern_europe,
2049              
2050             # Western European locales
2051             'af' => $western_europe,
2052             'ca' => $western_europe,
2053             'da' => $western_europe,
2054             'de' => { dayPeriod => 3, timeZone => 2 }, # Germany uses h24
2055             'es' => $western_europe,
2056             'fi' => $western_europe,
2057             'fr' => { dayPeriod => 3, timeZone => 1 },
2058             'it' => $western_europe,
2059             'nl' => $western_europe,
2060             'sv' => $western_europe,
2061              
2062             # Middle Eastern and Arabic-speaking locales
2063             'ar' => $middle_east,
2064             'he' => $middle_east,
2065             'fa' => $middle_east,
2066             'ur' => $middle_east,
2067            
2068             # Indian subcontinent locales
2069             'hi' => $indian_subcontinent,
2070             'bn' => $indian_subcontinent,
2071             'gu' => $indian_subcontinent,
2072             'ml' => $indian_subcontinent,
2073             'mr' => $indian_subcontinent,
2074             'ta' => $indian_subcontinent,
2075             'te' => $indian_subcontinent,
2076            
2077             # East Asia
2078             # Japan uses h24
2079             'ja' => { weekday => 4, era => 6, dayPeriod => 3, timeZone => 2 },
2080             'zh' => $east_asia,
2081             'ko' => { weekday => 4, era => 4, dayPeriod => 3, timeZone => 2 },
2082              
2083             # Southeast Asian locales
2084             'id' => $south_east_asia,
2085             'ms' => $south_east_asia,
2086             'vi' => $south_east_asia,
2087             'th' => $south_east_asia,
2088              
2089             # Default fallback for unspecified locales
2090             _default =>
2091             {
2092             weekday => 7,
2093             era => 4,
2094             dayPeriod => 4,
2095             timeZone => 3,
2096             }
2097             );
2098              
2099 551   50     3929 my $locales = $cldr->make_inheritance_tree( $locale ) ||
2100             return( $self->pass_error( $cldr->error ) );
2101             # Remove the last one: und
2102 551         4785527 pop( @$locales );
2103             # Return the specific locale's preferences, or fallback to the default
2104 551         2081 foreach my $loc ( @$locales )
2105             {
2106 558 100       2798 if( exists( $locale_preferences{ $loc } ) )
2107             {
2108 4         149 return( $locale_preferences{ $loc } );
2109             }
2110             }
2111             # Return the specific locale's preferences, or fallback to the default
2112 547         18286 return( $locale_preferences{_default} );
2113             }
2114              
2115             # We return 2 hash reference:
2116             # 1) An hash of components to weight and penalty used for scoring available patterns
2117             # 2) An hash of resolved options related components with their expected length, so we can score higher a pattern that match our option and has the right length.
2118             sub _get_option_dictionary
2119             {
2120 551     551   1157 my $self = shift( @_ );
2121 551         2066 my $args = $self->_get_args_as_hash( @_ );
2122             # Resolved options
2123             my $opts = $args->{options} ||
2124 551   50     1935 return( $self->error( "No options was provided." ) );
2125             # For intervals; this is optional and may be undef
2126 551         1175 my $diff = $args->{diff};
2127             # Scoring adjustments based on locale-specific preferences
2128 551         2204 my $locale_preferences = $self->_get_locale_preferences;
2129             # Score based on exact matches in the skeleton, with higher weights for more critical components
2130             # Define expected lengths and pattern characters for all options
2131             my $options_dict =
2132             {
2133             era =>
2134             {
2135             pattern_components => [qw(G)],
2136             penalty => 15,
2137             len =>
2138             {
2139             short => [1..3], # G..GGG
2140             long => 4, # GGGG
2141             narrow => 5, # GGGGG
2142             },
2143             weight => ( $locale_preferences->{era} || 4 ),
2144             },
2145             year =>
2146             {
2147             pattern_components => [qw(y Y)],
2148             penalty => 15,
2149             len =>
2150             {
2151             # 4 should be enough, but there is no upper limit actually in the LDML specifications
2152             numeric => [1..6], # y (numeric year)
2153             '2-digit' => 2 # yy (2-digit year)
2154             },
2155             weight => 14, # Year is generally important
2156             },
2157             month =>
2158             {
2159             pattern_components => [qw(M L)], # M and L for month
2160             penalty => 15,
2161             len =>
2162             {
2163             numeric => [1, 2], # M (numeric) or MM (2-digit)
2164             '2-digit' => 2, # MM (2-digit month)
2165             short => 3, # MMM (abbreviated month)
2166             long => 4, # MMMM (full month name)
2167             narrow => 5 # MMMMM (narrow month)
2168             },
2169             weight => 17, # Month is usually important
2170             },
2171             day =>
2172             {
2173             pattern_components => [qw(d)],
2174             penalty => 15,
2175             len =>
2176             {
2177             numeric => 1, # d (numeric day)
2178             '2-digit' => 2 # dd (2-digit day)
2179             },
2180             weight => 10,
2181             },
2182             weekday =>
2183             {
2184             pattern_components => [qw(c e E)],
2185             # Penalize heavily for unrequested weekday
2186             penalty => 20,
2187             len =>
2188             {
2189             # length of 1 and 2 are reserved for weekday as a number for pattern component 'c' and 'e', but not for E.
2190             # Abbreviated in CLDR
2191             short =>
2192             {
2193             'c' => 3, # ccc (Tue)
2194             'e' => 3, # eee (Tue)
2195             'E' => [1..3], # E..EEE (Tue)
2196             },
2197             # Wide in CLDR
2198             long => 4, # cccc (Tuesday), eeee (Tuesday), EEEE (Tuesday)
2199             # 6 characters should not happen though
2200             # Narrow and short in CLDR
2201             narrow => [5,6], # ccccc (T), cccccc (Tu), eeeee (T), eeeeee (Tu), EEEEE (T), EEEEEE (Tu)
2202             },
2203             weight => ( $locale_preferences->{weekday} || 7 ),
2204             },
2205             dayPeriod =>
2206             {
2207             # "Patterns for 12-hour-cycle time formats (using h or K) must include a day period field using one of a, b, or B."
2208             # <https://www.unicode.org/reports/tr35/tr35-dates.html#availableFormats_appendItems>
2209             # See at the end of this method for the implementation of this rule.
2210             # pattern_components => [qw(a b B)],
2211             # Actually, 'a' is AM/PM, not really a day period
2212             pattern_components => [qw(b B)],
2213             # Penalize for unrequested day periods
2214             penalty => 15,
2215             len =>
2216             {
2217             short => [1..3], # a..aaa, b..bbb, B..BBB (AM/PM)
2218             long => 4, # aaaa, bbbb, BBBB; b or B for specific day periods like noon or midnight
2219             narrow => 5, # aaaaa, bbbbb, BBBBB
2220             },
2221             weight => ( $locale_preferences->{dayPeriod} || 4 ),
2222             },
2223             hour =>
2224             {
2225             pattern_components => [qw(h H k K)],
2226             penalty => 15,
2227             len =>
2228             {
2229             numeric => [1,2], # h, H, k, K (numeric hour)
2230             '2-digit' => 2, # hh, HH, kk, KK (2-digit hour)
2231             },
2232             weight => 3,
2233             alias =>
2234             {
2235             # Only 'h' or 'H' are used in our option skeleton built in _options_to_skeleton()
2236             # and generally also in the CLDR available pattern skeletons
2237             'H' => ['k'],
2238             'h' => ['K'],
2239             },
2240             },
2241             minute =>
2242             {
2243             pattern_components => [qw(m)],
2244             penalty => 15,
2245             len =>
2246             {
2247             numeric => [1,2], # m (numeric minute)
2248             '2-digit' => 2, # mm (2-digit minute)
2249             },
2250             weight => 3,
2251             },
2252             second =>
2253             {
2254             pattern_components => [qw(s)],
2255             penalty => 15,
2256             len =>
2257             {
2258             numeric => [1,2], # s (numeric second)
2259             '2-digit' => 2, # ss (2-digit second)
2260             },
2261             weight => 3,
2262             },
2263             fractionalSecondDigits =>
2264             {
2265             pattern_components => [qw(S)],
2266             # Default penalty for unrequested components
2267             penalty => 5,
2268             len =>
2269             {
2270             1 => 1, # S (tenths of a second)
2271             2 => 2, # SS (hundredths of a second)
2272             3 => 3, # SSS (milliseconds)
2273             },
2274             weight => 3,
2275             },
2276             # 'V' is more for the time zone ID, or long time zone name, or exemplar city name
2277             timeZoneName =>
2278             {
2279             pattern_components => [qw(O z Z v V)],
2280             # Default penalty for unrequested components
2281             penalty => 5,
2282             len =>
2283             {
2284             short =>
2285             {
2286             'O' => 1, # O (GMT-8)
2287             'v' => 1, # v (short generic non-location format; e.g.: PT)
2288             'V' => 1, # V (short time zone ID; e.g. uslax)
2289             'z' => [1..3], # z..zzz (short localized GMT offset; e.g.: PDT)
2290             'Z' => [1..3], # Z..ZZZ (ISO8601 basic format; e.g.: -0800)
2291             },
2292             long => [4,5], # OOOO (GMT-08:00), zzzz (long localized GMT offset; e.g.: Pacific Daylight Time), ZZZZ (long localized GMT format. e.g.: GMT-8:00), ZZZZZ (ISO8601 extended format with hours, minutes and optional seconds; e.g.: -08:00 or -07:52:58)
2293             long =>
2294             {
2295             'O' => 4, # OOOO (long localized GMT format; e.g.: GMT-08:00)
2296             'v' => 4, # vvvv (long generic non-location format; e.g.: Pacific Time)
2297             # I seriously doubt VVV or VVVV would be occurring, but out of abondance of precaution, I add it anyway
2298             'V' => [2..4], # VV (long time zone ID; e.g. America/Los_Angeles), VVV (exemplar city; e.g.: Los Angeles), VVVV (generic location format; e.g.: Los Angeles Time)
2299             'z' => 4, # zzzz (long specific non-location format; e.g.: Pacific Daylight Time)
2300             # I doubt the ISO8601 extended format occurs, but out of abondance of precaution, I add it here anyway.
2301             'Z' => [4,5], # ZZZZ (long localized GMT format: e.g.: GMT-8:00), ZZZZZ (ISO8601 extended format with hours, minutes and optional seconds; e.g.: -07:52:58)
2302             },
2303             shortOffset => 1, # Z (short ISO-8601 time zone offset)
2304             longOffset => 4, # ZZZZ (long ISO-8601 time zone offset with GMT)
2305             shortGeneric => 1, # v (short generic non-location format; e.g.: PT)
2306             longGeneric => 4, # vvvv (long generic non-location format; e.g.: Pacific Time), VVVV (long generic location format; e.g.: Los Angeles Time)
2307             },
2308 551   100     48804 weight => ( $locale_preferences->{timeZone} || 3 ),
      100        
      50        
      50        
2309             }
2310             };
2311             # The components length for the selected options
2312 551         2759 my $components_length = {};
2313             # The components weight and penalty
2314 551         1053 my $components_weight = {};
2315             # The components aliases only for the resolved options components
2316             # Because, as the Unicode LDML specifies: "Only one field of each type is allowed; that is, "Hh" is not valid."
2317             # <https://www.unicode.org/reports/tr35/tr35-dates.html#availableFormats_appendItems>
2318 551         1067 my $components_alias = {};
2319 551         2636 foreach my $option ( keys( %$options_dict ) )
2320             {
2321 6061         9289 my $def = $options_dict->{ $option };
2322 6061         8739 my $components = $def->{pattern_components};
2323 6061         8829 foreach my $c ( @$components )
2324             {
2325 12673         25681 $components_weight->{ $c } = {};
2326 12673         17682 for( qw( weight penalty ) )
2327             {
2328 25346         48015 $components_weight->{ $c }->{ $_ } = $def->{ $_ };
2329             }
2330             }
2331 6061 100 100     17048 if( exists( $opts->{ $option } ) )
    50          
2332             {
2333 1565         2677 my $len = $def->{len};
2334             # Should not happen though
2335 1565 50       4759 die( "Misconfiguration: missing option value \"", $opts->{ $option }, "\" in our option length dictionary." ) if( !exists( $len->{ $opts->{ $option } } ) );
2336 1565 100       4499 if( ref( $len->{ $opts->{ $option } } ) eq 'HASH' )
2337             {
2338 182         414 foreach my $c ( keys( %{$len->{ $opts->{ $option } }} ) )
  182         851  
2339             {
2340 650         1561 $components_length->{ $c } = $len->{ $opts->{ $option } }->{ $c };
2341             }
2342             }
2343             else
2344             {
2345 1383         2785 foreach my $c ( @$components )
2346             {
2347             # which could be an integer, or an array reference of integer, such as [1,2]
2348 2616         5784 $components_length->{ $c } = $len->{ $opts->{ $option } };
2349             }
2350             }
2351              
2352 1565 100       3490 if( exists( $def->{alias} ) )
2353             {
2354 194         336 foreach my $k ( keys( %{$def->{alias}} ) )
  194         771  
2355             {
2356 388 50       1201 die( "Configuration error: I was expecting an array reference for this alias value for component \"${k}\", but instead I got '", $def->{alias}->{ $k }, "'" ) if( ref( $def->{alias}->{ $k } ) ne 'ARRAY' );
2357 388         648 my $keys = $def->{alias}->{ $k };
2358 388         1387 $components_alias->{ $k } = [@$keys];
2359             }
2360             }
2361             else
2362             {
2363 1371         2438 foreach my $c ( @$components )
2364             {
2365             # Any other, we alias to
2366 2490         7203 my @keys = grep( $_ ne $c, @$components );
2367 2490         6447 $components_alias->{ $c } = \@keys;
2368             }
2369             }
2370             }
2371             # If this option possible components match the greatest difference component if provided
2372 1740         5666 elsif( defined( $diff ) && scalar( grep( $_ eq $diff, @{$def->{pattern_components}} ) ) )
2373             {
2374             # We build an array of all possible length for this option
2375 0         0 my $len = $def->{len};
2376 0         0 foreach my $comp ( keys( %$len ) )
2377             {
2378 0 0       0 if( ref( $len->{ $comp } ) eq 'HASH' )
2379             {
2380 0         0 foreach my $c ( keys( %{$len->{ $comp }} ) )
  0         0  
2381             {
2382 0   0     0 $components_length->{ $c } ||= [];
2383 0 0       0 push( @{$components_length->{ $c }}, ref( $len->{ $comp }->{ $c } ) eq 'ARRAY' ? @{$len->{ $comp }->{ $c }} : $len->{ $comp }->{ $c } );
  0         0  
  0         0  
2384             }
2385             }
2386             else
2387             {
2388 0         0 foreach my $c ( @$components )
2389             {
2390 0   0     0 $components_length->{ $c } ||= [];
2391             # which could be an integer, or an array reference of integer, such as [1,2]
2392 0 0       0 push( @{$components_length->{ $c }}, ref( $len->{ $comp } ) eq 'ARRAY' ? @{$len->{ $comp }} : $len->{ $comp } );
  0         0  
  0         0  
2393             }
2394             }
2395             }
2396              
2397 0 0       0 if( exists( $def->{alias} ) )
2398             {
2399 0         0 foreach my $k ( keys( %{$def->{alias}} ) )
  0         0  
2400             {
2401 0 0       0 die( "Configuration error: I was expecting an array reference for this alias value for component \"${k}\", but instead I got '", $def->{alias}->{ $k }, "'" ) if( ref( $def->{alias}->{ $k } ) ne 'ARRAY' );
2402 0         0 my $keys = $def->{alias}->{ $k };
2403 0         0 $components_alias->{ $k } = [@$keys];
2404             }
2405             }
2406             else
2407             {
2408 0         0 foreach my $c ( @$components )
2409             {
2410             # Any other, we alias to
2411 0         0 my @keys = grep( $_ ne $c, @$components );
2412 0         0 $components_alias->{ $c } = \@keys;
2413             }
2414             }
2415             }
2416             }
2417              
2418             # "Patterns for 12-hour-cycle time formats (using h or K) must include a day period field using one of a, b, or B."
2419             # <https://www.unicode.org/reports/tr35/tr35-dates.html#availableFormats_appendItems>
2420             # We add an entry for AM/PM if hour12 is true and dayPeriod is not provided.
2421             # If dayPeriod is already provided, no need for 'a' as it would be redundant and the CLDR data reflects this.
2422 551 100 100     3998 if( exists( $opts->{hour12} ) &&
      100        
2423             $opts->{hour12} &&
2424             !exists( $opts->{dayPeriod} ) )
2425             {
2426 120         520 $components_length->{a} = [1..3];
2427 120         320 $components_weight->{a} = 5;
2428 120         386 $components_alias->{a} = ['a'];
2429             }
2430             # Some adjustments
2431 551 100       1851 if( exists( $opts->{hour12} ) )
2432             {
2433 214 100       573 if( $opts->{hour12} )
2434             {
2435             # Remove H23 and H24
2436 162         612 delete( @$components_length{ qw( H k ) } );
2437             }
2438             else
2439             {
2440             # Remove h11 and h12
2441 52         293 delete( @$components_length{ qw( h K ) } );
2442             }
2443             }
2444 551         15581 return( $components_length, $components_weight, $components_alias );
2445             }
2446              
2447             sub _get_options_map
2448             {
2449 632     632   1251 my $self = shift( @_ );
2450 632         13472 my $map =
2451             {
2452             # Maps for format length adjustments
2453             type_to_length =>
2454             {
2455             # actually 'abbreviated' in LDML parlance
2456             short => 1,
2457             # actually 'wide' in LDML parlance
2458             long => 4,
2459             narrow => 5,
2460             },
2461             # Those have been carefully considered n light of the documentation at:
2462             # <https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Intl/DateTimeFormat/DateTimeFormat#timezonename>
2463             # and the LDML symbols at:
2464             # <https://unicode.org/reports/tr35/tr35-dates.html#dfst-zone>
2465             # my $timeZoneName_map =
2466             timezone =>
2467             {
2468             # Short localized form (e.g.: "PST", "GMT-8")
2469             short => 'z',
2470             # Long localized form (e.g., "Pacific Standard Time", "Nordamerikanische Westküsten-Normalzeit")
2471             long => 'zzzz',
2472             # Short localized GMT format (e.g., "GMT-8")
2473             shortOffset => 'O',
2474             # Long localized GMT format (e.g., "GMT-08:00")
2475             longOffset => 'OOOO',
2476             # Short generic non-location format (e.g.: "PT", "Los Angeles Zeit").
2477             shortGeneric => 'v',
2478             # Long generic non-location format (e.g.: "Pacific Time", "Nordamerikanische Westküstenzeit")
2479             longGeneric => 'vvvv'
2480             },
2481             # my $month_map =
2482             month =>
2483             {
2484             numeric => 1,
2485             '2-digit' => 2,
2486             # 'abbreviated' in LDML parlance
2487             short => 3,
2488             # 'wide' in LDML parlance
2489             long => 4,
2490             narrow => 5,
2491             },
2492             # For pattern characters 'c' or 'e'
2493             # my $weekday_map =
2494             weekday =>
2495             {
2496             # actually 'abbreviated' in LDML parlance -> example: 'Tue'
2497             short => 1, # 2, or 3 are also acceptable
2498             # actually 'wide' in LDML parlance -> example: 'Tuesday'
2499             long => 4,
2500             # also matches 'narrow' in LDML -> example: 'T'
2501             narrow => 5,
2502            
2503             },
2504             };
2505 632         1669 return( $map );
2506             }
2507              
2508             sub _max
2509             {
2510 3     3   10 my( $x, $y ) = @_;
2511 3 100       18 return( ( $x > $y ) ? $x : $y );
2512             }
2513              
2514             sub _new_request_object
2515             {
2516 551     551   1086 my $self = shift( @_ );
2517 551         1600 my $args = $self->_get_args_as_hash( @_ );
2518 551   50     2035 my $opts = $args->{options} || die( "No resolved options hash reference provided." );
2519 551         1134 my $diff = $args->{diff};
2520             # $tokens is an array reference of hash with component, token and len properties
2521             # $components is an array of 1-letter component
2522 551   50     3139 my( $requested_skeleton, $tokens, $components, $date_components, $time_components ) = $self->_options_to_skeleton(
2523             options => $opts,
2524             ( defined( $diff ) ? ( diff => $diff ) : () ),
2525             ) || return( $self->pass_error );
2526              
2527             # Checking for exact match in the available pattern skeleton sounds like a great idea, but it leads to false positive.
2528             # So, we are best off going through all of the patterns and scoring them
2529 551   50     2827 my $request_object = $self->_new_skeleton_object(
2530             pattern_skeleton => $requested_skeleton,
2531             components => $components,
2532             date_components => $date_components,
2533             time_components => $time_components,
2534             tokens => $tokens,
2535             debug => $DEBUG,
2536             ) || return( $self->pass_error );
2537 551         2198 return( $request_object );
2538             }
2539              
2540             sub _new_score_result
2541             {
2542 20462     20462   28950 my $self = shift( @_ );
2543 20462   50     61791 my $obj = DateTime::Format::Intl::ScoreResult->new( @_ ) ||
2544             return( $self->pass_error( DateTime::Format::Intl::ScoreResult->error ) );
2545 20462         46554 return( $obj );
2546             }
2547              
2548             sub _new_skeleton_object
2549             {
2550 21011     21011   31013 my $self = shift( @_ );
2551 21011   50     62047 my $obj = DateTime::Format::Intl::Skeleton->new( @_ ) ||
2552             return( $self->pass_error( DateTime::Format::Intl::Skeleton->error ) );
2553 21011         53087 return( $obj );
2554             }
2555              
2556             # Generate a skeleton from the user-provided options, ensuring a consistent order
2557             sub _options_to_skeleton
2558             {
2559 551     551   1050 my $self = shift( @_ );
2560 551         1481 my $args = $self->_get_args_as_hash( @_ );
2561             my $opts = $args->{options} ||
2562 551   50     2017 return( $self->error( "No options provided." ) );
2563             # Provided if format_range() was called, otherwise this is undef
2564 551         1492 my $diff = $args->{diff};
2565              
2566 551         1344 my $skeleton = '';
2567              
2568             # Ensure a fixed order of components when building the skeleton
2569             # "The canonical order is from top to bottom in that table; that is, "yM" not "My"."
2570             # <https://www.unicode.org/reports/tr35/tr35-dates.html#availableFormats_appendItems>
2571 551         2728 my @ordered_options = qw( era year month weekday day dayPeriod hour minute second timeZoneName );
2572              
2573 551         2579 my $options_map = $self->_get_options_map;
2574             # Map of option keys to skeleton components
2575             # Possible components found in skeleton in CLDR data: [qw( B E G H M Q W Z c d h m s v w y )]
2576             # "It is not necessary to supply dateFormatItems with skeletons for every field length; fields in the skeleton and pattern are expected to be adjusted in parallel to handle a request."
2577             # <https://www.unicode.org/reports/tr35/tr35-dates.html#Matching_Skeletons>
2578             my $option_to_skeleton =
2579             {
2580             year => sub
2581             {
2582 551 100   551   2705 return( 'y' x ( exists( $opts->{year} ) ? ( $opts->{year} eq '2-digit' ? 2 : 1 ) : 1 ) );
    100          
2583             },
2584             month => sub
2585             {
2586 551 100   551   2468 return( 'M' x ( exists( $opts->{month} ) ? $options_map->{month}->{ $opts->{month} } : 1 ) );
2587             },
2588             day => sub
2589             {
2590 551 100   551   2284 return( 'd' x ( exists( $opts->{day} ) ? ( $opts->{day} eq '2-digit' ? 2 : 1 ) : 1 ) );
    100          
2591             },
2592             # There are 1 instance in the CLDR data where the skeleton uses 'c' (locale 'fi' with skeleton 'yMMMMccccd')
2593             weekday => sub
2594             {
2595 551 100   551   2151 return( 'E' x ( exists( $opts->{weekday} ) ? $options_map->{weekday}->{ $opts->{weekday} } : 1 ) );
2596             },
2597             # Can switch to 'H' for 24-hour time
2598             # hour => 'h',
2599             hour => sub
2600             {
2601 551 100 100 551   4083 my $comp = ( exists( $opts->{hourCycle} ) && defined( $opts->{hourCycle} ) && ( $opts->{hourCycle} eq 'h23' || $opts->{hourCycle} eq 'h24' ) ) ? 'H' : 'h';
2602 551 100       2362 return( $comp x ( exists( $opts->{hour} ) ? ( $opts->{hour} eq '2-digit' ? 2 : 1 ) : 1 ) );
    100          
2603             },
2604             minute => sub
2605             {
2606 551 50   551   2335 return( 'm' x ( exists( $opts->{minute} ) ? ( $opts->{minute} eq '2-digit' ? 2 : 1 ) : 1 ) );
    100          
2607             },
2608             second => sub
2609             {
2610 551 50   551   1905 return( 's' x ( exists( $opts->{second} ) ? ( $opts->{second} eq '2-digit' ? 2 : 1 ) : 1 ) );
    100          
2611             },
2612             era => sub
2613             {
2614 551 100   551   3198 return( 'G' x ( exists( $opts->{era} ) ? $options_map->{type_to_length}->{ $opts->{era} } : 1 ) );
2615             },
2616             dayPeriod => sub
2617             {
2618 551 100   551   2056 return( 'B' x ( exists( $opts->{dayPeriod} ) ? $options_map->{type_to_length}->{ $opts->{dayPeriod} } : 1 ) );
2619             },
2620             # There is 1 instance in the CLDR data where the skeleton uses 'Z' (locale 'fa' with skeleton 'HHmmZ')
2621             timeZoneName => sub
2622             {
2623 551 100   551   1615 return( exists( $opts->{timeZoneName} ) ? $options_map->{timezone}->{ $opts->{timeZoneName} } : 'v' );
2624             },
2625             # 'w' (week of year) and 'W' (week of month) are also found in the skeletons. 309 and 322 times respectively.
2626             # 'Q' (quarter) is also found 419 times in the skeletons, amazingly enough.
2627 551         18578 };
2628             # SELECT DISTINCT(format_id) FROM calendar_available_formats WHERE format_id regexp('G') ORDER BY LENGTH(format_id), format_id;
2629             # my $singletons =
2630             # {
2631             # # Bh, Bhm, Bhms, EBhm, EBhms
2632             # 'B' => 1,
2633             # # 'c' can have multiple occurrence
2634             # # 'd' can have multiple occurrence
2635             # # E can have multiple occurrence
2636             # # Gy, GyM, GyMd, GyMMM, GyMMMM, GyMMMd, GyMMMEd, GyMMMMd, GyMEEEEd, GyMMMMEd, GyMMMEEEEd
2637             # 'G' => 1,
2638             # # H, h, K, k can have multiple occurrence
2639             # # M, L can have multiple occurrence, although L never appears in skeletons
2640             # # m can have multiple occurrence
2641             # # s can have multiple occurrence
2642             # # Q can have multiple occurrence
2643             # # v can have multiple occurrence
2644             # # w can have multiple occurrence
2645             # # W probably can have multiple occurrence, although it never appears in skeletons
2646             # # y can have multiple occurrence
2647             # 'Z' => 1,
2648             # };
2649              
2650 551         2895 my $date_elements =
2651             {
2652             era => 1,
2653             year => 1,
2654             month => 1,
2655             weekday => 1,
2656             day => 1,
2657             };
2658 551         2263 my $time_elements =
2659             {
2660             dayPeriod => 1,
2661             hour => 1,
2662             minute => 1,
2663             second => 1,
2664             timeZoneName => 1,
2665             };
2666 551         1107 my $components = [];
2667 551         989 my $tokens = [];
2668 551         909 my $date_components = [];
2669 551         1012 my $time_components = [];
2670 551         1415 foreach my $option ( @ordered_options )
2671             {
2672 5510 50       14181 my $value = ( ref( $option_to_skeleton->{ $option } ) ? $option_to_skeleton->{ $option }->() : $option_to_skeleton->{ $option } );
2673 5510 100 50     25365 if( ( exists( $opts->{ $option } ) && length( $opts->{ $option } // '' ) ) ||
      66        
      66        
      66        
2674             ( defined( $diff ) && $value eq $diff ) )
2675             {
2676 1565         2656 $skeleton .= $value;
2677 1565         6665 push( @$tokens, {
2678             component => substr( $value, 0, 1 ),
2679             token => $value,
2680             len => length( $value ),
2681             });
2682 1565         3219 push( @$components, substr( $value, 0, 1 ) );
2683 1565 100       3772 if( exists( $date_elements->{ $option } ) )
    50          
2684             {
2685 1084         2592 push( @$date_components, substr( $value, 0, 1 ) );
2686             }
2687             elsif( exists( $time_elements->{ $option } ) )
2688             {
2689 481         1153 push( @$time_components, substr( $value, 0, 1 ) );
2690             }
2691             else
2692             {
2693 0 0       0 warn( "Uncategorised option \"${option}\" in either date or time map." ) if( warnings::enabled() );
2694             }
2695             }
2696             }
2697 551 50       20186 return( wantarray ? ( $skeleton, $tokens, $components, $date_components, $time_components ) : $skeleton );
2698             }
2699              
2700             # Convert a pattern to a skeleton for comparison
2701             sub _pattern_to_skeleton
2702             {
2703 20460     20460   28041 my $self = shift( @_ );
2704 20460         28825 my $pattern = shift( @_ );
2705            
2706             # Map format patterns to skeleton components
2707             # Found 16 skeleton components: [qw( B E G H M Q W Z c d h m s v w y )]
2708 20460         339735 my $format_to_skeleton =
2709             {
2710             'a' => 'B',
2711             'A' => 'B',
2712             'b' => 'B',
2713             'B' => 'B',
2714             'c' => 'E',
2715             'C' => 'h',
2716             'd' => 'd',
2717             # D (day of year)
2718             'e' => 'E',
2719             'E' => 'E',
2720             # F (Day of Week in Month)
2721             # g (Modified Julian day)
2722             'G' => 'G',
2723             'h' => 'h',
2724             'H' => 'H',
2725             'j' => 'h',
2726             'J' => 'h',
2727             'k' => 'H',
2728             'K' => 'h',
2729             'L' => 'M',
2730             'M' => 'M',
2731             'm' => 'm',
2732             'O' => 'v',
2733             'q' => 'Q',
2734             'Q' => 'Q',
2735             # r (Related Gregorian year)
2736             's' => 's',
2737             # S (Fractional Second)
2738             # u (Extended year)
2739             # U (Cyclic year name)
2740             'v' => 'v',
2741             'V' => 'v',
2742             'w' => 'w',
2743             'W' => 'W',
2744             'x' => 'v',
2745             'X' => 'v',
2746             'y' => 'y',
2747             'Y' => 'y',
2748             'z' => 'Z',
2749             'Z' => 'Z',
2750             };
2751            
2752 20460         34109 my $skeleton = '';
2753             # TODO: needs to be improved
2754 20460         81821 foreach my $component ( split( //, $pattern ) )
2755             {
2756 136821 100       246362 if( exists( $format_to_skeleton->{ $component } ) )
2757             {
2758             # $skeleton .= $format_to_skeleton->{ $component };
2759 84857         129591 $skeleton .= $component;
2760             }
2761             }
2762 20460         150758 return( $skeleton );
2763             }
2764              
2765             sub _remove_literal_text
2766             {
2767 20460     20460   28558 my $self = shift( @_ );
2768 20460         29057 my $pattern = shift( @_ );
2769             # This is an internal mishandling: die
2770 20460 50 50     58312 die( "No pattern was provided!" ) if( !length( $pattern // '' ) );
2771             # Regex to handle escaped single quotes ('') and remove literal text
2772             # Matches text inside single quotes and escaped quotes
2773 20460         56871 $pattern =~ s/'(?:[^']|'')*'//g;
2774 20460         57199 return( $pattern );
2775             }
2776              
2777             # Fine-tuned scoring logic based on real-world usage patterns and cultural preferences
2778             sub _score_pattern
2779             {
2780 20440     20440   29522 my $self = shift( @_ );
2781 20440         51914 my $args = $self->_get_args_as_hash( @_ );
2782 20440   50     45097 my $pattern_object = $args->{pattern_object} || die( "Missing pattern object." );
2783 20440   50     48754 my $request_object = $args->{request_object} || die( "Missing request object." );
2784 20440   50     41793 my $opts = $args->{options} || die( "Missing the user options." );
2785 20440         42191 my $pattern = $pattern_object->pattern;
2786 20440         43013 my $pattern_skeleton = $pattern_object->pattern_skeleton;
2787             # Array of descriptive dictionary for each component, such as: { component => 'E', token => 'EEEE', len => 4 }
2788 20440         51427 my $pattern_tokens = $pattern_object->tokens;
2789 20440         36770 my $requested_skeleton = $request_object->pattern_skeleton;
2790 20440         35359 my $requested_tokens = $request_object->tokens;
2791              
2792 20440   50     136613 my $locale = $self->{locale} || die( "The Locale::Intl object is gone" );
2793 20440   50     196310 my $unicode = $self->{_unicode} || die( "The DateTime::Locale::FromCLDR object is gone" );
2794            
2795 20440         111482 my $score = 0;
2796              
2797 20440         32117 my $components_length = $self->{_components_length};
2798 20440         30944 my $components_weight = $self->{_components_weight};
2799 20440         29404 my $components_alias = $self->{_components_alias};
2800              
2801             # Collect the components in the pattern skeleton
2802 20440         42341 my $pattern_chars = $pattern_object->components;
2803 20440         42159 my $pattern_components = +{ map{ $_->{component} => $_ } @$pattern_tokens };
  59025         164927  
2804              
2805             # This is used to check if a component found in the pattern is found or not in the skeleton. If it is not, the penalty is not as bad.
2806 20440         51689 my $skeleton_tokens = $pattern_object->skeleton_tokens;
2807 20440         34224 my $skeleton_components = +{ map{ $_->{component} => $_ } @$skeleton_tokens };
  55734         119042  
2808              
2809             # Penalize for extra components not in the requested skeleton
2810 20440         35844 my $extra_component_penalty = 0;
2811              
2812              
2813             # Score for a component that matches perfectly, i.e. the right component and right length
2814 20440         26317 my $perfect_component_score = 100;
2815             # Keep track of this hypothetical perfect score separate from the actual score, because we do not want to pollute the latter with the former, since this $perfect_score is just a test whether this available pattern skeleton matches perfectly our requested skeleton or not. If it is, we bump up the review of all available patterns stops.
2816 20440         25202 my $perfect_score = 0;
2817 20440         27076 my $missing = [];
2818             # Determine if this pattern needs adjustment, assuming it will be the one retained in the end.
2819             # We do this assessment here, because it is easy to check, and it saves us later the trouble of parsing the pattern once more to check for any need for adjustment, by calling the method _adjust_pattern
2820 20440         25472 my $need_adjustment = 0;
2821              
2822             # We give weight on the existence of a component from the requested skeleton in the available pattern; and
2823             # on the pertinence (length) of that components, such as MMMM for long (wide)
2824             # The order is not important, because of variation from locale to locale
2825             # The best will be retained, and its pattern adjusted to fit the user options; for example 'MMMM' might become 'MMM'
2826 20440         49521 for( my $i = 0; $i < scalar( @$requested_tokens ); $i++ )
2827             {
2828 57389         82917 my $def = $requested_tokens->[$i];
2829 57389         92096 my $requested_component = $def->{component};
2830 57389         72590 my $alias;
2831             # my $alias = ( exists( $pattern_components->{ $requested_component } ) ? $requested_component : [grep( exists( $pattern_components->{ $_ } ), @{$components_alias->{ $requested_component } || []} )]->[0] );
2832 57389 100       99976 if( exists( $pattern_components->{ $requested_component } ) )
    100          
2833             {
2834 19514         27945 $alias = $requested_component;
2835             }
2836             # Found the component in our request skeleton, but as an alias, which means that we will need to adjust our pattern
2837 37875 50       137018 elsif( my $found_alias = [grep( exists( $pattern_components->{ $_ } ), @{$components_alias->{ $requested_component } || []} )]->[0] )
2838             {
2839 810         1393 $alias = $found_alias;
2840 810         1333 $need_adjustment++;
2841             }
2842             else
2843             {
2844 37065         50060 $alias = $requested_component;
2845 37065         47462 $need_adjustment++;
2846             }
2847              
2848 57389 100       105288 my $exists = ( exists( $pattern_components->{ $alias } ) ? 1 : 0 );
2849             # Does the current pattern have our requested component, such as 'E' ?
2850 57389 100       88712 if( $exists )
2851             {
2852             # Our requested component might exist, even though the pattern skeleton is smaller than our requested one.
2853             # For example: YMMMd (requested skeleton) vs yd (pattern skeleton)
2854 20324         37747 $score += $components_weight->{ $alias }->{weight};
2855 20324         31854 my $expected_length = $components_length->{ $alias };
2856              
2857 20324 100       39816 if( ref( $expected_length ) eq 'ARRAY' )
2858             {
2859 9880 100       15944 if( scalar( grep{ $pattern_components->{ $alias }->{len} == $_ } @$expected_length ) )
  37308         74914  
2860             {
2861             # Reward for exact numeric match
2862 8592         11287 $score += 5;
2863 8592         21736 $perfect_score += $perfect_component_score;
2864             }
2865             else
2866             {
2867             # Penalize for abbreviation mismatch
2868 1288 50       4427 my $component_penalty = 3 + ( ( $expected_length->[0] > $pattern_components->{ $alias }->{len} ) ? ( $expected_length->[0] - $pattern_components->{ $alias }->{len} ) : ( $pattern_components->{ $alias }->{len} - $expected_length->[0] ) );
2869 1288         2024 $score -= $component_penalty;
2870 1288         3354 $need_adjustment++;
2871             }
2872             }
2873             else
2874             {
2875             # Exact length match (e.g., MMM, EEEE)
2876 10444 100       26125 if( $pattern_components->{ $alias }->{len} == $expected_length )
2877             {
2878             # Reward for exact match
2879 7476         10295 $score += 5;
2880 7476         18910 $perfect_score += $perfect_component_score;
2881             }
2882             else
2883             {
2884             # Penalize for mismatched length (e.g., MMM instead of MMMM or MM)
2885 2968 100       9884 my $component_penalty = 3 + ( ( $expected_length > $pattern_components->{ $alias }->{len} ) ? ( $expected_length - $pattern_components->{ $alias }->{len} ) : ( $pattern_components->{ $alias }->{len} - $expected_length ) );
2886 2968         4524 $score -= $component_penalty;
2887 2968         7963 $need_adjustment++;
2888             }
2889             }
2890             }
2891             # Requested component is missing, penalising this pattern
2892             else
2893             {
2894 37065         65747 push( @$missing, $alias );
2895             # my $component_penalty = ( $components_weight->{ $alias }->{weight} || 10 );
2896 37065         45212 my $component_penalty = 12;
2897 37065         86984 $score -= $component_penalty;
2898             }
2899             }
2900              
2901             # Penalise for extra components in the pattern that were not requested
2902 20440         39040 foreach my $component ( @$pattern_chars )
2903             {
2904             # Possible characters found in skeleton in CLDR data: [qw( B E G H M Q W Z c d h m s v w y )]
2905             # However, the DateTime::Format::Intl that implements the JavaScript Intl.DateTimeFormat does not support some components.
2906             # This is an unknown component, maybe W or Q, which is not an option component, i.e. a component derived from DateTimeFormat options
2907 59025 100       117831 unless( exists( $components_weight->{ $component } ) )
2908             {
2909             # Cancel our perfect score
2910 3506         5041 $perfect_score = 0;
2911 3506         4961 $extra_component_penalty += 15;
2912 3506         6774 next;
2913             }
2914              
2915             # This component is missing from our requested skeleton, but is also absent from the current pattern skeleton, so this is forgivable.
2916 55519 100 100     201349 if( !exists( $components_length->{ $component } ) &&
    100          
2917             !exists( $skeleton_components->{ $component } ) )
2918             {
2919 795         1769 next;
2920             }
2921             # This component is not among our requested component
2922             elsif( !exists( $components_length->{ $component } ) )
2923             {
2924             # "Patterns and skeletons for 24-hour-cycle time formats (using H or k) currently should not include fields with day period components (a, b, or B); these pattern components should be ignored if they appear in skeletons. However, in the future, CLDR may allow use of B (but not a or b) in 24-hour-cycle time formats."
2925             # <https://www.unicode.org/reports/tr35/tr35-dates.html#availableFormats_appendItems>
2926             # We increase penalty if the rule aforementioned materialise.
2927 33311         41672 my $augmented_penalty = 2;
2928 33311 100 100     168883 if( exists( $opts->{hourCycle} ) &&
    50 100        
      66        
      100        
      33        
2929             # H or k
2930             ( $opts->{hourCycle} eq 'h23' || $opts->{hourCycle} eq 'h24' ) &&
2931             ( $component eq 'a' || $component eq 'b' || $component eq 'B' ) )
2932             {
2933 210         388 $augmented_penalty = 10;
2934             }
2935             # "A requested skeleton that includes both seconds and fractional seconds (e.g. “mmssSSS”) is allowed to match a dateFormatItem skeleton that includes seconds but not fractional seconds (e.g. “ms”)."
2936             # <https://www.unicode.org/reports/tr35/tr35-dates.html#Matching_Skeletons>
2937             # Although the above rule never happens, as of now (2024-09-29), in the current CLDR data (v35), we implement it anyway.
2938             elsif( $component eq 'S' &&
2939             exists( $opts->{second} ) )
2940             {
2941 0         0 next;
2942             }
2943 33311   50     76614 $augmented_penalty += ( $components_weight->{ $component }->{penalty} || 15 );
2944             # Penalise extra components
2945 33311         41119 $extra_component_penalty += $augmented_penalty;
2946             # Cancel our perfect score
2947 33311         51224 $perfect_score = 0;
2948             }
2949             }
2950              
2951             # Adjust the final score
2952             # Penalise for extra components
2953 20440         27467 $score -= $extra_component_penalty;
2954 20440 100       42987 if( $perfect_score == ( scalar( @$requested_tokens ) * $perfect_component_score ) )
2955             {
2956 496         742 $score += $perfect_score;
2957             }
2958              
2959             # Adjust score based on specific options (e.g., hour cycle)
2960 20440 100       49061 if( exists( $opts->{hourCycle} ) )
2961             {
2962 8736 100 100     55229 if( $opts->{hourCycle} eq 'h12'
    100 100        
2963             && index( $pattern_skeleton, 'h' ) != -1 )
2964             {
2965 2049         3426 $score += 5;
2966             }
2967             elsif( $opts->{hourCycle} eq 'h24' &&
2968             index( $pattern_skeleton, 'H' ) != -1 )
2969             {
2970 324         569 $score += 5;
2971             }
2972             }
2973 20440   50     57582 my $result = $self->_new_score_result(
2974             missing => $missing,
2975             need_adjustment => $need_adjustment,
2976             pattern_object => $pattern_object,
2977             request_object => $request_object,
2978             score => $score,
2979             ) || return( $self->pass_error );
2980 20440         131158 return( $result );
2981             }
2982              
2983             # Select the best pattern from available patterns
2984             sub _select_best_pattern
2985             {
2986 551     551   1382 my $self = shift( @_ );
2987 551         2578 my $args = $self->_get_args_as_hash( @_ );
2988             my $available_patterns = $args->{patterns} ||
2989 551   50     2326 return( $self->error( "No patterns provided." ) );
2990             my $opts = $args->{options} ||
2991 551   50     2087 return( $self->error( "No options was provided." ) );
2992             # If we are called by format_range()
2993 551         1481 my $diff = $args->{diff};
2994              
2995             # Convert user options to a skeleton (an abstracted form of the requested options)
2996 551   50     3617 my $request_object = $self->_new_request_object(
2997             options => $opts,
2998             ( defined( $diff ) ? ( diff => $diff ) : () ),
2999             ) || return( $self->pass_error );
3000 551         1534 my $requested_skeleton = $request_object->pattern_skeleton;
3001 551         17550 my @sorted_available_skeletons = sort{ length( $a ) <=> length( $b ) } sort( keys( %$available_patterns ) );
  84671         125262  
3002 551         4769 my $requested_skeleton_len = length( $requested_skeleton );
3003 551         2281 for( my $i = 0; $i < scalar( @sorted_available_skeletons ); $i++ )
3004             {
3005             # If the next skeleton is equal of greater in length as our requested skeleton, we
3006             # take all the ones before it and place it at the end of the stack, so we deal with them last,
3007             # and thus avoid wasting processing power on pattern that have little chance of being satisfactory.
3008 11599 100 66     42709 if( $i <= $#sorted_available_skeletons &&
3009             length( $sorted_available_skeletons[$i] ) >= $requested_skeleton_len )
3010             {
3011             # push( @sorted_available_skeletons, splice( @sorted_available_skeletons, 0, $i ) );
3012 498 100       3636 push( @sorted_available_skeletons, splice( @sorted_available_skeletons, 0, ( $i - 1 ) ) ) if( $i > 0 );
3013 498         2194 last;
3014             }
3015             }
3016              
3017              
3018 551 100       3245 my( $components_len, $components_weight, $components_alias ) = $self->_get_option_dictionary(
3019             options => $opts,
3020             ( defined( $diff ) ? ( diff => $diff ) : () ),
3021             );
3022 551 50       2000 return( $self->pass_error ) if( !defined( $components_len ) );
3023 551         2439 $self->{_components_length} = $components_len;
3024 551         3987 $self->{_components_weight} = $components_weight;
3025 551         1751 $self->{_components_alias} = $components_alias;
3026              
3027 551         911 my $best_pattern;
3028             # Same as in _score_pattern(); maybe should make it a module constant ? Maybe overkill ?
3029 551         991 my $perfect_component_score = 100;
3030 551         1024 my $best_score = -1;
3031             # Merely for tracking and reporting
3032 551         1138 my( $best_skeleton, $best_score_object );
3033 551         1329 foreach my $skeleton ( @sorted_available_skeletons )
3034             {
3035 20440         67512 my $pattern = $available_patterns->{ $skeleton };
3036             # Handle literal text inside single quotes
3037 20440   50     46632 my $raw_pattern = $self->_remove_literal_text( $pattern ) ||
3038             return( $self->pass_error );
3039              
3040             # Generate a skeleton from the available pattern
3041 20440   50     53266 my $pattern_skeleton = $self->_pattern_to_skeleton( $raw_pattern ) ||
3042             return( $self->pass_error );
3043 20440   50     57364 my $pattern_object = $self->_new_skeleton_object(
3044             # Original skeleton provided by CLDR
3045             skeleton => $skeleton,
3046             # Skeleton derived from the format pattern
3047             pattern_skeleton => $pattern_skeleton,
3048             # Actual pattern for this format ID
3049             pattern => $pattern,
3050             debug => $DEBUG,
3051             ) || return( $self->pass_error );
3052              
3053              
3054             # Score how well the pattern matches the user's options
3055 20440   50     60938 my $score_object = $self->_score_pattern(
3056             request_object => $request_object,
3057             pattern_object => $pattern_object,
3058             options => $opts,
3059             ) || return( $self->pass_error );
3060 20440         43692 my $score = $score_object->score;
3061            
3062            
3063             # If the score is higher, update the best pattern
3064 20440 100       41303 if( $score > $best_score )
3065             {
3066 1029         2001 $best_pattern = $pattern;
3067 1029         1573 $best_score = $score;
3068 1029         1768 $best_skeleton = $skeleton;
3069 1029         9384 $best_score_object = $score_object;
3070             }
3071              
3072              
3073             # If the pattern score is equal or higher than the perfect component score, we got a perfect match and we stop checking.
3074 20440 100       283340 if( $score > $perfect_component_score )
3075             {
3076             # Actually, we keep going, because we could find another perfect match
3077             # last;
3078             }
3079             }
3080              
3081             # No perfect match, and this is a singleton, most likely something that has no equivalent among the available patterns.
3082             # If so, the requested skeleton in itself is our perfect match
3083 551   50     1794 my $request_tokens = $request_object->tokens || die( "No request tokens array reference set!" );
3084 551 100 100     4959 if( $best_score < $perfect_component_score &&
    100 66        
      100        
      100        
      100        
      50        
      66        
      66        
3085             scalar( @$request_tokens ) == 1 &&
3086             !exists( $available_patterns->{ $request_tokens->[0]->{token} } ) &&
3087             !exists( $available_patterns->{ $request_tokens->[0]->{component} } ) )
3088             {
3089 2         6 $best_score += $perfect_component_score;
3090 2 50       17 $best_skeleton = $best_pattern = ( $request_tokens->[0]->{component} x ( ref( $components_len->{ $request_tokens->[0]->{component} } ) eq 'ARRAY' ? $components_len->{ $request_tokens->[0]->{component} }->[0] : $components_len->{ $request_tokens->[0]->{component} } ) );
3091 2         10 $request_object->pattern( $best_pattern );
3092 2         9 $request_object->skeleton( $best_skeleton );
3093 2   50     7 $best_score_object = $self->_new_score_result(
3094             pattern_object => $request_object,
3095             request_object => $request_object,
3096             score => $best_score,
3097             ) || return( $self->pass_error );
3098 2         56 return( $best_score_object );
3099             }
3100             # Quoting from the LDML specifications:
3101             # "If a client-requested set of fields includes both date and time fields, and if the availableFormats data does not include a dateFormatItem whose skeleton matches the same set of fields, then the request should be handled as follows:
3102             # 1. Divide the request into a date fields part and a time fields part.
3103             # 2. For each part, find the matching dateFormatItem, and expand the pattern as above.
3104             # 3. Combine the patterns for the two dateFormatItems using the appropriate dateTimeFormat pattern, determined as follows from the requested date fields:
3105             # * If the requested date fields include wide month (MMMM, LLLL) and weekday name of any length (e.g. E, EEEE, c, cccc), use <dateTimeFormatLength type="full">
3106             # * Otherwise, if the requested date fields include wide month, use <dateTimeFormatLength type="long">
3107             # * Otherwise, if the requested date fields include abbreviated month (MMM, LLL), use <dateTimeFormatLength type="medium">
3108             # * Otherwise use <dateTimeFormatLength type="short">"
3109             # <https://www.unicode.org/reports/tr35/tr35-dates.html#Missing_Skeleton_Fields>
3110             elsif( (
3111             ( $best_score >= 0 && scalar( @{$best_score_object->missing // []} ) ) ||
3112             $best_score < 0
3113             ) &&
3114 23   50     69 scalar( @{$request_object->date_components // []} ) &&
3115 23   50     113 scalar( @{$request_object->time_components // []} ) &&
3116             !$diff &&
3117             !$args->{subprocess} )
3118             {
3119 20         82 my @core_options = qw( calendar hour12 hourCycle locale numberingSystem timeZone );
3120 20         121 my @date_options = ( qw( era year month weekday day ), @core_options );
3121 20         78 my @time_options = ( qw( hour minute second timeZoneName ), @core_options );
3122             # "1. Divide the request into a date fields part and a time fields part."
3123 20         197 my $date_opts = +{ map{ $_ => $opts->{ $_ } } grep( exists( $opts->{ $_ } ), @date_options ) };
  178         602  
3124 20         184 my $time_opts = +{ map{ $_ => $opts->{ $_ } } grep( exists( $opts->{ $_ } ), @time_options ) };
  167         407  
3125             # "2. For each part, find the matching dateFormatItem, and expand the pattern as above."
3126 20         137 my $date_score_object = $self->_select_best_pattern(
3127             options => $date_opts,
3128             patterns => $available_patterns,
3129             # To avoid risk of recurring calls, we tag it
3130             subprocess => 1,
3131             );
3132 20         96 my $date_pat = $date_score_object->pattern_object->pattern;
3133 20         60 my $date_skel = $date_score_object->pattern_object->skeleton;
3134 20   50     43 my $has_missing_date_components = scalar( @{$date_score_object->missing // []} );
  20         53  
3135             #
3136             # # If the result has some missing components, we need to add them
3137             # if( $has_missing_date_components )
3138             # {
3139             # $date_pat = $self->_append_components(
3140             # pattern => $date_pat,
3141             # missing => $date_score_object->missing,
3142             # );
3143             # }
3144              
3145 20         87 my $time_score_object = $self->_select_best_pattern(
3146             options => $time_opts,
3147             patterns => $available_patterns,
3148             # To avoid risk of recurring calls, we tag it
3149             subprocess => 1,
3150             );
3151 20         68 my $time_pat = $time_score_object->pattern_object->pattern;
3152 20         59 my $time_skel = $time_score_object->pattern_object->skeleton;
3153 20   50     42 my $has_missing_time_components = scalar( @{$time_score_object->missing // []} );
  20         58  
3154             # 3. Combine the patterns for the two dateFormatItems using the appropriate dateTimeFormat pattern, determined as follows from the requested date fields:
3155             # * If the requested date fields include wide month (MMMM, LLLL) and weekday name of any length (e.g. E, EEEE, c, cccc), use <dateTimeFormatLength type="full">
3156             # * Otherwise, if the requested date fields include wide month, use <dateTimeFormatLength type="long">
3157             # * Otherwise, if the requested date fields include abbreviated month (MMM, LLL), use <dateTimeFormatLength type="medium">
3158             # * Otherwise use <dateTimeFormatLength type="short">"
3159 20         42 my $datetime_format_width;
3160 20 100 66     274 if( exists( $components_len->{'M'} ) &&
    100 100        
    100 66        
      66        
3161             # wide
3162             $components_len->{'M'} == 4 &&
3163             # any length, so we do not have to check the length
3164             exists( $components_len->{'E'} ) )
3165             {
3166 6         14 $datetime_format_width = 'full';
3167             }
3168             elsif( exists( $components_len->{'M'} ) &&
3169             # wide
3170             $components_len->{'M'} == 4 )
3171             {
3172 4         10 $datetime_format_width = 'long';
3173             }
3174             elsif( exists( $components_len->{'M'} ) &&
3175             # abbreviated
3176             $components_len->{'M'} == 3 )
3177             {
3178 4         12 $datetime_format_width = 'medium';
3179             }
3180             else
3181             {
3182 6         19 $datetime_format_width = 'short';
3183             }
3184 20         93 my $datetime_format = $self->_get_datetime_format(
3185             width => $datetime_format_width,
3186             );
3187 20 50       67 return( $self->pass_error ) if( !defined( $datetime_format ) );
3188 20         50 my $datetime_skel = $datetime_format;
3189 20         133 $datetime_format =~ s/\{1\}/$date_pat/;
3190 20         120 $datetime_format =~ s/\{0\}/$time_pat/;
3191 20         89 $datetime_skel =~ s/\{1\}/$date_skel/;
3192 20         83 $datetime_skel =~ s/\{0\}/$time_skel/;
3193 20   50     110 my $raw_pattern = $self->_remove_literal_text( $datetime_format ) ||
3194             return( $self->pass_error );
3195 20   50     78 my $pattern_object = $self->_new_skeleton_object(
3196             pattern => $datetime_format,
3197             skeleton => $datetime_skel,
3198             pattern_skeleton => $self->_pattern_to_skeleton( $raw_pattern ),
3199             debug => $DEBUG,
3200             ) || return( $self->pass_error );
3201 20   50     133 $best_score_object = $self->_new_score_result(
3202             score => ( defined( $best_score_object ) ? $best_score_object->score : _max( $date_score_object->score, $time_score_object->score ) ),
3203             pattern_object => $pattern_object,
3204             request_object => $request_object,
3205             need_adjustment => ( ( $date_score_object->need_adjustment || $time_score_object->need_adjustment ) ? 1 : 0 ),
3206             ) || return( $self->pass_error );
3207 20         2851 return( $best_score_object );
3208             }
3209            
3210 529         1914 my $has_missing_components = $best_score_object->has_missing;
3211             # If the result has some missing components, we need to add them
3212 529 100       1635 if( $has_missing_components )
3213             {
3214 3         15 my $pattern = $self->_append_components(
3215             # pattern => $pattern,
3216             pattern => $best_score_object->pattern_object->pattern,
3217             missing => $best_score_object->missing,
3218             );
3219 3         17 $best_score_object->pattern_object->pattern( $pattern );
3220 3 50       13 return( $self->pass_error ) if( !defined( $pattern ) );
3221             }
3222              
3223             # "Once a best match is found between requested skeleton and dateFormatItem id, the corresponding dateFormatItem pattern is used, but with adjustments primarily to make the pattern field lengths match the skeleton field lengths."
3224             # <https://www.unicode.org/reports/tr35/tr35-dates.html#Matching_Skeletons>
3225             # No need to bother calling this method, if there is no need for adjustment
3226             # We do not append components on a datetime range, so we check if this is one with the $diff variable
3227 529 100 100     2176 if( !$diff && $best_score_object->need_adjustment )
3228             {
3229 81   50     284 my $pattern = $self->_adjust_pattern(
3230             # pattern => $pattern,
3231             pattern => $best_score_object->pattern_object->pattern,
3232             options => $opts,
3233             request_object => $best_score_object->request_object,
3234             pattern_object => $best_score_object->pattern_object,
3235             ) || return( $self->pass_error );
3236 81         352 $best_score_object->pattern_object->pattern( $pattern );
3237             }
3238              
3239 529 50       1347 return( $self->error( "No suitable date pattern found for given options" ) ) unless( $best_pattern );
3240 529         8436 return( $best_score_object );
3241             }
3242              
3243             sub _set_cached_pattern
3244             {
3245 513     513   1169 my $self = shift( @_ );
3246 513         1739 my( $locale, $key, $pattern ) = @_;
3247 513 100       4766 $CACHE->{ $locale } = {} if( !exists( $CACHE->{ $locale } ) );
3248 513         7775 $CACHE->{ $locale }->{ $key } = $pattern;
3249             }
3250              
3251             sub _set_get_prop
3252             {
3253 1109     1109   2318 my $self = shift( @_ );
3254 1109   50     3568 my $prop = shift( @_ ) || die( "No object property was provided." );
3255 1109 50       3159 $self->{ $prop } = shift( @_ ) if( @_ );
3256 1109         3569 return( $self->{ $prop } );
3257             }
3258              
3259             # NOTE: $BROWSER_DEFAULTS
3260             {
3261             $BROWSER_DEFAULTS =
3262             {
3263             af => {
3264             day => "2-digit",
3265             hour => "2-digit",
3266             minute => "2-digit",
3267             month => "2-digit",
3268             second => "2-digit",
3269             },
3270             "af-NA" => {
3271             day => "2-digit",
3272             minute => "2-digit",
3273             month => "2-digit",
3274             second => "2-digit",
3275             },
3276             agq => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3277             ak => { minute => "2-digit", second => "2-digit" },
3278             am => { minute => "2-digit", second => "2-digit" },
3279             ar => { minute => "2-digit", second => "2-digit" },
3280             "ar-IL" => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3281             "ar-KM" => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3282             "ar-MA" => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3283             as => {
3284             day => "2-digit",
3285             minute => "2-digit",
3286             month => "2-digit",
3287             second => "2-digit",
3288             },
3289             asa => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3290             ast => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3291             az => {
3292             day => "2-digit",
3293             hour => "2-digit",
3294             minute => "2-digit",
3295             month => "2-digit",
3296             second => "2-digit",
3297             },
3298             "az-Cyrl" => {
3299             day => "2-digit",
3300             hour => "2-digit",
3301             minute => "2-digit",
3302             month => "2-digit",
3303             second => "2-digit",
3304             },
3305             bas => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3306             be => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3307             bem => { minute => "2-digit", second => "2-digit" },
3308             bez => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3309             bg => {
3310             hour => "2-digit",
3311             minute => "2-digit",
3312             month => "2-digit",
3313             second => "2-digit",
3314             },
3315             bgc => { minute => "2-digit", second => "2-digit" },
3316             bho => {
3317             day => "2-digit",
3318             minute => "2-digit",
3319             month => "2-digit",
3320             second => "2-digit",
3321             },
3322             bm => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3323             bn => { minute => "2-digit", second => "2-digit" },
3324             bo => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3325             "bo-IN" => { minute => "2-digit", second => "2-digit" },
3326             br => {
3327             day => "2-digit",
3328             hour => "2-digit",
3329             minute => "2-digit",
3330             month => "2-digit",
3331             second => "2-digit",
3332             },
3333             brx => {
3334             day => "2-digit",
3335             minute => "2-digit",
3336             month => "2-digit",
3337             second => "2-digit",
3338             },
3339             bs => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3340             "bs-Cyrl" => {
3341             day => "2-digit",
3342             hour => "2-digit",
3343             minute => "2-digit",
3344             month => "2-digit",
3345             second => "2-digit",
3346             },
3347             ca => { minute => "2-digit", second => "2-digit" },
3348             ccp => { minute => "2-digit", second => "2-digit" },
3349             ceb => { minute => "2-digit", second => "2-digit" },
3350             cgg => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3351             chr => { minute => "2-digit", second => "2-digit" },
3352             ckb => { minute => "2-digit", second => "2-digit" },
3353             "ckb-IR" => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3354             cs => { minute => "2-digit", second => "2-digit" },
3355             cv => {
3356             day => "2-digit",
3357             hour => "2-digit",
3358             minute => "2-digit",
3359             month => "2-digit",
3360             second => "2-digit",
3361             },
3362             cy => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3363             da => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3364             dav => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3365             de => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3366             dje => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3367             doi => { minute => "2-digit", second => "2-digit" },
3368             dsb => { minute => "2-digit", second => "2-digit" },
3369             dua => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3370             dyo => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3371             dz => { minute => "2-digit", second => "2-digit" },
3372             ebu => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3373             ee => { minute => "2-digit", second => "2-digit" },
3374             "ee-TG" => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3375             el => { minute => "2-digit", second => "2-digit" },
3376             en => { minute => "2-digit", second => "2-digit" },
3377             "en-001" => {
3378             day => "2-digit",
3379             minute => "2-digit",
3380             month => "2-digit",
3381             second => "2-digit",
3382             },
3383             "en-150" => {
3384             day => "2-digit",
3385             hour => "2-digit",
3386             minute => "2-digit",
3387             month => "2-digit",
3388             second => "2-digit",
3389             },
3390             "en-AE" => {
3391             day => "2-digit",
3392             minute => "2-digit",
3393             month => "2-digit",
3394             second => "2-digit",
3395             },
3396             "en-AI" => {
3397             day => "2-digit",
3398             hour => "2-digit",
3399             minute => "2-digit",
3400             month => "2-digit",
3401             second => "2-digit",
3402             },
3403             "en-AU" => {
3404             day => "2-digit",
3405             minute => "2-digit",
3406             month => "2-digit",
3407             second => "2-digit",
3408             },
3409             "en-BE" => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3410             "en-BI" => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3411             "en-BW" => {
3412             day => "2-digit",
3413             hour => "2-digit",
3414             minute => "2-digit",
3415             month => "2-digit",
3416             second => "2-digit",
3417             },
3418             "en-BZ" => {
3419             day => "2-digit",
3420             hour => "2-digit",
3421             minute => "2-digit",
3422             month => "2-digit",
3423             second => "2-digit",
3424             },
3425             "en-CA" => {
3426             day => "2-digit",
3427             minute => "2-digit",
3428             month => "2-digit",
3429             second => "2-digit",
3430             },
3431             "en-CC" => {
3432             day => "2-digit",
3433             hour => "2-digit",
3434             minute => "2-digit",
3435             month => "2-digit",
3436             second => "2-digit",
3437             },
3438             "en-CH" => {
3439             day => "2-digit",
3440             hour => "2-digit",
3441             minute => "2-digit",
3442             month => "2-digit",
3443             second => "2-digit",
3444             },
3445             "en-CK" => {
3446             day => "2-digit",
3447             hour => "2-digit",
3448             minute => "2-digit",
3449             month => "2-digit",
3450             second => "2-digit",
3451             },
3452             "en-CM" => {
3453             day => "2-digit",
3454             hour => "2-digit",
3455             minute => "2-digit",
3456             month => "2-digit",
3457             second => "2-digit",
3458             },
3459             "en-CX" => {
3460             day => "2-digit",
3461             hour => "2-digit",
3462             minute => "2-digit",
3463             month => "2-digit",
3464             second => "2-digit",
3465             },
3466             "en-DG" => {
3467             day => "2-digit",
3468             hour => "2-digit",
3469             minute => "2-digit",
3470             month => "2-digit",
3471             second => "2-digit",
3472             },
3473             "en-DK" => {
3474             day => "2-digit",
3475             hour => "2-digit",
3476             minute => "2-digit",
3477             month => "2-digit",
3478             second => "2-digit",
3479             },
3480             "en-FI" => {
3481             day => "2-digit",
3482             minute => "2-digit",
3483             month => "2-digit",
3484             second => "2-digit",
3485             },
3486             "en-FK" => {
3487             day => "2-digit",
3488             hour => "2-digit",
3489             minute => "2-digit",
3490             month => "2-digit",
3491             second => "2-digit",
3492             },
3493             "en-GB" => {
3494             day => "2-digit",
3495             hour => "2-digit",
3496             minute => "2-digit",
3497             month => "2-digit",
3498             second => "2-digit",
3499             },
3500             "en-GG" => {
3501             day => "2-digit",
3502             hour => "2-digit",
3503             minute => "2-digit",
3504             month => "2-digit",
3505             second => "2-digit",
3506             },
3507             "en-GI" => {
3508             day => "2-digit",
3509             hour => "2-digit",
3510             minute => "2-digit",
3511             month => "2-digit",
3512             second => "2-digit",
3513             },
3514             "en-HK" => { minute => "2-digit", second => "2-digit" },
3515             "en-IE" => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3516             "en-IL" => {
3517             day => "2-digit",
3518             minute => "2-digit",
3519             month => "2-digit",
3520             second => "2-digit",
3521             },
3522             "en-IM" => {
3523             day => "2-digit",
3524             hour => "2-digit",
3525             minute => "2-digit",
3526             month => "2-digit",
3527             second => "2-digit",
3528             },
3529             "en-IN" => { minute => "2-digit", second => "2-digit" },
3530             "en-IO" => {
3531             day => "2-digit",
3532             hour => "2-digit",
3533             minute => "2-digit",
3534             month => "2-digit",
3535             second => "2-digit",
3536             },
3537             "en-JE" => {
3538             day => "2-digit",
3539             hour => "2-digit",
3540             minute => "2-digit",
3541             month => "2-digit",
3542             second => "2-digit",
3543             },
3544             "en-JM" => {
3545             day => "2-digit",
3546             minute => "2-digit",
3547             month => "2-digit",
3548             second => "2-digit",
3549             },
3550             "en-KE" => {
3551             day => "2-digit",
3552             hour => "2-digit",
3553             minute => "2-digit",
3554             month => "2-digit",
3555             second => "2-digit",
3556             },
3557             "en-MG" => {
3558             day => "2-digit",
3559             hour => "2-digit",
3560             minute => "2-digit",
3561             month => "2-digit",
3562             second => "2-digit",
3563             },
3564             "en-MS" => {
3565             day => "2-digit",
3566             hour => "2-digit",
3567             minute => "2-digit",
3568             month => "2-digit",
3569             second => "2-digit",
3570             },
3571             "en-MT" => {
3572             day => "2-digit",
3573             hour => "2-digit",
3574             minute => "2-digit",
3575             month => "2-digit",
3576             second => "2-digit",
3577             },
3578             "en-MU" => {
3579             day => "2-digit",
3580             hour => "2-digit",
3581             minute => "2-digit",
3582             month => "2-digit",
3583             second => "2-digit",
3584             },
3585             "en-MV" => {
3586             day => "2-digit",
3587             hour => "2-digit",
3588             minute => "2-digit",
3589             month => "2-digit",
3590             second => "2-digit",
3591             },
3592             "en-NF" => {
3593             day => "2-digit",
3594             hour => "2-digit",
3595             minute => "2-digit",
3596             month => "2-digit",
3597             second => "2-digit",
3598             },
3599             "en-NG" => {
3600             day => "2-digit",
3601             hour => "2-digit",
3602             minute => "2-digit",
3603             month => "2-digit",
3604             second => "2-digit",
3605             },
3606             "en-NR" => {
3607             day => "2-digit",
3608             hour => "2-digit",
3609             minute => "2-digit",
3610             month => "2-digit",
3611             second => "2-digit",
3612             },
3613             "en-NU" => {
3614             day => "2-digit",
3615             hour => "2-digit",
3616             minute => "2-digit",
3617             month => "2-digit",
3618             second => "2-digit",
3619             },
3620             "en-NZ" => { minute => "2-digit", month => "2-digit", second => "2-digit" },
3621             "en-PK" => {
3622             day => "2-digit",
3623             minute => "2-digit",
3624             month => "2-digit",
3625             second => "2-digit",
3626             },
3627             "en-PN" => {
3628             day => "2-digit",
3629             hour => "2-digit",
3630             minute => "2-digit",
3631             month => "2-digit",
3632             second => "2-digit",
3633             },
3634             "en-RW" => {
3635             day => "2-digit",
3636             hour => "2-digit",
3637             minute => "2-digit",
3638             month => "2-digit",
3639             second => "2-digit",
3640             },
3641             "en-SC" => {
3642             day => "2-digit",
3643             hour => "2-digit",
3644             minute => "2-digit",
3645             month => "2-digit",
3646             second => "2-digit",
3647             },
3648             "en-SE" => {
3649             day => "2-digit",
3650             hour => "2-digit",
3651             minute => "2-digit",
3652             month => "2-digit",
3653             second => "2-digit",
3654             },
3655             "en-SG" => {
3656             day => "2-digit",
3657             minute => "2-digit",
3658             month => "2-digit",
3659             second => "2-digit",
3660             },
3661             "en-SH" => {
3662             day => "2-digit",
3663             hour => "2-digit",
3664             minute => "2-digit",
3665             month => "2-digit",
3666             second => "2-digit",
3667             },
3668             "en-SX" => {
3669             day => "2-digit",
3670             hour => "2-digit",
3671             minute => "2-digit",
3672             month => "2-digit",
3673             second => "2-digit",
3674             },
3675             "en-TK" => {
3676             day => "2-digit",
3677             hour => "2-digit",
3678             minute => "2-digit",
3679             month => "2-digit",
3680             second => "2-digit",
3681             },
3682             "en-TV" => {
3683             day => "2-digit",
3684             hour => "2-digit",
3685             minute => "2-digit",
3686             month => "2-digit",
3687             second => "2-digit",
3688             },
3689             "en-TZ" => {
3690             day => "2-digit",
3691             hour => "2-digit",
3692             minute => "2-digit",
3693             month => "2-digit",
3694             second => "2-digit",
3695             },
3696             "en-UG" => {
3697             day => "2-digit",
3698             hour => "2-digit",
3699             minute => "2-digit",
3700             month => "2-digit",
3701             second => "2-digit",
3702             },
3703             "en-ZA" => {
3704             day => "2-digit",
3705             hour => "2-digit",
3706             minute => "2-digit",
3707             month => "2-digit",
3708             second => "2-digit",
3709             },
3710             "en-ZW" => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3711             eo => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3712             es => { minute => "2-digit", second => "2-digit" },
3713             "es-419" => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3714             "es-BO" => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3715             "es-BR" => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3716             "es-BZ" => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3717             "es-CL" => {
3718             day => "2-digit",
3719             hour => "2-digit",
3720             minute => "2-digit",
3721             month => "2-digit",
3722             second => "2-digit",
3723             },
3724             "es-CO" => { minute => "2-digit", second => "2-digit" },
3725             "es-DO" => { minute => "2-digit", second => "2-digit" },
3726             "es-GT" => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3727             "es-HN" => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3728             "es-MX" => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3729             "es-PA" => {
3730             day => "2-digit",
3731             minute => "2-digit",
3732             month => "2-digit",
3733             second => "2-digit",
3734             },
3735             "es-PE" => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3736             "es-PH" => { minute => "2-digit", second => "2-digit" },
3737             "es-PR" => {
3738             day => "2-digit",
3739             minute => "2-digit",
3740             month => "2-digit",
3741             second => "2-digit",
3742             },
3743             "es-US" => { minute => "2-digit", second => "2-digit" },
3744             et => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3745             eu => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3746             ewo => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3747             fa => { minute => "2-digit", second => "2-digit" },
3748             ff => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3749             "ff-Adlm" => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3750             "ff-Adlm-GH" => { minute => "2-digit", second => "2-digit" },
3751             "ff-Adlm-GM" => { minute => "2-digit", second => "2-digit" },
3752             "ff-Adlm-LR" => { minute => "2-digit", second => "2-digit" },
3753             "ff-Adlm-MR" => { minute => "2-digit", second => "2-digit" },
3754             "ff-Adlm-SL" => { minute => "2-digit", second => "2-digit" },
3755             "ff-Latn-GH" => { minute => "2-digit", second => "2-digit" },
3756             "ff-Latn-GM" => { minute => "2-digit", second => "2-digit" },
3757             "ff-Latn-LR" => { minute => "2-digit", second => "2-digit" },
3758             "ff-Latn-MR" => { minute => "2-digit", second => "2-digit" },
3759             "ff-Latn-SL" => { minute => "2-digit", second => "2-digit" },
3760             fi => { minute => "2-digit", second => "2-digit" },
3761             fil => { minute => "2-digit", second => "2-digit" },
3762             fo => {
3763             day => "2-digit",
3764             hour => "2-digit",
3765             minute => "2-digit",
3766             month => "2-digit",
3767             second => "2-digit",
3768             },
3769             fr => {
3770             day => "2-digit",
3771             hour => "2-digit",
3772             minute => "2-digit",
3773             month => "2-digit",
3774             second => "2-digit",
3775             },
3776             "fr-BE" => {
3777             day => "2-digit",
3778             hour => "2-digit",
3779             minute => "2-digit",
3780             month => "2-digit",
3781             second => "2-digit",
3782             },
3783             "fr-CA" => {
3784             day => "2-digit",
3785             hour => "2-digit",
3786             minute => "2-digit",
3787             month => "2-digit",
3788             second => "2-digit",
3789             },
3790             "fr-CH" => {
3791             day => "2-digit",
3792             hour => "2-digit",
3793             minute => "2-digit",
3794             month => "2-digit",
3795             second => "2-digit",
3796             },
3797             "fr-DJ" => {
3798             day => "2-digit",
3799             minute => "2-digit",
3800             month => "2-digit",
3801             second => "2-digit",
3802             },
3803             "fr-DZ" => {
3804             day => "2-digit",
3805             minute => "2-digit",
3806             month => "2-digit",
3807             second => "2-digit",
3808             },
3809             "fr-MR" => {
3810             day => "2-digit",
3811             minute => "2-digit",
3812             month => "2-digit",
3813             second => "2-digit",
3814             },
3815             "fr-SY" => {
3816             day => "2-digit",
3817             minute => "2-digit",
3818             month => "2-digit",
3819             second => "2-digit",
3820             },
3821             "fr-TD" => {
3822             day => "2-digit",
3823             minute => "2-digit",
3824             month => "2-digit",
3825             second => "2-digit",
3826             },
3827             "fr-TN" => {
3828             day => "2-digit",
3829             minute => "2-digit",
3830             month => "2-digit",
3831             second => "2-digit",
3832             },
3833             "fr-VU" => {
3834             day => "2-digit",
3835             minute => "2-digit",
3836             month => "2-digit",
3837             second => "2-digit",
3838             },
3839             fur => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3840             fy => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3841             ga => {
3842             day => "2-digit",
3843             hour => "2-digit",
3844             minute => "2-digit",
3845             month => "2-digit",
3846             second => "2-digit",
3847             },
3848             gd => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3849             gl => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3850             gsw => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3851             gu => { minute => "2-digit", second => "2-digit" },
3852             guz => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3853             gv => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3854             ha => {
3855             day => "2-digit",
3856             hour => "2-digit",
3857             minute => "2-digit",
3858             month => "2-digit",
3859             second => "2-digit",
3860             },
3861             "ha-GH" => {
3862             day => "2-digit",
3863             minute => "2-digit",
3864             month => "2-digit",
3865             second => "2-digit",
3866             },
3867             haw => { minute => "2-digit", second => "2-digit" },
3868             he => { minute => "2-digit", second => "2-digit" },
3869             hi => { minute => "2-digit", second => "2-digit" },
3870             "hi-Latn" => { minute => "2-digit", second => "2-digit" },
3871             hr => {
3872             day => "2-digit",
3873             hour => "2-digit",
3874             minute => "2-digit",
3875             month => "2-digit",
3876             second => "2-digit",
3877             },
3878             "hr-BA" => {
3879             day => "2-digit",
3880             hour => "2-digit",
3881             minute => "2-digit",
3882             month => "2-digit",
3883             second => "2-digit",
3884             },
3885             hsb => { minute => "2-digit", second => "2-digit" },
3886             hu => {
3887             day => "2-digit",
3888             minute => "2-digit",
3889             month => "2-digit",
3890             second => "2-digit",
3891             },
3892             hy => {
3893             day => "2-digit",
3894             minute => "2-digit",
3895             month => "2-digit",
3896             second => "2-digit",
3897             },
3898             ia => {
3899             day => "2-digit",
3900             hour => "2-digit",
3901             minute => "2-digit",
3902             month => "2-digit",
3903             second => "2-digit",
3904             },
3905             id => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3906             ig => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3907             ii => {
3908             day => "2-digit",
3909             hour => "2-digit",
3910             minute => "2-digit",
3911             month => "2-digit",
3912             second => "2-digit",
3913             },
3914             is => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3915             it => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3916             "it-CH" => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3917             ja => { minute => "2-digit", second => "2-digit" },
3918             jgo => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3919             jmc => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3920             jv => {
3921             day => "2-digit",
3922             hour => "2-digit",
3923             minute => "2-digit",
3924             month => "2-digit",
3925             second => "2-digit",
3926             },
3927             ka => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3928             kab => { minute => "2-digit", second => "2-digit" },
3929             kam => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3930             kde => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3931             kea => {
3932             day => "2-digit",
3933             hour => "2-digit",
3934             minute => "2-digit",
3935             month => "2-digit",
3936             second => "2-digit",
3937             },
3938             kgp => {
3939             day => "2-digit",
3940             hour => "2-digit",
3941             minute => "2-digit",
3942             month => "2-digit",
3943             second => "2-digit",
3944             },
3945             khq => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3946             ki => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3947             kk => {
3948             day => "2-digit",
3949             hour => "2-digit",
3950             minute => "2-digit",
3951             month => "2-digit",
3952             second => "2-digit",
3953             },
3954             kkj => {
3955             day => "2-digit",
3956             hour => "2-digit",
3957             minute => "2-digit",
3958             month => "2-digit",
3959             second => "2-digit",
3960             },
3961             kl => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3962             kln => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3963             km => { minute => "2-digit", second => "2-digit" },
3964             kn => { minute => "2-digit", second => "2-digit" },
3965             ko => { minute => "2-digit", second => "2-digit" },
3966             kok => { minute => "2-digit", second => "2-digit" },
3967             ks => { minute => "2-digit", second => "2-digit" },
3968             "ks-Deva" => { minute => "2-digit", second => "2-digit" },
3969             ksb => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3970             ksf => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3971             ksh => {
3972             day => "2-digit",
3973             minute => "2-digit",
3974             month => "2-digit",
3975             second => "2-digit",
3976             },
3977             ku => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3978             kw => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3979             ky => {
3980             day => "2-digit",
3981             hour => "2-digit",
3982             minute => "2-digit",
3983             month => "2-digit",
3984             second => "2-digit",
3985             },
3986             lag => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3987             lb => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3988             lg => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3989             lkt => { minute => "2-digit", second => "2-digit" },
3990             ln => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3991             lo => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
3992             "lrc-IQ" => { minute => "2-digit", second => "2-digit" },
3993             lt => {
3994             day => "2-digit",
3995             hour => "2-digit",
3996             minute => "2-digit",
3997             month => "2-digit",
3998             second => "2-digit",
3999             },
4000             lu => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4001             luo => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4002             luy => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4003             lv => {
4004             hour => "2-digit",
4005             minute => "2-digit",
4006             month => "2-digit",
4007             second => "2-digit",
4008             },
4009             mai => { minute => "2-digit", second => "2-digit" },
4010             mas => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4011             mer => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4012             mfe => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4013             mg => {
4014             day => "2-digit",
4015             hour => "2-digit",
4016             minute => "2-digit",
4017             month => "2-digit",
4018             second => "2-digit",
4019             },
4020             mgh => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4021             mgo => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4022             mi => {
4023             day => "2-digit",
4024             minute => "2-digit",
4025             month => "2-digit",
4026             second => "2-digit",
4027             },
4028             mk => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4029             ml => { minute => "2-digit", second => "2-digit" },
4030             mn => {
4031             day => "2-digit",
4032             hour => "2-digit",
4033             minute => "2-digit",
4034             month => "2-digit",
4035             second => "2-digit",
4036             },
4037             mni => { minute => "2-digit", second => "2-digit" },
4038             mr => { minute => "2-digit", second => "2-digit" },
4039             ms => { minute => "2-digit", second => "2-digit" },
4040             "ms-BN" => { minute => "2-digit", second => "2-digit" },
4041             "ms-ID" => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4042             mt => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4043             mua => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4044             my => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4045             naq => { minute => "2-digit", second => "2-digit" },
4046             nd => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4047             ne => {
4048             day => "2-digit",
4049             hour => "2-digit",
4050             minute => "2-digit",
4051             month => "2-digit",
4052             second => "2-digit",
4053             },
4054             "ne-IN" => {
4055             day => "2-digit",
4056             minute => "2-digit",
4057             month => "2-digit",
4058             second => "2-digit",
4059             },
4060             nl => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4061             "nl-BE" => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4062             nmg => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4063             nn => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4064             nnh => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4065             no => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4066             nus => { minute => "2-digit", second => "2-digit" },
4067             nyn => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4068             om => {
4069             day => "2-digit",
4070             minute => "2-digit",
4071             month => "2-digit",
4072             second => "2-digit",
4073             },
4074             "om-KE" => {
4075             day => "2-digit",
4076             hour => "2-digit",
4077             minute => "2-digit",
4078             month => "2-digit",
4079             second => "2-digit",
4080             },
4081             or => { minute => "2-digit", second => "2-digit" },
4082             os => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4083             pa => { minute => "2-digit", second => "2-digit" },
4084             "pa-Arab" => { minute => "2-digit", second => "2-digit" },
4085             pcm => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4086             pl => {
4087             hour => "2-digit",
4088             minute => "2-digit",
4089             month => "2-digit",
4090             second => "2-digit",
4091             },
4092             ps => {
4093             day => "2-digit",
4094             minute => "2-digit",
4095             month => "2-digit",
4096             second => "2-digit",
4097             },
4098             "ps-PK" => {
4099             day => "2-digit",
4100             minute => "2-digit",
4101             month => "2-digit",
4102             second => "2-digit",
4103             },
4104             pt => {
4105             day => "2-digit",
4106             hour => "2-digit",
4107             minute => "2-digit",
4108             month => "2-digit",
4109             second => "2-digit",
4110             },
4111             "pt-MO" => {
4112             day => "2-digit",
4113             minute => "2-digit",
4114             month => "2-digit",
4115             second => "2-digit",
4116             },
4117             "pt-PT" => {
4118             day => "2-digit",
4119             hour => "2-digit",
4120             minute => "2-digit",
4121             month => "2-digit",
4122             second => "2-digit",
4123             },
4124             qu => {
4125             day => "2-digit",
4126             hour => "2-digit",
4127             minute => "2-digit",
4128             month => "2-digit",
4129             second => "2-digit",
4130             },
4131             raj => { minute => "2-digit", second => "2-digit" },
4132             rm => {
4133             day => "2-digit",
4134             hour => "2-digit",
4135             minute => "2-digit",
4136             month => "2-digit",
4137             second => "2-digit",
4138             },
4139             rn => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4140             ro => {
4141             day => "2-digit",
4142             hour => "2-digit",
4143             minute => "2-digit",
4144             month => "2-digit",
4145             second => "2-digit",
4146             },
4147             rof => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4148             ru => {
4149             day => "2-digit",
4150             hour => "2-digit",
4151             minute => "2-digit",
4152             month => "2-digit",
4153             second => "2-digit",
4154             },
4155             rw => {
4156             day => "2-digit",
4157             hour => "2-digit",
4158             minute => "2-digit",
4159             month => "2-digit",
4160             second => "2-digit",
4161             },
4162             rwk => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4163             sa => { minute => "2-digit", second => "2-digit" },
4164             sah => {
4165             day => "2-digit",
4166             hour => "2-digit",
4167             minute => "2-digit",
4168             month => "2-digit",
4169             second => "2-digit",
4170             },
4171             saq => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4172             sat => { minute => "2-digit", second => "2-digit" },
4173             sbp => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4174             sc => {
4175             day => "2-digit",
4176             hour => "2-digit",
4177             minute => "2-digit",
4178             month => "2-digit",
4179             second => "2-digit",
4180             },
4181             sd => {
4182             day => "2-digit",
4183             minute => "2-digit",
4184             month => "2-digit",
4185             second => "2-digit",
4186             },
4187             "sd-Deva" => { minute => "2-digit", second => "2-digit" },
4188             "se-FI" => {
4189             day => "2-digit",
4190             hour => "2-digit",
4191             minute => "2-digit",
4192             month => "2-digit",
4193             second => "2-digit",
4194             },
4195             seh => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4196             ses => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4197             sg => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4198             shi => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4199             "shi-Latn" => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4200             si => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4201             sk => { minute => "2-digit", second => "2-digit" },
4202             sl => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4203             smn => { minute => "2-digit", second => "2-digit" },
4204             sn => {
4205             day => "2-digit",
4206             hour => "2-digit",
4207             minute => "2-digit",
4208             month => "2-digit",
4209             second => "2-digit",
4210             },
4211             so => { minute => "2-digit", second => "2-digit" },
4212             "so-KE" => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4213             sq => { minute => "2-digit", second => "2-digit" },
4214             "sq-MK" => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4215             "sq-XK" => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4216             sr => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4217             "sr-Latn" => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4218             su => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4219             sv => {
4220             day => "2-digit",
4221             hour => "2-digit",
4222             minute => "2-digit",
4223             month => "2-digit",
4224             second => "2-digit",
4225             },
4226             sw => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4227             "sw-KE" => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4228             ta => { minute => "2-digit", second => "2-digit" },
4229             "ta-LK" => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4230             te => { minute => "2-digit", second => "2-digit" },
4231             teo => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4232             tg => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4233             th => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4234             ti => { minute => "2-digit", second => "2-digit" },
4235             "ti-ER" => { minute => "2-digit", second => "2-digit" },
4236             tk => {
4237             day => "2-digit",
4238             hour => "2-digit",
4239             minute => "2-digit",
4240             month => "2-digit",
4241             second => "2-digit",
4242             },
4243             to => { minute => "2-digit", second => "2-digit" },
4244             "tr" => {
4245             day => "2-digit",
4246             hour => "2-digit",
4247             minute => "2-digit",
4248             month => "2-digit",
4249             second => "2-digit",
4250             },
4251             "tr-CY" => {
4252             day => "2-digit",
4253             minute => "2-digit",
4254             month => "2-digit",
4255             second => "2-digit",
4256             },
4257             tt => {
4258             day => "2-digit",
4259             hour => "2-digit",
4260             minute => "2-digit",
4261             month => "2-digit",
4262             second => "2-digit",
4263             },
4264             twq => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4265             tzm => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4266             ug => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4267             uk => {
4268             day => "2-digit",
4269             hour => "2-digit",
4270             minute => "2-digit",
4271             month => "2-digit",
4272             second => "2-digit",
4273             },
4274             ur => { minute => "2-digit", second => "2-digit" },
4275             uz => {
4276             day => "2-digit",
4277             hour => "2-digit",
4278             minute => "2-digit",
4279             month => "2-digit",
4280             second => "2-digit",
4281             },
4282             "uz-Arab" => {
4283             day => "2-digit",
4284             hour => "2-digit",
4285             minute => "2-digit",
4286             month => "2-digit",
4287             second => "2-digit",
4288             },
4289             "uz-Cyrl" => {
4290             day => "2-digit",
4291             hour => "2-digit",
4292             minute => "2-digit",
4293             month => "2-digit",
4294             second => "2-digit",
4295             },
4296             vai => { minute => "2-digit", second => "2-digit" },
4297             "vai-Latn" => { minute => "2-digit", second => "2-digit" },
4298             vi => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4299             vun => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4300             wae => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4301             wo => {
4302             day => "2-digit",
4303             hour => "2-digit",
4304             minute => "2-digit",
4305             month => "2-digit",
4306             second => "2-digit",
4307             },
4308             xh => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4309             xog => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4310             yav => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4311             yi => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4312             yo => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4313             yrl => {
4314             day => "2-digit",
4315             hour => "2-digit",
4316             minute => "2-digit",
4317             month => "2-digit",
4318             second => "2-digit",
4319             },
4320             "yrl-CO" => {
4321             day => "2-digit",
4322             minute => "2-digit",
4323             month => "2-digit",
4324             second => "2-digit",
4325             },
4326             "yrl-VE" => {
4327             day => "2-digit",
4328             minute => "2-digit",
4329             month => "2-digit",
4330             second => "2-digit",
4331             },
4332             yue => { minute => "2-digit", second => "2-digit" },
4333             "yue-Hans" => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4334             zgh => {
4335             day => "2-digit",
4336             hour => "2-digit",
4337             minute => "2-digit",
4338             month => "2-digit",
4339             second => "2-digit",
4340             },
4341             zh => { hour => "2-digit", minute => "2-digit", second => "2-digit" },
4342             "zh-Hans-HK" => { minute => "2-digit", second => "2-digit" },
4343             "zh-Hans-MO" => { minute => "2-digit", second => "2-digit" },
4344             "zh-Hans-SG" => { minute => "2-digit", second => "2-digit" },
4345             "zh-Hant" => { minute => "2-digit", second => "2-digit" },
4346             "zh-Hant-HK" => { minute => "2-digit", second => "2-digit" },
4347             zu => {
4348             day => "2-digit",
4349             hour => "2-digit",
4350             minute => "2-digit",
4351             month => "2-digit",
4352             second => "2-digit",
4353             },
4354             };
4355             }
4356              
4357             # NOTE: DateTime::Format::Intl::Exception class
4358             package DateTime::Format::Intl::Exception;
4359             BEGIN
4360             {
4361 11     11   152 use strict;
  11         23  
  11         443  
4362 11     11   63 use warnings;
  11         25  
  11         842  
4363 11     11   63 use vars qw( $VERSION );
  11         72  
  11         1058  
4364             use overload (
4365             '""' => 'as_string',
4366 0     0   0 bool => sub{ $_[0] },
4367 11         149 fallback => 1,
4368 11     11   69 );
  11         23  
4369 11     11   1611 our $VERSION = 'v0.1.0';
4370             };
4371 11     11   61 use strict;
  11         19  
  11         367  
4372 11     11   50 use warnings;
  11         58  
  11         5692  
4373              
4374             sub new
4375             {
4376 0     0   0 my $this = shift( @_ );
4377 0   0     0 my $self = bless( {} => ( ref( $this ) || $this ) );
4378 0         0 my @info = caller;
4379 0         0 @$self{ qw( package file line ) } = @info[0..2];
4380 0         0 my $args = {};
4381 0 0       0 if( scalar( @_ ) == 1 )
4382             {
4383 0 0 0     0 if( ( ref( $_[0] ) || '' ) eq 'HASH' )
    0 0        
4384             {
4385 0         0 $args = shift( @_ );
4386 0 0       0 if( $args->{skip_frames} )
4387             {
4388 0         0 @info = caller( int( $args->{skip_frames} ) );
4389 0         0 @$self{ qw( package file line ) } = @info[0..2];
4390             }
4391 0   0     0 $args->{message} ||= '';
4392 0         0 foreach my $k ( qw( package file line message code type retry_after ) )
4393             {
4394 0 0       0 $self->{ $k } = $args->{ $k } if( CORE::exists( $args->{ $k } ) );
4395             }
4396             }
4397             elsif( ref( $_[0] ) && $_[0]->isa( 'DateTime::Format::Intl::Exception' ) )
4398             {
4399 0         0 my $o = $args->{object} = shift( @_ );
4400 0         0 $self->{message} = $o->message;
4401 0         0 $self->{code} = $o->code;
4402 0         0 $self->{type} = $o->type;
4403 0         0 $self->{retry_after} = $o->retry_after;
4404             }
4405             else
4406             {
4407 0         0 die( "Unknown argument provided: '", overload::StrVal( $_[0] ), "'" );
4408             }
4409             }
4410             else
4411             {
4412 0 0       0 $args->{message} = join( '', map( ref( $_ ) eq 'CODE' ? $_->() : $_, @_ ) );
4413             }
4414 0         0 return( $self );
4415             }
4416              
4417             # This is important as stringification is called by die, so as per the manual page, we need to end with new line
4418             # And will add the stack trace
4419             sub as_string
4420             {
4421 11     11   87 no overloading;
  11         19  
  11         12832  
4422 0     0   0 my $self = shift( @_ );
4423 0 0 0     0 return( $self->{_cache_value} ) if( $self->{_cache_value} && !CORE::length( $self->{_reset} ) );
4424 0         0 my $str = $self->message;
4425 0         0 $str = "$str";
4426 0         0 $str =~ s/\r?\n$//g;
4427 0   0     0 $str .= sprintf( " within package %s at line %d in file %s", ( $self->{package} // 'undef' ), ( $self->{line} // 'undef' ), ( $self->{file} // 'undef' ) );
      0        
      0        
4428 0         0 $self->{_cache_value} = $str;
4429 0         0 CORE::delete( $self->{_reset} );
4430 0         0 return( $str );
4431             }
4432              
4433 0     0   0 sub code { return( shift->reset(@_)->_set_get_prop( 'code', @_ ) ); }
4434              
4435 0     0   0 sub file { return( shift->reset(@_)->_set_get_prop( 'file', @_ ) ); }
4436              
4437 0     0   0 sub line { return( shift->reset(@_)->_set_get_prop( 'line', @_ ) ); }
4438              
4439 0     0   0 sub message { return( shift->reset(@_)->_set_get_prop( 'message', @_ ) ); }
4440              
4441 0     0   0 sub package { return( shift->reset(@_)->_set_get_prop( 'package', @_ ) ); }
4442              
4443             # From perlfunc docmentation on "die":
4444             # "If LIST was empty or made an empty string, and $@ contains an
4445             # object reference that has a "PROPAGATE" method, that method will
4446             # be called with additional file and line number parameters. The
4447             # return value replaces the value in $@; i.e., as if "$@ = eval {
4448             # $@->PROPAGATE(__FILE__, __LINE__) };" were called."
4449             sub PROPAGATE
4450             {
4451 0     0   0 my( $self, $file, $line ) = @_;
4452 0 0 0     0 if( defined( $file ) && defined( $line ) )
4453             {
4454 0         0 my $clone = $self->clone;
4455 0         0 $clone->file( $file );
4456 0         0 $clone->line( $line );
4457 0         0 return( $clone );
4458             }
4459 0         0 return( $self );
4460             }
4461              
4462             sub reset
4463             {
4464 0     0   0 my $self = shift( @_ );
4465 0 0 0     0 if( !CORE::length( $self->{_reset} ) && scalar( @_ ) )
4466             {
4467 0         0 $self->{_reset} = scalar( @_ );
4468             }
4469 0         0 return( $self );
4470             }
4471              
4472             sub rethrow
4473             {
4474 0     0   0 my $self = shift( @_ );
4475 0 0       0 return if( !ref( $self ) );
4476 0         0 die( $self );
4477             }
4478              
4479 0     0   0 sub retry_after { return( shift->_set_get_prop( 'retry_after', @_ ) ); }
4480              
4481             sub throw
4482             {
4483 0     0   0 my $self = shift( @_ );
4484 0         0 my $e;
4485 0 0       0 if( @_ )
4486             {
4487 0         0 my $msg = shift( @_ );
4488 0         0 $e = $self->new({
4489             skip_frames => 1,
4490             message => $msg,
4491             });
4492             }
4493             else
4494             {
4495 0         0 $e = $self;
4496             }
4497 0         0 die( $e );
4498             }
4499              
4500 0     0   0 sub type { return( shift->reset(@_)->_set_get_prop( 'type', @_ ) ); }
4501              
4502             sub _set_get_prop
4503             {
4504 0     0   0 my $self = shift( @_ );
4505 0   0     0 my $prop = shift( @_ ) || die( "No object property was provided." );
4506 0 0       0 $self->{ $prop } = shift( @_ ) if( @_ );
4507 0         0 return( $self->{ $prop } );
4508             }
4509              
4510             sub FREEZE
4511             {
4512 0     0   0 my $self = CORE::shift( @_ );
4513 0   0     0 my $serialiser = CORE::shift( @_ ) // '';
4514 0         0 my $class = CORE::ref( $self );
4515 0         0 my %hash = %$self;
4516             # Return an array reference rather than a list so this works with Sereal and CBOR
4517             # On or before Sereal version 4.023, Sereal did not support multiple values returned
4518 0 0 0     0 CORE::return( [$class, \%hash] ) if( $serialiser eq 'Sereal' && Sereal::Encoder->VERSION <= version->parse( '4.023' ) );
4519             # But Storable want a list with the first element being the serialised element
4520 0         0 CORE::return( $class, \%hash );
4521             }
4522              
4523 0     0   0 sub STORABLE_freeze { return( shift->FREEZE( @_ ) ); }
4524              
4525 0     0   0 sub STORABLE_thaw { return( shift->THAW( @_ ) ); }
4526              
4527             # NOTE: CBOR will call the THAW method with the stored classname as first argument, the constant string CBOR as second argument, and all values returned by FREEZE as remaining arguments.
4528             # NOTE: Storable calls it with a blessed object it created followed with $cloning and any other arguments initially provided by STORABLE_freeze
4529             sub THAW
4530             {
4531 0     0   0 my( $self, undef, @args ) = @_;
4532 0 0 0     0 my $ref = ( CORE::scalar( @args ) == 1 && CORE::ref( $args[0] ) eq 'ARRAY' ) ? CORE::shift( @args ) : \@args;
4533 0 0 0     0 my $class = ( CORE::defined( $ref ) && CORE::ref( $ref ) eq 'ARRAY' && CORE::scalar( @$ref ) > 1 ) ? CORE::shift( @$ref ) : ( CORE::ref( $self ) || $self );
      0        
4534 0 0       0 my $hash = CORE::ref( $ref ) eq 'ARRAY' ? CORE::shift( @$ref ) : {};
4535 0         0 my $new;
4536             # Storable pattern requires to modify the object it created rather than returning a new one
4537 0 0       0 if( CORE::ref( $self ) )
4538             {
4539 0         0 foreach( CORE::keys( %$hash ) )
4540             {
4541 0         0 $self->{ $_ } = CORE::delete( $hash->{ $_ } );
4542             }
4543 0         0 $new = $self;
4544             }
4545             else
4546             {
4547 0         0 $new = CORE::bless( $hash => $class );
4548             }
4549 0         0 CORE::return( $new );
4550             }
4551              
4552 0     0   0 sub TO_JSON { return( shift->as_string ); }
4553              
4554             {
4555             # NOTE: DateTime::Format::Intl::NullObject class
4556             package
4557             DateTime::Format::Intl::NullObject;
4558             BEGIN
4559 0         0 {
4560 11     11   94 use strict;
  11         35  
  11         357  
4561 11     11   55 use warnings;
  11         19  
  11         846  
4562             use overload (
4563 0     0   0 '""' => sub{ '' },
4564 11         119 fallback => 1,
4565 11     11   69 );
  11         64  
4566 11     11   942 use Want;
  11     0   73  
  11         1033  
4567             };
4568 11     11   118 use strict;
  11         36  
  11         337  
4569 11     11   86 use warnings;
  11         25  
  11         3109  
4570              
4571             sub new
4572             {
4573 0     0   0 my $this = shift( @_ );
4574 0 0       0 my $ref = @_ ? { @_ } : {};
4575 0   0     0 return( bless( $ref => ( ref( $this ) || $this ) ) );
4576             }
4577              
4578             sub AUTOLOAD
4579             {
4580 0     0   0 my( $method ) = our $AUTOLOAD =~ /([^:]+)$/;
4581 0         0 my $self = shift( @_ );
4582 0 0       0 if( Want::want( 'OBJECT' ) )
4583             {
4584 0         0 rreturn( $self );
4585             }
4586             # Otherwise, we return undef; Empty return returns undef in scalar context and empty list in list context
4587 0         0 return;
4588             };
4589             }
4590              
4591             # NOTE: DateTime::Format::Intl::ScoreResult
4592             # This is a private class whose purpose is to contain detailed information about the evaluation of a pattern during scoring, and in particular which fields were missing.
4593             # The information about missing fields is key to whether we need to patch the date and time as specified by the LDML specifications at <https://www.unicode.org/reports/tr35/tr35-dates.html#Missing_Skeleton_Fields>
4594             {
4595             package
4596             DateTime::Format::Intl::ScoreResult;
4597 11     11   122 use strict;
  11         18  
  11         344  
4598 11     11   61 use warnings;
  11         21  
  11         1157  
4599 11     11   71 use vars qw( $DEBUG $ERROR );
  11         60  
  11         640  
4600 11     11   101 use Want;
  11         28  
  11         11436  
4601              
4602             sub new
4603             {
4604 20462     20462   30182 my $this = shift( @_ );
4605 20462   33     72893 my $self = bless( {} => ( ref( $this ) || $this ) );
4606             # Whether there are any missing component that will need to ne appended
4607 20462         48055 $self->{has_missing} = 0;
4608             # The components that will need to be appended
4609 20462         47089 $self->{missing} = [];
4610             # Whether the pattern has components, but not at the right precision, and thus who will need to be adjusted
4611             # By default this value is set to undef, so we can differentiate if it has been set or not: 0 or 1
4612 20462         34997 $self->{need_adjustment} = undef;
4613 20462         33462 $self->{pattern_object} = undef;
4614 20462         32068 $self->{request_object} = undef;
4615 20462         50203 $self->{score} = 0;
4616              
4617 20462         64078 my @args = @_;
4618 20462 50 33     75457 if( scalar( @args ) == 1 &&
    50 33        
4619             defined( $args[0] ) &&
4620             ref( $args[0] ) eq 'HASH' )
4621             {
4622 0         0 my $opts = shift( @args );
4623 0         0 @args = %$opts;
4624             }
4625             elsif( ( scalar( @args ) % 2 ) )
4626             {
4627 0         0 return( $self->error( sprintf( "Uneven number of parameters provided (%d). Should receive key => value pairs. Parameters provided are: %s", scalar( @args ), join( ', ', @args ) ) ) );
4628             }
4629            
4630 20462         47629 for( my $i = 0; $i < scalar( @args ); $i += 2 )
4631             {
4632 102286 50       248727 if( $args[$i] eq 'fatal' )
4633             {
4634 0         0 $self->{fatal} = $args[$i + 1];
4635 0         0 last;
4636             }
4637             }
4638            
4639             # Then, if the user provided with an hash or hash reference of options, we apply them
4640 20462         41677 for( my $i = 0; $i < scalar( @args ); $i++ )
4641             {
4642 102286         135057 my $name = $args[ $i ];
4643 102286         133567 my $val = $args[ ++$i ];
4644 102286         225530 my $meth = $self->can( $name );
4645 102286 50       200407 if( !defined( $meth ) )
    50          
4646             {
4647 0         0 return( $self->error( "Unknown method \"${meth}\" provided." ) );
4648             }
4649             elsif( !defined( $meth->( $self, $val ) ) )
4650             {
4651 0 0 0     0 if( defined( $val ) && $self->error )
4652             {
4653 0         0 return( $self->pass_error );
4654             }
4655             }
4656             }
4657 20462         27289 $self->{has_missing} = scalar( @{$self->{missing}} );
  20462         38141  
4658 20462         66405 return( $self );
4659             }
4660              
4661             sub error
4662             {
4663 0     0   0 my $self = shift( @_ );
4664 0 0       0 if( @_ )
4665             {
4666 0 0       0 my $msg = join( '', map( ( ref( $_ ) eq 'CODE' ) ? $_->() : $_, @_ ) );
4667 0         0 $self->{error} = $ERROR = DateTime::Format::Intl::Exception->new({
4668             skip_frames => 1,
4669             message => $msg,
4670             });
4671 0 0       0 if( $self->fatal )
4672             {
4673 0         0 die( $self->{error} );
4674             }
4675             else
4676             {
4677 0 0       0 warn( $msg ) if( warnings::enabled( 'DateTime::Format::Intl' ) );
4678 0 0       0 if( Want::want( 'ARRAY' ) )
    0          
4679             {
4680 0         0 rreturn( [] );
4681             }
4682             elsif( Want::want( 'OBJECT' ) )
4683             {
4684 0         0 rreturn( DateTime::Format::Intl::NullObject->new );
4685             }
4686 0         0 return;
4687             }
4688             }
4689 0 0       0 return( ref( $self ) ? $self->{error} : $ERROR );
4690             }
4691            
4692 0     0   0 sub fatal { return( shift->_set_get_prop( 'fatal', @_ ) ); }
4693              
4694 745     745   1844 sub has_missing { return( shift->{has_missing} ); }
4695              
4696 21029     21029   47013 sub missing { return( shift->_set_get_prop( 'missing', @_ ) ); }
4697              
4698 21016     21016   37033 sub need_adjustment { return( shift->_set_get_prop( 'need_adjustment', @_ ) ); }
4699              
4700             sub pass_error
4701             {
4702 0     0   0 my $self = shift( @_ );
4703 0 0       0 if( Want::want( 'OBJECT' ) )
4704             {
4705 0         0 rreturn( DateTime::Format::Intl::NullObject->new );
4706             }
4707 0         0 return;
4708             }
4709              
4710 21813     21813   37759 sub pattern_object { return( shift->_set_get_prop( 'pattern_object', @_ ) ); }
4711              
4712 20543     20543   34842 sub request_object { return( shift->_set_get_prop( 'request_object', @_ ) ); }
4713              
4714 40925     40925   67467 sub score { return( shift->_set_get_prop( 'score', @_ ) ); }
4715              
4716             sub _set_get_prop
4717             {
4718 125326     125326   154125 my $self = shift( @_ );
4719 125326   50     221017 my $prop = shift( @_ ) || die( "No object property was provided." );
4720 125326 100       248748 $self->{ $prop } = shift( @_ ) if( @_ );
4721 125326         363902 return( $self->{ $prop } );
4722             }
4723             }
4724              
4725             # NOTE: DateTime::Format::Intl::Skeleton class
4726             # This object is used to represent a user requested skeleton, or an CLDR available skeleton
4727             # For the requested skeleton, there is obviously no pattern
4728             # For the available format there is a subtlety, whereby we have a tokens containing an array of elements representing the pattern, and we also have a skeleton_tokens representing an tokens for the actual skeleton
4729             {
4730             # Hide it from CPAN so it does not get registered
4731             package
4732             DateTime::Format::Intl::Skeleton;
4733 11     11   90 use strict;
  11         22  
  11         316  
4734 11     11   54 use warnings;
  11         18  
  11         600  
4735 11     11   59 use vars qw( $DEBUG $ERROR );
  11         17  
  11         24057  
4736              
4737             sub new
4738             {
4739 21011     21011   31551 my $this = shift( @_ );
4740 21011   33     79571 my $self = bless( {} => ( ref( $this ) || $this ) );
4741 21011         45704 $self->{components} = [];
4742 21011         34891 $self->{date_components} = [];
4743 21011         32901 $self->{is_interval} = 0;
4744 21011         32530 $self->{patched_pattern} = undef;
4745 21011         33701 $self->{patched_skeleton} = undef;
4746 21011         45022 $self->{pattern} = undef;
4747 21011         40786 $self->{pattern_skeleton} = undef;
4748 21011         32522 $self->{skeleton} = undef;
4749 21011         34969 $self->{skeleton_components} = [];
4750 21011         35540 $self->{skeleton_date_components} = [];
4751 21011         41618 $self->{skeleton_time_components} = [];
4752 21011         38732 $self->{skeleton_tokens} = [];
4753 21011         40805 $self->{time_components} = [];
4754 21011         34306 $self->{tokens} = [];
4755 21011         35007 $self->{debug} = $DateTime::Format::Intl::DEBUG;
4756              
4757 21011         76408 my @args = @_;
4758 21011 50 33     86336 if( scalar( @args ) == 1 &&
    50 33        
4759             defined( $args[0] ) &&
4760             ref( $args[0] ) eq 'HASH' )
4761             {
4762 0         0 my $opts = shift( @args );
4763 0         0 @args = %$opts;
4764             }
4765             elsif( ( scalar( @args ) % 2 ) )
4766             {
4767 0         0 return( $self->error( sprintf( "Uneven number of parameters provided (%d). Should receive key => value pairs. Parameters provided are: %s", scalar( @args ), join( ', ', @args ) ) ) );
4768             }
4769              
4770             PREPROCESS:
4771 42022         91660 for( my $i = 0; $i < scalar( @args ); $i += 2 )
4772             {
4773 149281 50       395474 if( $args[$i] eq 'fatal' )
    100          
4774             {
4775 0         0 $self->{fatal} = $args[$i + 1];
4776 0         0 splice( @args, $i, 2 );
4777 0         0 goto PREPROCESS;
4778             }
4779             elsif( $args[$i] eq 'debug' )
4780             {
4781 21011         38488 $self->{debug} = $args[$i + 1];
4782 21011         41307 splice( @args, $i, 2 );
4783 21011         200050 goto PREPROCESS;
4784             }
4785             }
4786            
4787             # Then, if the user provided with an hash or hash reference of options, we apply them
4788 21011         50416 for( my $i = 0; $i < scalar( @args ); $i++ )
4789             {
4790 64135         88874 my $name = $args[ $i ];
4791 64135         92982 my $val = $args[ ++$i ];
4792 64135         156351 my $meth = $self->can( $name );
4793 64135 50       138533 if( !defined( $meth ) )
    100          
4794             {
4795 0         0 return( $self->error( "Unknown method \"${name}\" provided." ) );
4796             }
4797             elsif( !defined( $meth->( $self, $val ) ) )
4798             {
4799 2204 50 33     7232 if( defined( $val ) && $self->error )
4800             {
4801 0         0 return( $self->pass_error );
4802             }
4803             }
4804             }
4805              
4806             # TODO: We always use the option 'pattern_skeleton', so we should consider simplifying this
4807 21011   33     52579 my $pattern_skeleton = $self->{pattern_skeleton} || $self->{skeleton};
4808 21011 50 100     26482 if( scalar( @{$self->{tokens} // []} ) &&
  21011   50     74848  
      0        
      0        
4809 0   0     0 scalar( @{$self->{components} // []} ) &&
4810 0   0     0 scalar( @{$self->{date_components} // []} ) &&
4811 0   0     0 scalar( @{$self->{time_components} // []} ) )
4812             {
4813             }
4814             else
4815             {
4816 21011         46901 my( $tokens, $components, $date_components, $time_components ) = $self->_split_skeleton( $pattern_skeleton );
4817 21011         43044 $self->{tokens} = $tokens;
4818             # Collect the components in the requested skeleton
4819 21011         34170 $self->{components} = $components;
4820 21011         35083 $self->{date_components} = $date_components;
4821 21011         38524 $self->{time_components} = $time_components;
4822             }
4823              
4824 21011 50 50     30873 if( scalar( @{$self->{skeleton_tokens} // []} ) &&
  21011 100 50     109099  
      0        
      0        
4825 0   0     0 scalar( @{$self->{skeleton_components} // []} ) &&
4826 0   0     0 scalar( @{$self->{skeleton_date_components} // []} ) &&
4827 0   0     0 scalar( @{$self->{skeleton_time_components} // []} ) )
4828             {
4829             }
4830             # For datetime format skeletons
4831             elsif( $self->{skeleton} )
4832             {
4833 20460         46962 my( $skel_tokens, $skel_components, $skel_date_components, $skel_time_components ) = $self->_split_skeleton( $self->{skeleton} );
4834 20460         40926 $self->{skeleton_components} = $skel_components;
4835 20460         33235 $self->{skeleton_date_components} = $skel_date_components;
4836 20460         32103 $self->{skeleton_time_components} = $skel_time_components;
4837 20460         35869 $self->{skeleton_tokens} = $skel_tokens;
4838             }
4839 21011         83222 return( $self );
4840             }
4841              
4842             # Array reference of single characters, i.e. component or symbol
4843 20991     20991   40731 sub components { return( shift->_set_get_prop( 'components', @_ ) ); }
4844              
4845 574     574   1633 sub date_components { return( shift->_set_get_prop( 'date_components', @_ ) ); }
4846              
4847             sub error
4848             {
4849 0     0   0 my $self = shift( @_ );
4850 0 0       0 if( @_ )
4851             {
4852 0 0       0 my $msg = join( '', map( ( ref( $_ ) eq 'CODE' ) ? $_->() : $_, @_ ) );
4853 0         0 $self->{error} = $ERROR = DateTime::Format::Intl::Exception->new({
4854             skip_frames => 1,
4855             message => $msg,
4856             });
4857 0 0       0 if( $self->fatal )
4858             {
4859 0         0 die( $self->{error} );
4860             }
4861             else
4862             {
4863 0 0       0 warn( $msg ) if( warnings::enabled( 'DateTime::Format::Intl' ) );
4864 0 0       0 if( Want::want( 'ARRAY' ) )
    0          
4865             {
4866 0         0 rreturn( [] );
4867             }
4868             elsif( Want::want( 'OBJECT' ) )
4869             {
4870 0         0 rreturn( DateTime::Format::Intl::NullObject->new );
4871             }
4872 0         0 return;
4873             }
4874             }
4875 0 0       0 return( ref( $self ) ? $self->{error} : $ERROR );
4876             }
4877            
4878 0     0   0 sub fatal { return( shift->_set_get_prop( 'fatal', @_ ) ); }
4879              
4880 0     0   0 sub is_interval { return( shift->_set_get_prop( 'is_interval', @_ ) ); }
4881              
4882             sub pass_error
4883             {
4884 0     0   0 my $self = shift( @_ );
4885 0 0       0 if( Want::want( 'OBJECT' ) )
4886             {
4887 0         0 rreturn( DateTime::Format::Intl::NullObject->new );
4888             }
4889 0         0 return;
4890             }
4891              
4892             # If the resulting best pattern has missing components, as per the LDML, it is patched
4893             # If it has been patched, this returns the patched pattern; undef by default
4894 0     0   0 sub patched_pattern { return( shift->_set_get_prop( 'patched_pattern', @_ ) ); }
4895              
4896             # Same as patched_pattern, but for skeleton
4897 0     0   0 sub patched_skeleton { return( shift->_set_get_prop( 'patched_skeleton', @_ ) ); }
4898              
4899             # The actual pattern
4900 41621     41621   85561 sub pattern { return( shift->_set_get_prop( 'pattern', @_ ) ); }
4901              
4902             # This is the skeleton derived from the pattern, so it does not necessarily match the actual skeleton
4903 62442     62442   111055 sub pattern_skeleton { return( shift->_set_get_prop( 'pattern_skeleton', @_ ) ); }
4904              
4905             # Real skeleton from Unicode CLDR
4906             # It may be empty if this object is used for representing the user requested options
4907 21013     21013   48815 sub skeleton { return( shift->_set_get_prop( 'skeleton', @_ ) ); }
4908              
4909             # For datetime format skeletons: array reference of single characters, i.e. component or symbol
4910 0     0   0 sub skeleton_components { return( shift->_set_get_prop( 'skeleton_components', @_ ) ); }
4911              
4912 0     0   0 sub skeleton_date_components { return( shift->_set_get_prop( 'skeleton_date_components', @_ ) ); }
4913              
4914 0     0   0 sub skeleton_time_components { return( shift->_set_get_prop( 'skeleton_time_components', @_ ) ); }
4915              
4916             # For datetime format skeletons: the array reference of tokens for the skeleton (not the pattern skeleton), i.e. each array entry is an hash with the properties 'component', 'len' and 'token'
4917 20521     20521   36692 sub skeleton_tokens { return( shift->_set_get_prop( 'skeleton_tokens', @_ ) ); }
4918              
4919 574     574   1513 sub time_components { return( shift->_set_get_prop( 'time_components', @_ ) ); }
4920              
4921             # The array reference of tokens, i.e. each array entry is an hash with the properties 'component', 'len' and 'token'
4922 42063     42063   70462 sub tokens { return( shift->_set_get_prop( 'tokens', @_ ) ); }
4923              
4924             sub _set_get_prop
4925             {
4926 209799     209799   259665 my $self = shift( @_ );
4927 209799   50     376535 my $prop = shift( @_ ) || die( "No object property was provided." );
4928 209799 100       389277 $self->{ $prop } = shift( @_ ) if( @_ );
4929 209799         535927 return( $self->{ $prop } );
4930             }
4931              
4932             sub _split_skeleton
4933             {
4934 41471     41471   59520 my $self = shift( @_ );
4935 41471         57010 my $skel = shift( @_ );
4936 41471         101683 $skel =~ s/[^a-zA-Z]+//g;
4937 41471         55440 my $tokens = [];
4938 41471         51250 my $components = [];
4939 41471         301748 my $date_elements =
4940             {
4941             'c' => 1,
4942             'd' => 1,
4943             'D' => 1,
4944             'e' => 1,
4945             'E' => 1,
4946             'F' => 1,
4947             'g' => 1,
4948             'G' => 1,
4949             'L' => 1,
4950             'M' => 1,
4951             'q' => 1,
4952             'Q' => 1,
4953             'r' => 1,
4954             'u' => 1,
4955             'U' => 1,
4956             'w' => 1,
4957             'W' => 1,
4958             'y' => 1,
4959             'Y' => 1,
4960             };
4961 41471         231112 my $time_elements =
4962             {
4963             'h' => 1,
4964             'H' => 1,
4965             'j' => 1,
4966             'k' => 1,
4967             'K' => 1,
4968             'm' => 1,
4969             'O' => 1,
4970             's' => 1,
4971             'S' => 1,
4972             'v' => 1,
4973             'V' => 1,
4974             'x' => 1,
4975             'X' => 1,
4976             'z' => 1,
4977             'Z' => 1,
4978             };
4979 41471         56393 my $date_components = [];
4980 41471         55688 my $time_components = [];
4981 41471         117896 foreach my $component ( split( //, $skel ) )
4982             {
4983 156321 100 100     426430 if( scalar( @$tokens ) &&
4984             $tokens->[-1]->{component} eq $component )
4985             {
4986 39750         72764 $tokens->[-1]->{token} .= $component;
4987             }
4988             else
4989             {
4990 116571 100       254386 if( exists( $time_elements->{ $component } ) )
    100          
4991             {
4992 38565         69080 push( @$time_components, $component );
4993             }
4994             elsif( exists( $date_elements->{ $component } ) )
4995             {
4996 70637         126594 push( @$date_components, $component );
4997             }
4998 116571         178739 push( @$components, $component );
4999 116571 100       272967 $tokens->[-1]->{len} = length( $tokens->[-1]->{token} ) if( scalar( @$tokens ) );
5000 116571         357533 push( @$tokens, { component => $component, token => $component });
5001             }
5002             }
5003 41471 50       135486 $tokens->[-1]->{len} = length( $tokens->[-1]->{token} ) if( scalar( @$tokens ) );
5004 41471         263621 return( $tokens, $components, $date_components, $time_components );
5005             }
5006             }
5007              
5008             1;
5009             # NOTE: POD
5010             __END__
5011              
5012             =encoding utf-8
5013              
5014             =head1 NAME
5015              
5016             DateTime::Format::Intl - A Web Intl.DateTimeFormat Class Implementation
5017              
5018             =head1 SYNOPSIS
5019              
5020             use DateTime;
5021             use DateTime::Format::Intl;
5022             my $dt = DateTime->now;
5023             my $fmt = DateTime::Format::Intl->new(
5024             # You can use ja-JP (Unicode / web-style) or ja_JP (system-style), it does not matter.
5025             'ja_JP', {
5026             localeMatcher => 'best fit',
5027             # The only one supported. You can use 'gregory' or 'gregorian' indifferently
5028             calendar => 'gregorian',
5029             # see getNumberingSystems() in Locale::Intl for the supported number systems
5030             numberingSystem => 'latn',
5031             formatMatcher => 'best fit',
5032             dateStyle => 'long',
5033             timeStyle => 'long',
5034             },
5035             ) || die( DateTime::Format::Intl->error );
5036             say $fmt->format( $dt );
5037              
5038             my $fmt = DateTime::Format::Intl->new(
5039             # You can also use ja-JP (Unicode / web-style) or ja_JP (system-style), it does not matter.
5040             'ja_JP', {
5041             localeMatcher => 'best fit',
5042             # The only one supported
5043             calendar => 'gregorian',
5044             numberingSystem => 'latn',
5045             hour12 => 0,
5046             timeZone => 'Asia/Tokyo',
5047             weekday => 'long',
5048             era => 'short',
5049             year => 'numeric',
5050             month => '2-digit',
5051             day => '2-digit',
5052             dayPeriod => 'long',
5053             hour => '2-digit',
5054             minute => '2-digit',
5055             second => '2-digit',
5056             fractionalSecondDigits => 3,
5057             timeZoneName => 'long',
5058             formatMatcher => 'best fit',
5059             },
5060             ) || die( DateTime::Format::Intl->error );
5061             say $fmt->format( $dt );
5062              
5063             In basic use without specifying a locale, C<DateTime::Format::Intl> uses the default locale and default options:
5064              
5065             use DateTime;
5066             my $date = DateTime->new(
5067             year => 2012,
5068             month => 11,
5069             day => 20,
5070             hour => 3,
5071             minute => 0,
5072             second => 0,
5073             # Default
5074             time_zone => 'UTC',
5075             );
5076             # toLocaleString without arguments depends on the implementation,
5077             # the default locale, and the default time zone
5078             say DateTime::Format::Intl->new->format( $date );
5079             # "12/19/2012" if run with en-US locale (language) and time zone America/Los_Angeles (UTC-0800)
5080              
5081             Using C<timeStyle> and C<dateStyle>:
5082              
5083             Possible values are: C<full>, C<long>, C<medium> and C<short>
5084              
5085             my $now = DateTime->new(
5086             year => 2024,
5087             month => 9,
5088             day => 13,
5089             hour => 14,
5090             minute => 12,
5091             second => 10,
5092             time_zone => 'Europe/Paris',
5093             );
5094             my $shortTime = DateTime::Format::Intl->new('en', {
5095             timeStyle => 'short',
5096             });
5097             say $shortTime->format( $now ); # "2:12 PM"
5098            
5099             my $shortDate = DateTime::Format::Intl->new('en', {
5100             dateStyle => 'short',
5101             });
5102             say $shortDate->format( $now ); # "09/13/24"
5103            
5104             my $mediumTime = DateTime::Format::Intl->new('en', {
5105             timeStyle => 'medium',
5106             dateStyle => 'short',
5107             });
5108             say $mediumTime->format( $now ); # "09/13/24, 2:12:10 PM"
5109              
5110             my $shortDate = DateTime::Format::Intl->new('en', {
5111             dateStyle => 'medium',
5112             });
5113             say $shortDate->format( $now ); # "13 Sep 2024"
5114              
5115             my $shortDate = DateTime::Format::Intl->new('en', {
5116             dateStyle => 'long',
5117             });
5118             say $shortDate->format( $now ); # "September 13, 2024"
5119              
5120             my $shortDate = DateTime::Format::Intl->new('en', {
5121             dateStyle => 'long',
5122             timeStyle => 'long',
5123             });
5124             say $shortDate->format( $now ); # "September 13, 2024 at 2:12:10 PM GMT+1"
5125              
5126             my $shortDate = DateTime::Format::Intl->new('en', {
5127             dateStyle => 'full',
5128             });
5129             say $shortDate->format( $now ); # "Friday, September 13, 2024"
5130              
5131             my $shortDate = DateTime::Format::Intl->new('en', {
5132             dateStyle => 'full',
5133             timeStyle => 'full',
5134             });
5135             say $shortDate->format( $now ); # "Friday, September 13, 2024 at 2:12:10 PM Central European Standard Time"
5136              
5137             Using C<dayPeriod>:
5138              
5139             Use the C<dayPeriod> option to output a string for the times of day (C<in the morning>, C<at night>, C<noon>, etc.). Note, that this only works when formatting for a 12 hour clock (C<< hourCycle => 'h12' >> or C<< hourCycle => 'h11' >>) and that for many locales the strings are the same irrespective of the value passed for the C<dayPeriod>.
5140              
5141             my $date = DateTime->new(
5142             year => 2012,
5143             month => 11,
5144             day => 17,
5145             hour => 4,
5146             minute => 0,
5147             second => 42,
5148             # Default
5149             time_zone => 'UTC',
5150             );
5151              
5152             say DateTime::Format::Intl->new( 'en-GB', {
5153             hour => 'numeric',
5154             hourCycle => 'h12',
5155             dayPeriod => 'short',
5156             # or 'time_zone' is ok too
5157             timeZone => 'UTC',
5158             })->format( $date );
5159             # "4 at night" (same formatting in en-GB for all dayPeriod values)
5160              
5161             say DateTime::Format::Intl->new( 'fr', {
5162             hour => 'numeric',
5163             hourCycle => 'h12',
5164             dayPeriod => 'narrow',
5165             # or 'time_zone' is ok too
5166             timeZone => 'UTC',
5167             })->format( $date );
5168             # "4 mat." (same output in French for both narrow/short dayPeriod)
5169              
5170             say DateTime::Format::Intl->new( 'fr', {
5171             hour => 'numeric',
5172             hourCycle => 'h12',
5173             dayPeriod => 'long',
5174             # or 'time_zone' is ok too
5175             timeZone => 'UTC',
5176             })->format( $date );
5177             # "4 du matin"
5178              
5179             Using C<timeZoneName>:
5180              
5181             Use the C<timeZoneName> option to output a string for the C<timezone> (C<GMT>, C<Pacific Time>, etc.).
5182              
5183             my $date = DateTime->new(
5184             year => 2021,
5185             month => 11,
5186             day => 17,
5187             hour => 3,
5188             minute => 0,
5189             second => 42,
5190             # Default
5191             time_zone => 'UTC',
5192             );
5193             my $timezoneNames = [qw(
5194             short
5195             long
5196             shortOffset
5197             longOffset
5198             shortGeneric
5199             longGeneric
5200             )];
5201              
5202             foreach my $zoneName ( @$timezoneNames )
5203             {
5204             # Do something with currentValue
5205             my $formatter = DateTime::Format::Intl->new( 'en-US', {
5206             timeZone => 'America/Los_Angeles',
5207             timeZoneName => $zoneName,
5208             });
5209             say "${zoneName}: ", $formatter->format( $date);
5210             }
5211              
5212             # Yields the following:
5213             # short: 12/16/2021, PST
5214             # long: 12/16/2021, Pacific Standard Time
5215             # shortOffset: 12/16/2021, GMT-8
5216             # longOffset: 12/16/2021, GMT-08:00
5217             # shortGeneric: 12/16/2021, PT
5218             # longGeneric: 12/16/2021, Pacific Time
5219              
5220             # Enabling fatal exceptions
5221             use v5.34;
5222             use experimental 'try';
5223             no warnings 'experimental';
5224             try
5225             {
5226             my $fmt = DateTime::Format::Intl->new( 'x', fatal => 1 );
5227             # More code
5228             }
5229             catch( $e )
5230             {
5231             say "Oops: ", $e->message;
5232             }
5233              
5234             Or, you could set the global variable C<$FATAL_EXCEPTIONS> instead:
5235              
5236             use v5.34;
5237             use experimental 'try';
5238             no warnings 'experimental';
5239             local $DateTime::Format::Intl::FATAL_EXCEPTIONS = 1;
5240             try
5241             {
5242             my $fmt = DateTime::Format::Intl->new( 'x' );
5243             # More code
5244             }
5245             catch( $e )
5246             {
5247             say "Oops: ", $e->message;
5248             }
5249              
5250             =head1 VERSION
5251              
5252             v0.1.8
5253              
5254             =head1 DESCRIPTION
5255              
5256             This module provides the equivalent of the JavaScript implementation of L<Intl.DateTimeFormat|https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Intl/DateTimeFormat>
5257              
5258             It relies on L<DateTime::Format::Unicode>, L<DateTime::Locale::FromCLDR>, L<Locale::Unicode::Data>, which provides access to all the L<Unicode CLDR (Common Locale Data Repository)|https://cldr.unicode.org/>, and L<Locale::Intl> to achieve similar results. It requires perl v5.10.1 minimum to run.
5259              
5260             It is very elaborate and the algorithm provides the same result you would get with a web browser. The algorithm itself is quite complex and took me several months to implement, given all the dependencies with the modules aforementioned it relies on, that I also had to build to make the whole thing work.
5261              
5262             I hope they will benefit you as they benefit me.
5263              
5264             Because, just like its JavaScript equivalent, C<DateTime::Format::Intl> does quite a bit of look-ups and sensible guessing upon object instantiation, you want to create an object for a specific format, cache it and re-use it rather than creating a new one for each date formatting.
5265              
5266             C<DateTime::Format::Intl> uses a set of culturally sensible default values derived directly from the web browsers own default. Upon object instantiation, it uses a culturally sensitive scoring to find the best matching format pattern available in the Unicode CLDR (Common Locale Data Repository) data for the options provided. It L<appends any missing components|https://www.unicode.org/reports/tr35/tr35-dates.html#Missing_Skeleton_Fields>, if any. Finally, it adjusts the best pattern retained to match perfectly the options of the user.
5267              
5268             =head1 CONSTRUCTOR
5269              
5270             =head2 new
5271              
5272             This takes a C<locale> (a.k.a. language C<code> compliant with L<ISO 15924|https://en.wikipedia.org/wiki/ISO_15924> as defined by L<IETF|https://en.wikipedia.org/wiki/IETF_language_tag#Syntax_of_language_tags>) and an hash or hash reference of options and will return a new L<DateTime::Format::Intl> object, or upon failure C<undef> in scalar context and an empty list in list context.
5273              
5274             Each option can also be accessed or changed using their corresponding method of the same name.
5275              
5276             See the L<CLDR (Unicode Common Locale Data Repository) page|https://cldr.unicode.org/translation/date-time/date-time-patterns> for more on the format patterns used.
5277              
5278             Supported options are:
5279              
5280             =head3 Locale options
5281              
5282             =over 4
5283              
5284             =item * C<localeMatcher>
5285              
5286             The locale matching algorithm to use. Possible values are C<lookup> and C<best fit>; the default is C<best fit>. For information about this option, see L<Locale identification and negotiation|https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Intl#locale_identification_and_negotiation>.
5287              
5288             Whatever value you provide, does not actually have any influence on the algorithm used. C<best fit> will always be the one used.
5289              
5290             =item * C<calendar>
5291              
5292             The calendar to use, such as C<chinese>, C<gregorian> (or C<gregory>), C<persian>, and so on. For a list of calendar types, see L<Intl.Locale.prototype.getCalendars()|https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Intl/Locale/getCalendars#supported_calendar_types>, and the method L<getAllCalendars|Locale::Intl/getAllCalendars> in the perl module L<Locale::Intl>. This option can also be set through the C<ca> Unicode extension key; if both are provided, this options property takes precedence. See L<Locale::Unicode/ca>
5293              
5294             For example, a Japanese locale with the C<japanese> calendar extension set:
5295              
5296             my $fmt = DateTime::Format::Intl->new( 'ja-Kana-JP-u-ca-japanese' );
5297              
5298             The only value calendar type supported by this module is C<gregorian>. Any other value will return an error.
5299              
5300             =item * C<numberingSystem>
5301              
5302             The numbering system to use for number formatting, such as C<fullwide>, C<hant>, C<mathsans>, and so on. For a list of supported numbering system types, see L<getNumberingSystems()|Locale::Intl/getNumberingSystems>. This option can also be set through the L<nu|Locale::Unicode/nu> Unicode extension key; if both are provided, this options property takes precedence.
5303              
5304             For example, a Japanese locale with the C<latn> number system extension set and with the C<jptyo> time zone:
5305              
5306             my $fmt = DateTime::Format::Intl->new( 'ja-u-nu-latn-tz-jptyo' );
5307              
5308             However, note that you can only provide a number system that is supported by the C<locale>, and whose type is C<numeric>, i.e. not C<algorithmic>. For instance, you cannot specify a C<locale> C<ar-SA> (arab as spoken in Saudi Arabia) with a number system of Japan:
5309              
5310             my $fmt = DateTime::Format::Intl->new( 'ar-SA', { numberingSystem => 'japn' } );
5311             say $fmt->resolvedOptions->{numberingSystem}; # arab
5312              
5313             It would reject it, and issue a warning, if warnings are enabled, and fallback to the C<locale>'s default number system, which is, in this case, C<arab>
5314              
5315             Additionally, even though the number system C<jpanfin> is supported by the locale C<ja>, it would not be acceptable, because it is not suitable for datetime formatting, since it is not of type C<numeric>, or at least this is how it is treated by web browsers (see L<here the web browser engine implementation|https://github.com/v8/v8/blob/main/src/objects/intl-objects.cc> and L<here for the Unicode ICU implementation|https://github.com/unicode-org/icu/blob/main/icu4c/source/i18n/numsys.cpp>). This API could easily make it acceptable, but it was designed to closely mimic the web browser implementation of the JavaScript API C<Intl.DateTimeFormat>. Thus:
5316              
5317             my $fmt = DateTime::Format::Intl->new( 'ja-u-nu-jpanfin-tz-jptyo' );
5318             say $fmt->resolvedOptions->{numberingSystem}; # latn
5319              
5320             See L<Mozilla documentation|https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Intl/Locale/getNumberingSystems>, and also the perl module L<Locale::Intl>
5321              
5322             =item * C<hour12>
5323              
5324             Whether to use 12-hour time (as opposed to 24-hour time). Possible values are C<true> (C<1>) and C<false> (C<0>); the default is locale dependent. When C<true>, this option sets C<hourCycle> to either C<h11> or C<h12>, depending on the locale. When C<false>, it sets hourCycle to C<h23>. C<hour12> overrides both the hc locale extension tag and the C<hourCycle> option, should either or both of those be present.
5325              
5326             =item * C<hourCycle>
5327              
5328             The hour cycle to use. Possible values are C<h11>, C<h12>, C<h23>, and C<h24>. This option can also be set through the C<hc> Unicode extension key; if both are provided, this options property takes precedence.
5329              
5330             See L<Mozilla documentation|https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Intl/DateTimeFormat/DateTimeFormat#hourcycle>
5331              
5332             =item * C<timeZone>
5333              
5334             The time zone to use. Time zone names correspond to the Zone and Link names of the L<IANA Time Zone Database|https://www.iana.org/time-zones>, such as C<UTC>, C<Asia/Tokyo>, C<Asia/Kolkata>, and C<America/New_York>. Additionally, time zones can be given as UTC offsets in the format C<±hh:mm>, C<±hhmm>, or C<±hh>, for example as C<+01:00>, C<-2359>, or C<+23>. The default is the runtime's default time zone.
5335              
5336             See L<Mozilla documentation|https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Intl/DateTimeFormat/DateTimeFormat#timezone>
5337              
5338             =back
5339              
5340             =head3 Date-time component options
5341              
5342             =over 4
5343              
5344             =item * C<weekday>
5345              
5346             The representation of the weekday. Possible values are:
5347              
5348             =over 8
5349              
5350             =item * C<long>
5351              
5352             For example: C<Thursday>
5353              
5354             =item * C<short>
5355              
5356             For example: C<Thu>
5357              
5358             =item * C<narrow>
5359              
5360             For example: C<T>
5361              
5362             Two weekdays may have the same narrow style for some locales (e.g. C<Tuesday>'s narrow style is also C<T>).
5363              
5364             =back
5365              
5366             =item * C<era>
5367              
5368             The representation of the era. Possible values are:
5369              
5370             =over 8
5371              
5372             =item * C<long>
5373              
5374             For example: C<Anno Domini>
5375              
5376             =item * C<short>
5377              
5378             For example: C<AD>
5379              
5380             =item * C<narrow>
5381              
5382             For example: C<A>
5383              
5384             =back
5385              
5386             =item * C<year>
5387              
5388             The representation of the year. Possible values are C<numeric> and C<2-digit>.
5389              
5390             =item * C<month>
5391              
5392             The representation of the month. Possible values are:
5393              
5394             =over 8
5395              
5396             =item * C<numeric>
5397              
5398             For example: C<3>
5399              
5400             =item * C<2-digit>
5401              
5402             For example: C<03>
5403              
5404             =item * C<long>
5405              
5406             For example: C<March>
5407              
5408             =item * C<short>
5409              
5410             For example: C<Mar>
5411              
5412             =item * C<narrow>
5413              
5414             For example: C<M>.
5415              
5416             Two months may have the same narrow style for some locales (e.g. C<May>'s narrow style is also C<M>).
5417              
5418             =back
5419              
5420             =item * C<day>
5421              
5422             The representation of the day. Possible values are C<numeric> and C<2-digit>.
5423              
5424             =item * C<dayPeriod> or C<day_period>
5425              
5426             The formatting style used for day periods like C<in the morning>, C<am>, C<noon>, C<n> etc. Possible values are C<narrow>, C<short>, and C<long>.
5427              
5428             Note: This option only has an effect if a 12-hour clock (C<hourCycle>: C<h12> or C<hourCycle>: C<h11>) is used. Many locales use the same string irrespective of the width specified.
5429              
5430             =item * C<hour>
5431              
5432             The representation of the hour. Possible values are C<numeric> and C<2-digit>.
5433              
5434             =item * C<minute>
5435              
5436             The representation of the minute. Possible values are C<numeric> and C<2-digit>.
5437              
5438             =item * C<second>
5439              
5440             The representation of the second. Possible values are C<numeric> and C<2-digit>.
5441              
5442             =item * C<fractionalSecondDigits>
5443              
5444             The number of digits used to represent fractions of a second (any additional digits are truncated). Possible values are from C<1> to C<3>.
5445              
5446             =item * C<timeZoneName>
5447              
5448             The localized representation of the time zone name. Possible values are:
5449              
5450             =over 8
5451              
5452             =item * C<long>
5453              
5454             Long localized form (e.g., C<Pacific Standard Time>, C<Nordamerikanische Westküsten-Normalzeit>)
5455              
5456             =item * C<short>
5457              
5458             Short localized form (e.g.: C<PST>, C<GMT-8>)
5459              
5460             =item * C<shortOffset>
5461              
5462             Short localized GMT format (e.g., C<GMT-8>)
5463              
5464             =item * C<longOffset>
5465              
5466             Long localized GMT format (e.g., C<GMT-08:00>)
5467              
5468             =item * C<shortGeneric>
5469              
5470             Short generic non-location format (e.g.: C<PT>, C<Los Angeles Zeit>).
5471              
5472             =item * C<longGeneric>
5473              
5474             Long generic non-location format (e.g.: C<Pacific Time>, C<Nordamerikanische Westküstenzeit>)
5475              
5476             The default value for each date-time component option is C<undef>, but if all component properties are C<undef>, then C<year>, C<month>, and C<day> default to C<numeric>. If any of the date-time component options is specified, then C<dateStyle> and C<timeStyle> must be C<undef>.
5477              
5478             =back
5479              
5480             =item * C<formatMatcher>
5481              
5482             The format matching algorithm to use. Possible values are C<basic> and C<best fit>; the default is C<best fit>.
5483              
5484             Whatever value you provide, does not actually have any influence on the algorithm used. C<best fit> will always be the one used.
5485              
5486             Implementations are required to support displaying at least the following subsets of date-time components:
5487              
5488             =over 8
5489              
5490             =item * C<weekday>, C<year>, C<month>, C<day>, C<hour>, C<minute>, C<second>
5491              
5492             =item * C<weekday>, C<year>, C<month>, C<day>
5493              
5494             =item * C<year>, C<month>, C<day>
5495              
5496             =item * C<year>, C<month>
5497              
5498             =item * C<month>, C<day>
5499              
5500             =item * C<hour>, C<minute>, C<second>
5501              
5502             =item * C<hour>, C<minute>>
5503              
5504             =back
5505              
5506             Implementations may support other subsets, and requests will be negotiated against all available subset-representation combinations to find the best match. The algorithm for C<best fit> is implementation-defined, and C<basic> is defined by the spec. This option is only used when both C<dateStyle> and C<timeStyle> are undefined (so that each date-time component's format is individually customizable).
5507              
5508             =back
5509              
5510             =head3 Style shortcuts
5511              
5512             =over 4
5513              
5514             =item * C<dateStyle>
5515              
5516             The date formatting style to use when calling C<format()>. Possible values are C<full>, C<long>, C<medium>, and C<short>.
5517              
5518             =item * C<timeStyle>
5519              
5520             The time formatting style to use when calling C<format()>. Possible values are C<full>, C<long>, C<medium>, and C<short>.
5521              
5522             =back
5523              
5524             Note: C<dateStyle> and C<timeStyle> can be used with each other, but not with other date-time component options (e.g. C<weekday>, C<hour>, C<month>, etc.).
5525              
5526             =head1 METHODS
5527              
5528             =head2 format
5529              
5530             my $options =
5531             {
5532             weekday => 'long',
5533             year => 'numeric',
5534             month => 'long',
5535             day => 'numeric',
5536             };
5537             my $date = DateTime->new(
5538             year => 2012,
5539             month => 6,
5540             day => 1,
5541             time_zone => 'UTC',
5542             );
5543            
5544             my $dateTimeFormat1 = DateTime::Format::Intl->new('sr-RS', $options);
5545             say $dateTimeFormat1->format( $date );
5546             # Expected output: "петак, 1. јун 2012."
5547            
5548             my $dateTimeFormat2 = DateTime::Format::Intl->new('en-GB', $options);
5549             say $dateTimeFormat2->format( $date );
5550             # Expected output: "Friday, 1 June 2012"
5551            
5552             my $dateTimeFormat3 = DateTime::Format::Intl->new('en-US', $options);
5553             say $dateTimeFormat3->format( $date );
5554             # Expected output: "Friday, June 1, 2012"
5555              
5556             This takes a L<DateTime> object, and returns a string representing the given date formatted according to the C<locale> and formatting options of this C<DateTime::Format::Intl> object.
5557              
5558             =head2 format_range
5559              
5560             Same as L<formatRange|/formatRange>
5561              
5562             =head2 format_range_to_parts
5563              
5564             Same as L<formatRangeToParts|/formatRangeToParts>
5565              
5566             =head2 format_to_parts
5567              
5568             Same as L<formatToParts|/formatToParts>
5569              
5570             =head2 formatRange
5571              
5572             my $d1 = DateTime->new(
5573             year => 2024,
5574             month => 5,
5575             day => 10,
5576             hour => 13,
5577             minute => 0,
5578             second => 0,
5579             );
5580             my $d2 = DateTime->new(
5581             year => 2024,
5582             month => 5,
5583             day => 11,
5584             hour => 14,
5585             minute => 0,
5586             second => 0,
5587             );
5588             my $fmt = DateTime::Format::Intl->new( 'fr-FR' );
5589             say $fmt->formatRange( $d1 => $d2 ); # 10/05/2024 - 11/05/2024
5590              
5591             my $fmt2 = DateTime::Format::Intl->new( 'ja-JP' );
5592             say $fmt2->formatRange( $d1 => $d2 ); # 2024/05/10~2024/05/11
5593              
5594             my $fmt3 = DateTime::Format::Intl->new( 'fr-FR', {
5595             weekday => 'long',
5596             year => 'numeric',
5597             month => 'long',
5598             day => 'numeric',
5599             });
5600             say $fmt3->formatRange( $d1 => $d2 ); # vendredi 10 mai 2024 - samedi 11 mai 2024
5601              
5602             This C<formatRange()> method takes 2 L<DateTime> objects, and formats the range between 2 dates and returns a string.
5603              
5604             The format used is the most concise way based on the locales and options provided when instantiating the new L<DateTime::Format::Intl> object. When no option were provided upon object instantiation, it default to a short version of the date format using L<date_format_short|DateTime::Locale::FromCLDR/date_format_short>), which, in turn, gets interpreted in various formats depending on the locale chosen. In British English, this would be C<10/05/2024> for May 10th, 2024.
5605              
5606             =head2 formatRangeToParts
5607              
5608             my $d1 = DateTime->new(
5609             year => 2024,
5610             month => 5,
5611             day => 10,
5612             hour => 13,
5613             minute => 0,
5614             second => 0,
5615             );
5616             my $d2 = DateTime->new(
5617             year => 2024,
5618             month => 5,
5619             day => 11,
5620             hour => 14,
5621             minute => 0,
5622             second => 0,
5623             );
5624             my $fmt = DateTime::Format::Intl->new( 'fr-FR', {
5625             weekday => 'long',
5626             year => 'numeric',
5627             month => 'long',
5628             day => 'numeric',
5629             });
5630             say $fmt->formatRange( $d1, $d2 ); # mercredi 10 janvier à 19:00 – jeudi 11 janvier à 20:00
5631             my $ref = $fmt->formatRangeToParts( $d1, $d2 );
5632              
5633             This would return an array containing the following hash references:
5634              
5635             { type => 'weekday', value => 'mercredi', source => 'startRange' },
5636             { type => 'literal', value => ' ', source => 'startRange' },
5637             { type => 'day', value => '10', source => 'startRange' },
5638             { type => 'literal', value => ' ', source => 'startRange' },
5639             { type => 'month', value => 'janvier', source => 'startRange' },
5640             { type => 'literal', value => ' à ', source => 'startRange' },
5641             { type => 'hour', value => '19', source => 'startRange' },
5642             { type => 'literal', value => ':', source => 'startRange' },
5643             { type => 'minute', value => '00', source => 'startRange' },
5644             { type => 'literal', value => ' – ', source => 'shared' },
5645             { type => 'weekday', value => 'jeudi', source => 'endRange' },
5646             { type => 'literal', value => ' ', source => 'endRange' },
5647             { type => 'day', value => '11', source => 'endRange' },
5648             { type => 'literal', value => ' ', source => 'endRange' },
5649             { type => 'month', value => 'janvier', source => 'endRange' },
5650             { type => 'literal', value => ' à ', source => 'endRange' },
5651             { type => 'hour', value => '20', source => 'endRange' },
5652             { type => 'literal', value => ':', source => 'endRange' },
5653             { type => 'minute', value => '00', source => 'endRange' }
5654              
5655             The C<formatRangeToParts()> method returns an array of locale-specific tokens representing each part of the formatted date range produced by this L<DateTime::Format::Intl> object. It is useful for custom formatting of date strings.
5656              
5657             =head2 formatToParts
5658              
5659             my $d = DateTime->new(
5660             year => 2024,
5661             month => 5,
5662             day => 10,
5663             hour => 13,
5664             minute => 0,
5665             second => 0,
5666             );
5667             my $fmt = DateTime::Format::Intl->new( 'fr-FR', {
5668             weekday => 'long',
5669             year => 'numeric',
5670             month => 'long',
5671             day => 'numeric',
5672             });
5673             say $fmt->format( $d ); # mercredi 10 janvier à 19:00
5674             my $ref = $fmt->formatToParts( $d );
5675              
5676             This would return an array containing the following hash references:
5677              
5678             { type => 'weekday', value => 'mercredi' },
5679             { type => 'literal', value => ' ' },
5680             { type => 'day', value => '10' },
5681             { type => 'literal', value => ' ' },
5682             { type => 'month', value => 'janvier' },
5683             { type => 'literal', value => ' à ' },
5684             { type => 'hour', value => '19' },
5685             { type => 'literal', value => ':' },
5686             { type => 'minute', value => '00' }
5687              
5688             The C<formatToParts()> method takes an optional L<DateTime> object, and returns an array of locale-specific tokens representing each part of the formatted date produced by this L<DateTime::Format::Intl> object. It is useful for custom formatting of date strings.
5689              
5690             If no L<DateTime> object is provided, it will default to the current date and time.
5691              
5692             The properties of the hash references returned are as follows:
5693              
5694             =over 4
5695              
5696             =item * C<day>
5697              
5698             The string used for the day, for example C<17>.
5699              
5700             =item * C<dayPeriod>
5701              
5702             The string used for the day period, for example, C<AM>, C<PM>, C<in the morning>, or C<noon>
5703              
5704             =item * C<era>
5705              
5706             The string used for the era, for example C<BC> or C<AD>.
5707              
5708             =item * C<fractionalSecond>
5709              
5710             The string used for the fractional seconds, for example C<0> or C<00> or C<000>.
5711              
5712             =item * C<hour>
5713              
5714             The string used for the hour, for example C<3> or C<03>.
5715              
5716             =item * C<literal>
5717              
5718             The string used for separating date and time values, for example C</>, C<,>, C<o'clock>, C<de>, etc.
5719              
5720             =item * C<minute>
5721              
5722             The string used for the minute, for example C<00>.
5723              
5724             =item * C<month>
5725              
5726             The string used for the month, for example C<12>.
5727              
5728             =item * C<relatedYear>
5729              
5730             The string used for the related 4-digit Gregorian year, in the event that the calendar's representation would be a yearName instead of a year, for example C<2019>.
5731              
5732             =item * C<second>
5733              
5734             The string used for the second, for example C<07> or C<42>.
5735              
5736             =item * C<timeZoneName>
5737              
5738             The string used for the name of the time zone, for example C<UTC>. Default is the timezone of the current environment.
5739              
5740             =item * C<weekday>
5741              
5742             The string used for the weekday, for example C<M>, C<Monday>, or C<Montag>.
5743              
5744             =item * C<year>
5745              
5746             The string used for the year, for example C<2012> or C<96>.
5747              
5748             =item * C<yearName>
5749              
5750             The string used for the yearName in relevant contexts, for example C<geng-zi>
5751              
5752             =back
5753              
5754             =head2 resolvedOptions
5755              
5756             The C<resolvedOptions()> method returns an hash reference with the following properties reflecting the C<locale> and date and time formatting C<options> computed during the object instantiation.
5757              
5758             =over 4
5759              
5760             =item * C<locale>
5761              
5762             The BCP 47 language tag for the locale actually used. If any Unicode extension values were requested in the input BCP 47 language tag that led to this locale, the key-value pairs that were requested and are supported for this locale are included in locale.
5763              
5764             =item * C<calendar>
5765              
5766             E.g. C<gregory>
5767              
5768             =item * C<numberingSystem>
5769              
5770             The values requested using the Unicode extension keys C<ca> and C<nu> or filled in as default values.
5771              
5772             =item * C<timeZone>
5773              
5774             The value provided for this property in the options argument; defaults to the runtime's default time zone. Should never be undefined.
5775              
5776             =item * C<hour12>
5777              
5778             The value provided for this property in the options argument or filled in as a default.
5779              
5780             =item * C<weekday>, C<era>, C<year>, C<month>, C<day>, C<hour>, C<minute>, C<second>, C<timeZoneName>
5781              
5782             The values resulting from format matching between the corresponding properties in the options argument and the available combinations and representations for date-time formatting in the selected locale. Some of these properties may not be present, indicating that the corresponding components will not be represented in formatted output.
5783              
5784             =back
5785              
5786             =head1 OTHER NON-CORE METHODS
5787              
5788             =head2 error
5789              
5790             Sets or gets an L<exception object|DateTime::Format::Intl::Exception>
5791              
5792             When called with parameters, this will instantiate a new L<DateTime::Format::Intl::Exception> object, passing it all the parameters received.
5793              
5794             When called in accessor mode, this will return the latest L<exception object|DateTime::Format::Intl::Exception> set, if any.
5795              
5796             =head2 fatal
5797              
5798             $fmt->fatal(1); # Enable fatal exceptions
5799             $fmt->fatal(0); # Disable fatal exceptions
5800             my $bool = $fmt->fatal;
5801              
5802             Sets or get the boolean value, whether to die upon exception, or not. If set to true, then instead of setting an L<exception object|DateTime::Format::Intl::Exception>, this module will die with an L<exception object|DateTime::Format::Intl::Exception>. You can catch the exception object then after using C<try>. For example:
5803              
5804             use v.5.34; # to be able to use try-catch blocks in perl
5805             use experimental 'try';
5806             no warnings 'experimental';
5807             try
5808             {
5809             my $fmt = DateTime::Format::Intl->new( 'x', fatal => 1 );
5810             }
5811             catch( $e )
5812             {
5813             say "Error occurred: ", $e->message;
5814             # Error occurred: Invalid locale value "x" provided.
5815             }
5816              
5817             =head2 greatest_diff
5818              
5819             my $fmt = DateTime::Format::Intl->new( 'fr-FR' );
5820             say $fmt->formatRange( $d1 => $d2 ); # 10/05/2024 - 11/05/2024
5821             # Found that day ('d') is the greatest difference between the two datetimes
5822             my $component = $fmt->greatest_diff; # d
5823              
5824             Read-only method.
5825              
5826             Returns a string representing the component that is the greatest difference between two datetimes.
5827              
5828             This value can be retrieved after L<formatRange|/formatRange> or L<formatRangeToParts|/formatRangeToParts> has been called, otherwise, it would merely return C<undef>
5829              
5830             This is a non-standard method, not part of the original C<Intl.DateTimeFormat> JavaScript API.
5831              
5832             See also L<DateTime::Locale::FromCLDR/interval_greatest_diff> and the L<Unicode LDML specifications|https://unicode.org/reports/tr35/tr35-dates.html#intervalFormats>
5833              
5834             =head2 interval_pattern
5835              
5836             my $fmt = DateTime::Format::Intl->new( 'fr-FR' );
5837             say $fmt->formatRange( $d1 => $d2 ); # 10/05/2024 - 11/05/2024
5838             my $pattern = $fmt->interval_pattern;
5839              
5840             Read-only method.
5841              
5842             Returns a string representing the format pattern resulting from calling L<formatRange|/formatRange> or L<formatRangeToParts|/formatRangeToParts>. This format pattern, which is most likely based on interval format patterns available in the Unicode CLDR data, may have been adjusted to match the required options.
5843              
5844             This is a non-standard method, not part of the original C<Intl.DateTimeFormat> JavaScript API.
5845              
5846             =head2 interval_skeleton
5847              
5848             my $fmt = DateTime::Format::Intl->new( 'fr-FR' );
5849             say $fmt->formatRange( $d1 => $d2 ); # 10/05/2024 - 11/05/2024
5850             my $skeleton = $fmt->interval_skeleton;
5851              
5852             Read-only method.
5853              
5854             Returns a string representing the format skeleton resulting from calling L<formatRange|/formatRange> or L<formatRangeToParts|/formatRangeToParts>. This format skeleton, as called in the Unicode LDML specifications, is like an ID representing the underlying format pattern.
5855              
5856             This is a non-standard method, not part of the original C<Intl.DateTimeFormat> JavaScript API.
5857              
5858             =for Pod::Coverage pass_error
5859              
5860             =head2 pattern
5861              
5862             my $fmt = DateTime::Format::Intl->new( 'en', { weekday => 'short' } ) ||
5863             die( DateTime::Format::Intl->error );
5864             my $resolved_pattern = $fmt->pattern;
5865              
5866             Read-only method.
5867              
5868             Returns a string representing the pattern resolved from the lookup based on the C<locale> provided and C<options> specified.
5869              
5870             This is a non-standard method, not part of the original C<Intl.DateTimeFormat> JavaScript API.
5871              
5872             =head2 skeleton
5873              
5874             my $fmt = DateTime::Format::Intl->new( 'en', { weekday => 'short' } ) ||
5875             die( DateTime::Format::Intl->error );
5876             my $resolved_skeleton = $fmt->skeleton;
5877              
5878             Read-only method.
5879              
5880             Returns a string representing the skeleton resolved from the lookup based on the C<locale> provided and C<options> specified. This returns a value only if the neither of the constructor options C<dateStyle> or C<timeStyle> have been provided. Otherwise, it would be C<undef>
5881              
5882             This is a non-standard method, not part of the original C<Intl.DateTimeFormat> JavaScript API.
5883              
5884             =head1 CLASS FUNCTIONS
5885              
5886             =head2 supportedLocalesOf
5887              
5888             my $array = DateTime::Format::Intl->supportedLocalesOf( $locales, $options1 );
5889             # Try 3 locales by order of priority
5890             my $array = DateTime::Format::Intl->supportedLocalesOf( ['ja-t-de-t0-und-x0-medical', 'he-IL-u-ca-hebrew-tz-jeruslm', 'en-GB'], $options1 );
5891              
5892             The C<supportedLocalesOf()> class function returns an array containing those of the provided locales that are supported in L<DateTime::Locale::FromCLDR> without having to fall back to the runtime's default locale.
5893              
5894             It takes 2 arguments: C<locales> to look up, and an hash or hash reference of C<options>
5895              
5896             =over 4
5897              
5898             =item * C<locales>
5899              
5900             A string with a L<BCP 47 language tag|https://en.wikipedia.org/wiki/IETF_language_tag#Syntax_of_language_tags>, or an array of such strings. For the general form and interpretation of the locales argument, see the parameter description on the L<object instantiation|/new>.
5901              
5902             =item * C<options>
5903              
5904             An optional hash or hash reference that may have the following property:
5905              
5906             =over 8
5907              
5908             =item * C<localeMatcher>
5909              
5910             The locale matching algorithm to use. Possible values are C<lookup> and C<best fit>; the default is C<best fit>. For information about this option, see the L<object instantiation|/new>.
5911              
5912             In this API, this option is not used.
5913              
5914             =back
5915              
5916             =back
5917              
5918             =head1 EXCEPTIONS
5919              
5920             A C<RangeError> exception is thrown if locales or options contain invalid values.
5921              
5922             If an error occurs, any given method will set the L<error object|DateTime::Format::Intl::Exception> and return C<undef> in scalar context, or an empty list in list context.
5923              
5924             See L<Mozilla documentation|https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/RangeError> for more information.
5925              
5926             =head1 AUTHOR
5927              
5928             Jacques Deguest E<lt>F<jack@deguest.jp>E<gt>
5929              
5930             =head1 SEE ALSO
5931              
5932             L<Locale::Unicode>, L<Locale::Intl>, L<Locale::Unicode::Data>, L<DateTime::Locale::FromCLDR>, L<DateTime::Format::Unicode>, L<DateTime>
5933              
5934             L<Mozilla documentation|https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Intl/DateTimeFormat>
5935              
5936             L<CLDR repository for dates and time|https://github.com/unicode-org/cldr-json/tree/main/cldr-json/cldr-dates-full/main>
5937              
5938             L<ICU documentation|https://unicode-org.github.io/icu/userguide/format_parse/datetime/>
5939              
5940             L<CLDR website|http://cldr.unicode.org/>
5941              
5942             =head1 COPYRIGHT & LICENSE
5943              
5944             Copyright(c) 2024 DEGUEST Pte. Ltd.
5945              
5946             All rights reserved
5947              
5948             This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
5949              
5950             =cut