← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:06 2021

Filename/usr/local/lib/perl5/site_perl/DateTime/Locale.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sDateTime::Locale::::BEGIN@11DateTime::Locale::BEGIN@11
0000s0sDateTime::Locale::::BEGIN@12DateTime::Locale::BEGIN@12
0000s0sDateTime::Locale::::BEGIN@13DateTime::Locale::BEGIN@13
0000s0sDateTime::Locale::::BEGIN@14DateTime::Locale::BEGIN@14
0000s0sDateTime::Locale::::BEGIN@15DateTime::Locale::BEGIN@15
0000s0sDateTime::Locale::::BEGIN@3DateTime::Locale::BEGIN@3
0000s0sDateTime::Locale::::BEGIN@5DateTime::Locale::BEGIN@5
0000s0sDateTime::Locale::::BEGIN@6DateTime::Locale::BEGIN@6
0000s0sDateTime::Locale::::BEGIN@7DateTime::Locale::BEGIN@7
0000s0sDateTime::Locale::::CORE:substDateTime::Locale::CORE:subst (opcode)
0000s0sDateTime::Locale::::__ANON__DateTime::Locale::__ANON__ (xsub)
0000s0sDateTime::Locale::::_guess_codeDateTime::Locale::_guess_code
0000s0sDateTime::Locale::::_load_class_from_codeDateTime::Locale::_load_class_from_code
0000s0sDateTime::Locale::::_locale_object_forDateTime::Locale::_locale_object_for
0000s0sDateTime::Locale::::_registerDateTime::Locale::_register
0000s0sDateTime::Locale::::_registered_locale_forDateTime::Locale::_registered_locale_for
0000s0sDateTime::Locale::::add_aliasesDateTime::Locale::add_aliases
0000s0sDateTime::Locale::::codesDateTime::Locale::codes
0000s0sDateTime::Locale::::idsDateTime::Locale::ids
0000s0sDateTime::Locale::::loadDateTime::Locale::load
0000s0sDateTime::Locale::::namesDateTime::Locale::names
0000s0sDateTime::Locale::::native_namesDateTime::Locale::native_names
0000s0sDateTime::Locale::::registerDateTime::Locale::register
0000s0sDateTime::Locale::::register_from_dataDateTime::Locale::register_from_data
0000s0sDateTime::Locale::::remove_aliasDateTime::Locale::remove_alias
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package DateTime::Locale;
2
3use 5.008004;
4
5use strict;
6use warnings;
7use namespace::autoclean;
8
9our $VERSION = '1.32';
10
11use DateTime::Locale::Data;
12use DateTime::Locale::FromData;
13use DateTime::Locale::Util qw( parse_locale_code );
14use Params::ValidationCompiler 0.13 qw( validation_for );
15use Specio::Library::String;
16
17my %Class;
18my %DataForCode;
19my %NameToCode;
20my %NativeNameToCode;
21my %UserDefinedAlias;
22
23my %LoadCache;
24
25sub register {
26 my $class = shift;
27
28 %LoadCache = ();
29
30 if ( ref $_[0] ) {
31 $class->_register(%$_) foreach @_;
32 }
33 else {
34 $class->_register(@_);
35 }
36}
37
38sub _register {
39 shift;
40 my %p = @_;
41
42 my $id = $p{id};
43
44 die q{'\@' or '=' are not allowed in locale ids}
45 if $id =~ /[\@=]/;
46
47 die
48 "You cannot replace an existing locale ('$id') unless you also specify the 'replace' parameter as true\n"
49 if !delete $p{replace} && exists $DataForCode{$id};
50
51 $p{native_language} = $p{en_language}
52 unless exists $p{native_language};
53
54 my @en_pieces;
55 my @native_pieces;
56 foreach my $p (qw( language script territory variant )) {
57 push @en_pieces, $p{"en_$p"} if exists $p{"en_$p"};
58 push @native_pieces, $p{"native_$p"} if exists $p{"native_$p"};
59 }
60
61 $p{en_complete_name} = join q{ }, @en_pieces;
62 $p{native_complete_name} = join q{ }, @native_pieces;
63
64 $id =~ s/_/-/g;
65
66 $DataForCode{$id} = \%p;
67
68 $NameToCode{ $p{en_complete_name} } = $id;
69 $NativeNameToCode{ $p{native_complete_name} } = $id;
70
71 $Class{$id} = $p{class} if defined exists $p{class};
72}
73
74sub register_from_data {
75 shift;
76
77 %LoadCache = ();
78
79 my %p = ref $_[0] ? %{ $_[0] } : @_;
80
81 my $code = $p{code};
82
83 die q{'\@' or '=' are not allowed in locale codes}
84 if $code =~ /[\@=]/;
85
86 $code =~ s/_/-/g;
87
88 DateTime::Locale::Data::add_locale( $code, \%p );
89 return $LoadCache{$code} = DateTime::Locale::FromData->new( \%p );
90}
91
92sub add_aliases {
93 shift;
94
95 %LoadCache = ();
96
97 my $aliases = ref $_[0] ? $_[0] : {@_};
98
99 for my $alias ( keys %{$aliases} ) {
100 my $code = $aliases->{$alias};
101
102 die q{Can't alias an id to itself}
103 if $alias eq $code;
104
105 # check for overwrite?
106
107 my %seen = ( $alias => 1, $code => 1 );
108 my $copy = $code;
109 while ( $copy = $UserDefinedAlias{$copy} ) {
110 die
111 "Creating an alias from $alias to $code would create a loop.\n"
112 if $seen{$copy};
113
114 $seen{$copy} = 1;
115 }
116
117 $UserDefinedAlias{$alias} = $code;
118 }
119}
120
121sub remove_alias {
122 shift;
123
124 %LoadCache = ();
125
126 my $alias = shift;
127
128 return delete $UserDefinedAlias{$alias};
129}
130
131# deprecated
132sub ids {
133 shift->codes;
134}
135
136## no critic (Variables::ProhibitPackageVars)
137sub codes {
138 wantarray
139 ? keys %DateTime::Locale::Data::Codes
140 : [ keys %DateTime::Locale::Data::Codes ];
141}
142
143sub names {
144 wantarray
145 ? keys %DateTime::Locale::Data::Names
146 : [ keys %DateTime::Locale::Data::Names ];
147}
148
149sub native_names {
150 wantarray
151 ? keys %DateTime::Locale::Data::NativeNames
152 : [ keys %DateTime::Locale::Data::NativeNames ];
153}
154
155# These are hard-coded for backwards comaptibility with the DateTime::Language
156# code.
157my %DateTimeLanguageAliases = (
158
159 # 'Afar' => 'aa',
160 'Amharic' => 'am-ET',
161 'Austrian' => 'de-AT',
162 'Brazilian' => 'pt-BR',
163 'Czech' => 'cs-CZ',
164 'Danish' => 'da-DK',
165 'Dutch' => 'nl-NL',
166 'English' => 'en-US',
167 'French' => 'fr-FR',
168
169 # 'Gedeo' => undef, # XXX
170 'German' => 'de-DE',
171 'Italian' => 'it-IT',
172 'Norwegian' => 'no-NO',
173 'Oromo' => 'om-ET', # Maybe om-KE or plain om ?
174 'Portugese' => 'pt-PT',
175
176 # 'Sidama' => 'sid',
177 'Somali' => 'so-SO',
178 'Spanish' => 'es-ES',
179 'Swedish' => 'sv-SE',
180
181 # 'Tigre' => 'tig',
182 'TigrinyaEthiopian' => 'ti-ET',
183 'TigrinyaEritrean' => 'ti-ER',
184);
185
186my %POSIXAliases = (
187 C => 'en-US-POSIX',
188 POSIX => 'en-US-POSIX',
189);
190
191{
192 my $validator = validation_for(
193 name => '_check_load_params',
194 name_is_optional => 1,
195 params => [
196 { type => t('NonEmptyStr') },
197 ],
198 );
199
200 sub load {
201 my $class = shift;
202 my ($code) = $validator->(@_);
203
204 # We used to use underscores in codes instead of dashes. We want to
205 # support both indefinitely.
206 $code =~ tr/_/-/;
207
208 # Strip off charset for LC_* codes : en_GB.UTF-8 etc
209 $code =~ s/\..*$//;
210
211 return $LoadCache{$code} if exists $LoadCache{$code};
212
213 while ( exists $UserDefinedAlias{$code} ) {
214 $code = $UserDefinedAlias{$code};
215 }
216
217 $code = $DateTimeLanguageAliases{$code}
218 if exists $DateTimeLanguageAliases{$code};
219 $code = $POSIXAliases{$code} if exists $POSIXAliases{$code};
220 $code = $DateTime::Locale::Data::ISO639Aliases{$code}
221 if exists $DateTime::Locale::Data::ISO639Aliases{$code};
222
223 if ( exists $DateTime::Locale::Data::Codes{$code} ) {
224 return $class->_locale_object_for($code);
225 }
226
227 if ( exists $DateTime::Locale::Data::Names{$code} ) {
228 return $class->_locale_object_for(
229 $DateTime::Locale::Data::Names{$code} );
230 }
231
232 if ( exists $DateTime::Locale::Data::NativeNames{$code} ) {
233 return $class->_locale_object_for(
234 $DateTime::Locale::Data::NativeNames{$code} );
235 }
236
237 if ( my $locale = $class->_registered_locale_for($code) ) {
238 return $locale;
239 }
240
241 if ( my $guessed = $class->_guess_code($code) ) {
242 return $class->_locale_object_for($guessed);
243 }
244
245 die "Invalid locale code or name: $code\n";
246 }
247}
248
249sub _guess_code {
250 shift;
251 my $code = shift;
252
253 my %codes = parse_locale_code($code);
254
255 my @guesses;
256
257 if ( $codes{script} ) {
258 my $guess = join q{-}, $codes{language}, $codes{script};
259
260 push @guesses, $guess;
261
262 $guess .= q{-} . $codes{territory} if defined $codes{territory};
263
264 # version with script comes first
265 unshift @guesses, $guess;
266 }
267
268 if ( $codes{variant} ) {
269 push @guesses, join q{-}, $codes{language}, $codes{territory},
270 $codes{variant};
271 }
272
273 if ( $codes{territory} ) {
274 push @guesses, join q{-}, $codes{language}, $codes{territory};
275 }
276
277 push @guesses, $codes{language};
278
279 for my $code (@guesses) {
280 return $code
281 if exists $DateTime::Locale::Data::Codes{$code}
282 || exists $DateTime::Locale::Data::Names{$code};
283 }
284}
285
286sub _locale_object_for {
287 shift;
288 my $code = shift;
289
290 my $data = DateTime::Locale::Data::locale_data($code)
291 or return;
292
293 # We want to make a copy of the data just in case ...
294 return $LoadCache{$code} = DateTime::Locale::FromData->new( \%{$data} );
295}
296
297sub _registered_locale_for {
298 my $class = shift;
299 my $code = shift;
300
301 # Custom locale registered by user
302 if ( $Class{$code} ) {
303 return $LoadCache{$code}
304 = $class->_load_class_from_code( $code, $Class{$code} );
305 }
306
307 if ( $DataForCode{$code} ) {
308 return $LoadCache{$code} = $class->_load_class_from_code($code);
309 }
310
311 if ( $NameToCode{$code} ) {
312 return $LoadCache{$code}
313 = $class->_load_class_from_code( $NameToCode{$code} );
314 }
315
316 if ( $NativeNameToCode{$code} ) {
317 return $LoadCache{$code}
318 = $class->_load_class_from_code( $NativeNameToCode{$code} );
319 }
320}
321
322sub _load_class_from_code {
323 my $class = shift;
324 my $code = shift;
325 my $real_class = shift;
326
327 # We want the first alias for which there is data, even if it has
328 # no corresponding .pm file. There may be multiple levels of
329 # alias to go through.
330 my $data_code = $code;
331 while ( exists $UserDefinedAlias{$data_code}
332 && !exists $DataForCode{$data_code} ) {
333
334 $data_code = $UserDefinedAlias{$data_code};
335 }
336
337 ( my $underscore_code = $data_code ) =~ s/-/_/g;
338 $real_class ||= "DateTime::Locale::$underscore_code";
339
340 unless ( $real_class->can('new') ) {
341 ## no critic (BuiltinFunctions::ProhibitStringyEval, ErrorHandling::RequireCheckingReturnValueOfEval)
342 eval "require $real_class";
343 die $@ if $@;
344 ## use critic
345 }
346
347 my $locale = $real_class->new(
348 %{ $DataForCode{$data_code} },
349 code => $code,
350 );
351
352 if ( $locale->can('cldr_version') ) {
353 my $object_version = $locale->cldr_version;
354
355 if ( $object_version ne $DateTime::Locale::Data::CLDRVersion ) {
356 warn
357 "Loaded $real_class, which is from an older version ($object_version)"
358 . ' of the CLDR database than this installation of'
359 . " DateTime::Locale ($DateTime::Locale::Data::CLDRVersion).\n";
360 }
361 }
362
363 return $locale;
364}
365## use critic
366
3671;
368
369# ABSTRACT: Localization support for DateTime.pm
370
371__END__