← 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:07 2021

Filename/usr/local/libexec/sympa/Sympa/Language.pm
StatementsExecuted 6645529 statements in 13.3s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
75350212.82s7.19sSympa::Language::::_find_posix_localeSympa::Language::_find_posix_locale
173706532.61s3.29sSympa::Language::::canonic_langSympa::Language::canonic_lang
3918232942ms15.9sSympa::Language::::set_langSympa::Language::set_lang
3767511778ms4.06sSympa::Language::::_resolve_gettext_localeSympa::Language::_resolve_gettext_locale
4786743469ms1.35sSympa::Language::::implicated_langsSympa::Language::implicated_langs
60816751449ms449msSympa::Language::::CORE:matchSympa::Language::CORE:match (opcode)
7987121345ms1.68sSympa::Language::::lang2localeSympa::Language::lang2locale
904211172ms172msSympa::Language::::_oldlocale2langSympa::Language::_oldlocale2lang
34741221162ms162msSympa::Language::::CORE:regcompSympa::Language::CORE:regcomp (opcode)
1386443185.5ms85.5msSympa::Language::::CORE:substSympa::Language::CORE:subst (opcode)
1235742146.4ms46.4msSympa::Language::::CORE:substcontSympa::Language::CORE:substcont (opcode)
11501121.2ms140msSympa::Language::::dgettextSympa::Language::dgettext
1507119.76ms15.0msSympa::Language::::push_langSympa::Language::push_lang
1507116.17ms166msSympa::Language::::pop_langSympa::Language::pop_lang
4164336.08ms6.08msSympa::Language::::get_langSympa::Language::get_lang
1150113.81ms144msSympa::Language::::gettextSympa::Language::gettext
0000s0sSympa::Language::::BEGIN@30Sympa::Language::BEGIN@30
0000s0sSympa::Language::::BEGIN@31Sympa::Language::BEGIN@31
0000s0sSympa::Language::::BEGIN@32Sympa::Language::BEGIN@32
0000s0sSympa::Language::::BEGIN@34Sympa::Language::BEGIN@34
0000s0sSympa::Language::::BEGIN@35Sympa::Language::BEGIN@35
0000s0sSympa::Language::::BEGIN@36Sympa::Language::BEGIN@36
0000s0sSympa::Language::::BEGIN@38Sympa::Language::BEGIN@38
0000s0sSympa::Language::::BEGIN@40Sympa::Language::BEGIN@40
0000s0sSympa::Language::::CORE:qrSympa::Language::CORE:qr (opcode)
0000s0sSympa::Language::::__ANON__Sympa::Language::__ANON__ (xsub)
0000s0sSympa::Language::::_new_instanceSympa::Language::_new_instance
0000s0sSympa::Language::::gettext_sprintfSympa::Language::gettext_sprintf
0000s0sSympa::Language::::gettext_strftimeSympa::Language::gettext_strftime
0000s0sSympa::Language::::lang2oldlocaleSympa::Language::lang2oldlocale
0000s0sSympa::Language::::maketextSympa::Language::maketext
0000s0sSympa::Language::::native_nameSympa::Language::native_name
0000s0sSympa::Language::::negotiate_langSympa::Language::negotiate_lang
0000s0sSympa::Language::::parse_http_accept_stringSympa::Language::parse_http_accept_string
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1# -*- indent-tabs-mode: nil; -*-
2# vim:ft=perl:et:sw=4
3# $Id$
4
5# Sympa - SYsteme de Multi-Postage Automatique
6#
7# Copyright (c) 1997, 1998, 1999 Institut Pasteur & Christophe Wolfhugel
8# Copyright (c) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
9# 2006, 2007, 2008, 2009, 2010, 2011 Comite Reseau des Universites
10# Copyright (c) 2011, 2012, 2013, 2014, 2015, 2016, 2017 GIP RENATER
11# Copyright 2017, 2018 The Sympa Community. See the AUTHORS.md file at the
12# top-level directory of this distribution and at
13# <https://github.com/sympa-community/sympa.git>.
14#
15# This program is free software; you can redistribute it and/or modify
16# it under the terms of the GNU General Public License as published by
17# the Free Software Foundation; either version 2 of the License, or
18# (at your option) any later version.
19#
20# This program is distributed in the hope that it will be useful,
21# but WITHOUT ANY WARRANTY; without even the implied warranty of
22# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
23# GNU General Public License for more details.
24#
25# You should have received a copy of the GNU General Public License
26# along with this program. If not, see <http://www.gnu.org/licenses/>.
27
28package Sympa::Language;
29
30use strict;
31use warnings;
32use base qw(Class::Singleton);
33
34use Encode qw();
35use Locale::Messages;
36use POSIX qw();
37
38use Sympa::Constants;
39
40BEGIN {
41 ## Using the Pure Perl implementation of gettext
42 ## This is required on Solaris : native implementation of gettext does not
43 ## map ll_RR with ll.
44 # libintl-perl 1.22 (virtually 1.23) or later is recommended to use
45 # 'gettext_dumb' package which is independent from POSIX locale. If older
46 # version is used. falls back to 'gettext_pp'.
47 my $package = Locale::Messages->select_package('gettext_dumb');
48 Locale::Messages->select_package('gettext_pp')
49 unless $package and $package eq 'gettext_dumb';
50 ## Workaround: Prevent from searching catalogs in /usr/share/locale.
51 undef $Locale::gettext_pp::__gettext_pp_default_dir;
52
53 ## Define what catalogs are used
54 Locale::Messages::bindtextdomain(sympa => Sympa::Constants::LOCALEDIR);
55 Locale::Messages::bindtextdomain(web_help => Sympa::Constants::LOCALEDIR);
56 Locale::Messages::textdomain('sympa');
57 ## Get translations by internal encoding.
58 Locale::Messages::bind_textdomain_codeset(sympa => 'utf-8');
59 Locale::Messages::bind_textdomain_codeset(web_help => 'utf-8');
60}
61
62# Constructor for Class::Singleton.
63sub _new_instance {
64 my $class = shift;
65 my $self = $class->SUPER::_new_instance();
66
67 ## Initialize lang/locale.
68 $self->set_lang('en');
69 return $self;
70}
71
72## The map to get language tag from older non-POSIX locale naming.
73my %language_equiv = (
74 'cn' => 'zh-CN',
75 'tw' => 'zh-TW',
76 'cz' => 'cs',
77 'us' => 'en-US',
78);
79
80## The map to get appropriate POSIX locale name from language code.
81## Why this is required is that on many systems locales often have canonic
82## "ll_RR.ENCODING" names only. n.b. This format can not express all
83## languages in proper way, e.g. Common Arabic ("ar"), Esperanto ("eo").
84##
85## This map is also used to convert old-style Sympa "locales" to language
86## tags ('en' is special case. cf. set_lang()).
87my %lang2oldlocale = (
88 'af' => 'af_ZA',
89 'ar' => 'ar_SY',
90 'br' => 'br_FR',
91 'bg' => 'bg_BG',
92 'ca' => 'ca_ES',
93 'cs' => 'cs_CZ',
94 'de' => 'de_DE',
95 'el' => 'el_GR',
96 'es' => 'es_ES',
97 'et' => 'et_EE',
98 'eu' => 'eu_ES',
99 'fi' => 'fi_FI',
100 'fr' => 'fr_FR',
101 'gl' => 'gl_ES',
102 'hu' => 'hu_HU',
103 'id' => 'id_ID',
104 'it' => 'it_IT',
105 'ja' => 'ja_JP',
106 'ko' => 'ko_KR',
107 'la' => 'la_VA', # from OpenOffice.org
108 'ml' => 'ml_IN',
109 'nb' => 'nb_NO',
110 'nn' => 'nn_NO',
111 'nl' => 'nl_NL',
112 'oc' => 'oc_FR',
113 'pl' => 'pl_PL',
114 'pt' => 'pt_PT',
115 'rm' => 'rm_CH', # CLDR
116 'ro' => 'ro_RO',
117 'ru' => 'ru_RU',
118 'sv' => 'sv_SE',
119 'tr' => 'tr_TR',
120 'vi' => 'vi_VN',
121);
122
123## Regexp for old style canonical locale used by Sympa-6.2a or earlier.
124my $oldlocale_re = qr/^([a-z]{2})_([A-Z]{2})(?![A-Z])/i;
125
126## Regexp for IETF language tag described in RFC 5646 (BCP 47), modified.
127my $language_tag_re = qr/^
128 ([a-z]{2}(?:-[a-z]{3}){1,3} | [a-z]{2,3}) # language (and ext.)
129 (?:-([a-z]{4}))? # script
130 (?:-([a-z]{2}))? # region (no UN M.49)
131 (?:-( # variant
132 (?:[a-z0-9]{5,} | [0-9][a-z0-9]{3,})
133 (?:-[a-z0-9]{5,} | -[0-9][a-z0-9]{3,})*
134 ))?
135$/ix;
136
137## A tiny subset of script codes and gettext modifier names.
138## Keys are ISO 15924 script codes (Titlecased, four characters).
139## Values are property value aliases standardised by Unicode Consortium
140## (lowercased). cf. <http://www.unicode.org/iso15924/iso15924-codes.html>.
141my %script2modifier = (
142 'Arab' => 'arabic',
143 'Cyrl' => 'cyrillic',
144 'Deva' => 'devanagari',
145 'Dsrt' => 'deseret',
146 'Glag' => 'glagolitic',
147 'Grek' => 'greek',
148 'Guru' => 'gurmukhi',
149 'Hebr' => 'hebrew',
150 'Latn' => 'latin',
151 'Mong' => 'mongolian',
152 'Shaw' => 'shaw', # found in Debian "en@shaw" locale.
153 'Tfng' => 'tifinagh',
154);
155
156
# spent 3.29s (2.61+674ms) within Sympa::Language::canonic_lang which was called 173706 times, avg 19µs/call: # 79871 times (1.15s+186ms) by Sympa::Language::lang2locale at line 494, avg 17µs/call # 47867 times (734ms+139ms) by Sympa::Language::implicated_langs at line 202, avg 18µs/call # 37675 times (624ms+330ms) by Sympa::Language::set_lang at line 320, avg 25µs/call # 8280 times (100ms+19.5ms) by Sympa::Robot::_load_topics_get_title at line 337 of /usr/local/libexec/sympa/Sympa/Robot.pm, avg 14µs/call # 13 times (165µs+76µs) by Sympa::List::_load_list_config_postprocess at line 5331 of /usr/local/libexec/sympa/Sympa/List.pm, avg 18µs/call
sub canonic_lang {
15717370637.3ms my $lang = shift;
15817370619.7ms return unless $lang;
159
160 ## Compatibility: older non-POSIX locale names.
1611737061.06s356454300ms if ($language_equiv{$lang}) {
# spent 172ms making 9042 calls to Sympa::Language::_oldlocale2lang, avg 19µs/call # spent 91.9ms making 173706 calls to Sympa::Language::CORE:regcomp, avg 529ns/call # spent 35.7ms making 173706 calls to Sympa::Language::CORE:match, avg 205ns/call
162 $lang = $language_equiv{$lang};
163 }
164 ## Compatibility: names used as "lang" or "locale" by Sympa <= 6.2a.
165 elsif ($lang =~ $oldlocale_re) {
166 $lang = _oldlocale2lang(lc($1) . '_' . uc($2));
167 }
168
16917370622.7ms my @subtags;
170
171 # unknown format.
1721737061.15s347412301ms return unless @subtags = ($lang =~ $language_tag_re);
# spent 231ms making 173706 calls to Sympa::Language::CORE:match, avg 1µs/call # spent 70.4ms making 173706 calls to Sympa::Language::CORE:regcomp, avg 405ns/call
173
174 ## Canonicalize cases of subtags: ll-ext-Scri-RR-variant-...
17517370639.9ms $subtags[0] = lc $subtags[0];
17617370617.6ms $subtags[1] =~ s/^(\w)(\w+)/uc($1) . lc($2)/e if $subtags[1];
17717370618.3ms1284µs $subtags[2] = uc $subtags[2] if $subtags[2];
17817370614.4ms $subtags[3] = lc $subtags[3] if $subtags[3];
179
180 ##XXX Maybe more canonicalizations here.
181
182 ## Check subtags,
183 # won't support language extension subtags.
184173706502ms17370673.4ms return unless $subtags[0] =~ /^[a-z]{2,3}$/;
# spent 73.4ms making 173706 calls to Sympa::Language::CORE:match, avg 422ns/call
185
186 # won't allow multiple variant subtags.
18717370616.0ms $subtags[3] =~ s/-.+// if $subtags[3];
188
189 ##XXX Maybe more checks here.
190
191173706371ms return @subtags if wantarray;
19245968173ms return join '-', grep {$_} @subtags;
193}
194
195
# spent 1.35s (469ms+880ms) within Sympa::Language::implicated_langs which was called 47867 times, avg 28µs/call: # 37675 times (368ms+702ms) by Sympa::Language::set_lang at line 328, avg 28µs/call # 6028 times (59.5ms+109ms) by Sympa::Robot::load_topics at line 287 of /usr/local/libexec/sympa/Sympa/Robot.pm, avg 28µs/call # 3014 times (25.3ms+45.9ms) by Sympa::Robot::load_topics at line 303 of /usr/local/libexec/sympa/Sympa/Robot.pm, avg 24µs/call # 1150 times (16.3ms+22.2ms) by Sympa::Task::_parse at line 301 of /usr/local/libexec/sympa/Sympa/Task.pm, avg 34µs/call
sub implicated_langs {
1964786715.5ms my @langs = @_;
197478676.63ms die 'missing langs parameter' unless @langs;
198
199478679.32ms my @implicated_langs = ();
200
2014786713.5ms foreach my $lang (@langs) {
2024786738.2ms47867874ms my @subtags = canonic_lang($lang);
# spent 874ms making 47867 calls to Sympa::Language::canonic_lang, avg 18µs/call
2034786729.7ms while (@subtags) {
2045238840.8ms my $l = join '-', grep {$_} @subtags;
2055238825.1ms @implicated_langs = ((grep { $_ ne $l } @implicated_langs), $l);
206
207 ## Workaround:
208 ## - "zh-Hans-CN", "zh-Hant-TW", ... may occasionally be
209 ## identified with "zh-CN", "zh-TW" etc. Add them to
210 ## implication list.
21152388109ms523886.08ms if ($l =~ /^zh-(Hans|Hant)-[A-Z]{2}\b/) {
# spent 6.08ms making 52388 calls to Sympa::Language::CORE:match, avg 116ns/call
212 $l = join '-', grep {$_} @subtags[0, 2 .. $#subtags];
213 @implicated_langs =
214 ((grep { $_ ne $l } @implicated_langs), $l);
215 }
216
2175238872.6ms 1 until pop @subtags;
218 }
219 }
220
22147867150ms return @implicated_langs;
222}
223
224## Parses content of HTTP 1.1 Accept-Charset, Accept-Encoding or
225## Accept-Language request header field.
226## Returns an array of arrayrefs [ITEM, WEIGHT].
227##
228## NOTE: This might be moved to utility package such as tools.pm.
229sub parse_http_accept_string {
230 my $accept_string = shift || '';
231
232 $accept_string =~ s/^\s+//;
233 $accept_string =~ s/\s+$//;
234 $accept_string ||= '*';
235 my @pairs = split /\s*,\s*/, $accept_string;
236
237 my @ret = ();
238 foreach my $pair (@pairs) {
239 my ($item, $weight) = split /\s*;\s*/, $pair, 2;
240 if ( defined $weight
241 and $weight =~ s/^q\s*=\s*//i
242 and $weight =~ /^(\d+(\.\d*)?|\.\d+)$/) {
243 $weight += 0.0;
244 } else {
245 $weight = 1.0;
246 }
247 push @ret, [$item => $weight];
248 }
249 return @ret;
250}
251
252sub negotiate_lang {
253 my $accept_string = shift || '*';
254 my @supported_languages = grep {$_} map { split /[\s,]+/, $_ } @_;
255
256 ## parse Accept-Language: header field.
257 ## unknown languages are ignored.
258 my @accept_languages =
259 grep { $_->[0] eq '*' or $_->[0] = canonic_lang($_->[0]) }
260 parse_http_accept_string($accept_string);
261 return unless @accept_languages;
262
263 ## try to find the best language.
264 my $best_lang = undef;
265 my $best_weight = 0.0;
266 foreach my $supported_lang (@supported_languages) {
267 my @supported_pfxs = implicated_langs($supported_lang);
268 foreach my $pair (@accept_languages) {
269 my ($accept_lang, $weight) = @$pair;
270 if ($accept_lang eq '*'
271 or grep { $accept_lang eq $_ } @supported_pfxs) {
272 unless ($best_lang and $weight <= $best_weight) {
273 $best_lang = $supported_pfxs[0]; # canonic form
274 $best_weight = $weight;
275 }
276 }
277 }
278 }
279
280 return $best_lang;
281}
282
283##sub GetSupportedLanguages {
284##DEPRECATED: use Sympa::get_supported_languages().
285## Supported languages are defined by 'supported_lang' sympa.conf parameter.
286
287## Old name: PushLang()
288
# spent 15.0ms (9.76+5.23) within Sympa::Language::push_lang which was called 1507 times, avg 10µs/call: # 1507 times (9.76ms+5.23ms) by Sympa::get_supported_languages at line 583 of /usr/local/libexec/sympa/Sympa.pm, avg 10µs/call
sub push_lang {
2891507413µs my $self = shift;
2901507471µs my @langs = @_;
291
29215073.25ms15072.14ms push @{$self->{previous_lang}}, $self->get_lang;
# spent 2.14ms making 1507 calls to Sympa::Language::get_lang, avg 1µs/call
29315071.78ms15073.09ms $self->set_lang(@langs);
# spent 3.09ms making 1507 calls to Sympa::Language::set_lang, avg 2µs/call
294
29515077.63ms return 1;
296}
297
298## Old name: PopLang()
299
# spent 166ms (6.17+160) within Sympa::Language::pop_lang which was called 1507 times, avg 110µs/call: # 1507 times (6.17ms+160ms) by Sympa::get_supported_languages at line 587 of /usr/local/libexec/sympa/Sympa.pm, avg 110µs/call
sub pop_lang {
3001507544µs my $self = shift;
301
302 die 'calling pop_lang() without push_lang()'
3031507823µs unless @{$self->{previous_lang}};
30415071.17ms my $lang = pop @{$self->{previous_lang}};
30515071.22ms1507160ms $self->set_lang($lang);
# spent 160ms making 1507 calls to Sympa::Language::set_lang, avg 106µs/call
306
30715072.08ms return 1;
308}
309
310## Old name: SetLang()
311
# spent 15.9s (942ms+15.0) within Sympa::Language::set_lang which was called 39182 times, avg 406µs/call: # 36168 times (910ms+14.8s) by Sympa::get_supported_languages at line 585 of /usr/local/libexec/sympa/Sympa.pm, avg 435µs/call # 1507 times (28.2ms+132ms) by Sympa::Language::pop_lang at line 305, avg 106µs/call # 1507 times (3.09ms+0s) by Sympa::Language::push_lang at line 293, avg 2µs/call
sub set_lang {
312391828.31ms my $self = shift;
3133918213.9ms my @langs = @_;
314391825.45ms my $locale;
315
316391827.80ms foreach my $lang (@langs) {
317 # Canonicalize lang.
318 # Note: 'en' is always allowed. Use 'en-US' and so on to provide NLS
319 # for English.
3203767537.3ms37675954ms next unless $lang = canonic_lang($lang);
# spent 954ms making 37675 calls to Sympa::Language::canonic_lang, avg 25µs/call
321
322 # Try to set POSIX locale and gettext locale, and get lang actually
323 # set.
324 # Note: Macrolanguage 'zh', 'zh-Hans' or 'zh-Hant' may fallback to
325 # lang with available region.
3263767566.3ms753504.94s if ($locale = _resolve_gettext_locale(lang2locale($lang))) {
# spent 4.06s making 37675 calls to Sympa::Language::_resolve_gettext_locale, avg 108µs/call # spent 874ms making 37675 calls to Sympa::Language::lang2locale, avg 23µs/call
327 ($lang) =
3287987199.2ms798711.88s grep { lang2locale($_) eq $locale } implicated_langs($lang);
# spent 1.07s making 37675 calls to Sympa::Language::implicated_langs, avg 28µs/call # spent 808ms making 42196 calls to Sympa::Language::lang2locale, avg 19µs/call
329 } elsif ($lang =~ /^zh\b/) {
330 my @rr;
331 if ($lang =~ /^zh-Hans\b/) {
332 @rr = qw(CN SG HK MO TW); # try simp. first
333 } elsif ($lang =~ /^zh-Hant\b/) {
334 @rr = qw(HK MO TW CN SG); # try trad. first
335 } else {
336 @rr = qw(CN HK MO SG TW);
337 }
338 foreach my $rr (@rr) {
339 $lang = "zh-$rr";
340 last if $locale = _resolve_gettext_locale(lang2locale($lang));
341 }
342 }
343
344376757.21ms next unless $locale and $lang;
345
346 # The locale is the gettext catalog name; lang is the IETF language
347 # tag. Ex: locale = pt_BR ; lang = pt-BR
348 # locale_numeric and locale_time are POSIX locales for LC_NUMERIC and
349 # POSIX::LC_TIME catogories, respectively. As of 6.2b, they became
350 # optional:
351 # If setting each of them failed, 'C' locale will be set.
3523767512.9ms $self->{lang} = $lang;
353376758.22ms $self->{locale} = $locale;
354 $self->{locale_numeric} =
3553767543.7ms376754.31s _find_posix_locale(POSIX::LC_NUMERIC(), $locale)
# spent 4.31s making 37675 calls to Sympa::Language::_find_posix_locale, avg 114µs/call
356 || 'C';
3573767538.7ms376752.89s $self->{locale_time} = _find_posix_locale(POSIX::LC_TIME(), $locale)
# spent 2.89s making 37675 calls to Sympa::Language::_find_posix_locale, avg 77µs/call
358 || 'C';
359
36037675122ms return $lang;
361 }
362
36315072.32ms return;
364}
365
366## Trys to set gettext locale and returns actually set locale.
367## Mandatory parameter is gettext locale name.
368
# spent 4.06s (778ms+3.29) within Sympa::Language::_resolve_gettext_locale which was called 37675 times, avg 108µs/call: # 37675 times (778ms+3.29s) by Sympa::Language::set_lang at line 326, avg 108µs/call
sub _resolve_gettext_locale {
369376757.88ms my $locale = shift or die 'missing locale parameter';
370
371 # 'en' is always allowed.
3723767512.5ms return $locale if $locale eq 'en';
373
374 # Workaround:
375 # - "nb" and "nn" are recommended not to have "_NO" region suffix:
376 # Both of them are official languages in Norway. However, current Sympa
377 # provides "nb_NO" NLS catalog.
37834661126ms3767514.2ms $locale =~ s/^(nb|nn)\b/${1}_NO/;
# spent 13.1ms making 34661 calls to Sympa::Language::CORE:subst, avg 378ns/call # spent 1.08ms making 3014 calls to Sympa::Language::CORE:substcont, avg 357ns/call
379
380 ## Check if catalog is loaded.
3813466153.2ms local %ENV;
3823466154.0ms $ENV{'LANGUAGE'} = $locale;
3833466142.8ms346613.16s my $metadata = Locale::Messages::gettext(''); # get header
# spent 3.16s making 34661 calls to Locale::Messages::gettext, avg 91µs/call
384
38534661180ms34661103ms unless ($metadata) {
# spent 103ms making 34661 calls to Sympa::Language::CORE:match, avg 3µs/call
386 ## If a sub-locale of 'en' (en-CA, en@shaw, ...) failed, fallback to
387 ## 'en'. Otherwise fails.
388 if ($locale =~ /^en(?![a-z])/) {
389 $locale = 'en';
390 } else {
391 return;
392 }
393 } elsif ($metadata =~ /(?:\A|\n)Language:\s*([\@\w]+)/i) {
394 ## Get precise name of gettext locale if possible.
395 $locale = $1;
396 }
397
398 ## Workaround for "nb" and "nn": See above.
3993466176.3ms346617.65ms $locale =~ s/^(nb|nn)_NO\b/$1/;
# spent 7.65ms making 34661 calls to Sympa::Language::CORE:subst, avg 221ns/call
400
40134661367ms return $locale;
402}
403
404# Trys to set POSIX locale which affects to strftime, sprintf etc.
405
# spent 7.19s (2.82+4.38) within Sympa::Language::_find_posix_locale which was called 75350 times, avg 95µs/call: # 37675 times (1.42s+2.88s) by Sympa::Language::set_lang at line 355, avg 114µs/call # 37675 times (1.40s+1.49s) by Sympa::Language::set_lang at line 357, avg 77µs/call
sub _find_posix_locale {
4067535013.8ms my $type = shift;
4077535012.6ms my $locale = shift;
408
409 # Special case: 'en' is an alias of 'C' locale. Use 'en_US' and so on for
410 # real English.
4117535030.3ms return 'C' if $locale eq 'en';
412
41369322171ms6932235.0ms my $orig_locale = POSIX::setlocale($type);
# spent 35.0ms making 69322 calls to POSIX::setlocale, avg 505ns/call
414
415 ## From "ll@modifier", gets "ll", "ll_RR" and "@modifier".
4166932288.5ms my ($loc, $mod) = split /(?=\@)/, $locale, 2;
4176932212.1ms my $machloc = $loc;
41869322641ms189882110ms $machloc =~ s/^([a-z]{2,3})(?!_)/$lang2oldlocale{$1} || $1/e;
# spent 64.8ms making 69322 calls to Sympa::Language::CORE:subst, avg 935ns/call # spent 45.3ms making 120560 calls to Sympa::Language::CORE:substcont, avg 376ns/call
4196932214.3ms $mod ||= '';
420
421 ## Set POSIX locale
422693227.26ms my $posix_locale;
423 my @try;
424
425 ## Add codeset.
426 ## UpperCase required for FreeBSD; dashless required on HP-UX;
427 ## null codeset is last resort.
4286932224.0ms foreach my $cs ('.utf-8', '.UTF-8', '.utf8', '') {
429 ## Truncate locale similarly in gettext: full locale, and omit
430 ## region then modifier.
431 push @try,
4321109152848ms map { sprintf $_, $cs }
433 ("$machloc%s$mod", "$loc%s$mod", "$loc%s");
434 }
4356932212.1ms foreach my $try (@try) {
4363255123.47s3255122.71s if (POSIX::setlocale($type, $try)) {
# spent 2.71s making 325512 calls to POSIX::setlocale, avg 8µs/call
4376329413.0ms $posix_locale = $try;
4386329419.3ms last;
439 }
440 }
441
442693221.71s693221.52s POSIX::setlocale($type, $orig_locale);
# spent 1.52s making 69322 calls to POSIX::setlocale, avg 22µs/call
443
44469322285ms return $posix_locale;
445}
446
447## Old name: GetLangName()
448## Note: Optional $lang argument was deprecated.
449sub native_name {
450 my $self = shift;
451 die 'extra argument(s)' if @_;
452 my $name;
453
454 unless ($self->{lang} and $self->{lang} ne 'en') {
455 $name = 'English';
456 } else {
457 ## Workaround for nb/nn.
458 my $locale = $self->{locale};
459 $locale =~ s/^(nb|nn)\b/${1}_NO/;
460
461 local %ENV;
462 $ENV{'LANGUAGE'} = $locale;
463 my $metadata = Locale::Messages::gettext(''); # get header
464
465 if ($metadata =~ /(?:\A|\n)Language-Team:\s*(.+)/i) {
466 $name = $1;
467 $name =~ s/\s*\<\S+\>//;
468 }
469 }
470
471 return (defined $name and $name =~ /\S/) ? $name : '';
472}
473
474## Old name: GetLang()
475
# spent 6.08ms within Sympa::Language::get_lang which was called 4164 times, avg 1µs/call: # 1507 times (2.15ms+0s) by Sympa::Robot::load_topics at line 284 of /usr/local/libexec/sympa/Sympa/Robot.pm, avg 1µs/call # 1507 times (2.14ms+0s) by Sympa::Language::push_lang at line 292, avg 1µs/call # 1150 times (1.78ms+0s) by Sympa::Task::_parse at line 301 of /usr/local/libexec/sympa/Sympa/Task.pm, avg 2µs/call
sub get_lang {
4764164901µs my $self = shift;
477416412.8ms return $self->{lang} || 'en'; # the last resort
478}
479
480# DEPRECATED: use Conf::lang2charset().
481# sub GetCharset;
482
483## DEPRECATED: Use canonic_lang().
484## sub Locale2Lang;
485
486# Internal function.
487# Convert language tag to gettext locale name.
488
# spent 1.68s (345ms+1.34) within Sympa::Language::lang2locale which was called 79871 times, avg 21µs/call: # 42196 times (162ms+646ms) by Sympa::Language::set_lang at line 328, avg 19µs/call # 37675 times (183ms+692ms) by Sympa::Language::set_lang at line 326, avg 23µs/call
sub lang2locale {
4897987114.0ms my $lang = shift;
490798718.76ms my $locale;
491 my @subtags;
492
493 ## unknown format.
4947987152.6ms798711.34s return unless @subtags = canonic_lang($lang);
# spent 1.34s making 79871 calls to Sympa::Language::canonic_lang, avg 17µs/call
495
496 ## convert from "ll-Scri-RR" to "ll_RR@scriptname", or
497 ## from "ll-RR-variant" to "ll_RR@variant".
4987987113.3ms $locale = $subtags[0];
499798718.71ms if ($subtags[2]) {
500 $locale .= '_' . $subtags[2];
501 }
5027987112.4ms if ($subtags[1]) {
503 $locale .= '@' . ($script2modifier{$subtags[1]} || $subtags[1]);
504 } elsif ($subtags[3]) {
505 $locale .= '@' . $subtags[3];
506 }
507
50879871196ms return $locale;
509}
510
511# Internal function.
512# Get language tag from old-style "locale".
513# Note: Old name is Locale2Lang().
514# Note: Use canonic_lang().
515
# spent 172ms within Sympa::Language::_oldlocale2lang which was called 9042 times, avg 19µs/call: # 9042 times (172ms+0s) by Sympa::Language::canonic_lang at line 161, avg 19µs/call
sub _oldlocale2lang {
51690422.01ms my $oldlocale = shift;
517904215.0ms my @parts = split /[\W_]/, $oldlocale;
51890421.13ms my $lang;
519
5209042165ms if ($lang = {reverse %lang2oldlocale}->{$oldlocale}) {
521 return $lang;
522 } elsif (scalar @parts > 1 and length $parts[1]) {
523 return join '-', lc $parts[0], uc $parts[1];
524 } else {
525 return lc $parts[0];
526 }
527}
528
529# Convert language tag to old style "locale".
530# Note: This function in earlier releases was named Lang2Locale().
531sub lang2oldlocale {
532 my $lang = shift;
533 my $oldlocale;
534 my @subtags;
535
536 ## unknown format.
537 return unless @subtags = canonic_lang($lang);
538
539 ## 'zh-Hans' and 'zh-Hant' cannot map to useful POSIX locale. Map them to
540 ## 'zh_CN' and 'zh_TW'.
541 ## 'zh' cannot map.
542 if ($subtags[0] eq 'zh' and $subtags[1] and not $subtags[2]) {
543 if ($subtags[1] eq 'Hans') {
544 $subtags[2] = 'CN';
545 } elsif ($subtags[1] eq 'Hant') {
546 $subtags[2] = 'TW';
547 }
548 }
549
550 unless ($subtags[2]) {
551 if ($lang2oldlocale{$subtags[0]}) {
552 return $lang2oldlocale{$subtags[0]};
553 }
554 } else {
555 return join '_', $subtags[0], $subtags[2];
556 }
557 ## unconvertible locale name
558 return;
559}
560
561# Note: older name is sympa_dgettext().
562
# spent 140ms (21.2+119) within Sympa::Language::dgettext which was called 1150 times, avg 122µs/call: # 1150 times (21.2ms+119ms) by Sympa::Language::gettext at line 600, avg 122µs/call
sub dgettext {
5631150286µs my $self = shift;
5641150303µs my $textdomain = shift;
5651150201µs my $msgid = shift;
566
567 # Returns meta information on the catalog.
568 # Note: currently, charset is always 'utf-8'; encoding won't be used.
5691150959µs unless (defined $msgid) {
570 return;
571 } elsif ($msgid eq '') { # prevents meta information to be returned
572 return '';
573 } elsif ($msgid eq '_language_') {
574 return $self->native_name;
575 } elsif ($msgid eq '_charset_') {
576 return 'UTF-8';
577 } elsif ($msgid eq '_encoding_') {
578 return '8bit';
579 }
580
5811150151µs my $gettext_locale;
5821150878µs unless ($self->{lang} and $self->{lang} ne 'en') {
583 $gettext_locale = 'en_US';
584 } else {
585 $gettext_locale = $self->{locale};
586
587 # Workaround for nb/nn.
588 $gettext_locale =~ s/^(nb|nn)\b/${1}_NO/;
589 }
590
59111502.22ms local %ENV;
59211502.18ms $ENV{'LANGUAGE'} = $gettext_locale;
593115014.3ms1150119ms return Locale::Messages::dgettext($textdomain, $msgid);
# spent 119ms making 1150 calls to Locale::Messages::dgettext, avg 103µs/call
594}
595
596
# spent 144ms (3.81+140) within Sympa::Language::gettext which was called 1150 times, avg 125µs/call: # 1150 times (3.81ms+140ms) by Sympa::Task::_parse at line 308 of /usr/local/libexec/sympa/Sympa/Task.pm, avg 125µs/call
sub gettext {
5971150320µs my $self = shift;
5981150365µs my $msgid = shift;
599
60011503.03ms1150140ms return $self->dgettext('', $msgid);
# spent 140ms making 1150 calls to Sympa::Language::dgettext, avg 122µs/call
601}
602
603sub gettext_sprintf {
604 my $self = shift;
605 my $format = shift;
606 my @args = @_;
607
608 my $orig_locale = POSIX::setlocale(POSIX::LC_NUMERIC());
609
610 ## if lang has not been set or 'en' is set, fallback to native sprintf().
611 unless ($self->{lang} and $self->{lang} ne 'en') {
612 POSIX::setlocale(POSIX::LC_NUMERIC(), 'C');
613 } else {
614 $format = $self->gettext($format);
615 POSIX::setlocale(POSIX::LC_NUMERIC(), $self->{locale_numeric});
616 }
617 my $ret = sprintf($format, @args);
618
619 POSIX::setlocale(POSIX::LC_NUMERIC(), $orig_locale);
620 return $ret;
621}
622
623my %date_part_names = (
624 '%a' => {
625 'index' => 6,
626 'gettext_id' => 'Sun:Mon:Tue:Wed:Thu:Fri:Sat'
627 },
628 '%A' => {
629 'index' => 6,
630 'gettext_id' =>
631 'Sunday:Monday:Tuesday:Wednesday:Thursday:Friday:Saturday'
632 },
633 '%b' => {
634 'index' => 4,
635 'gettext_id' => 'Jan:Feb:Mar:Apr:May:Jun:Jul:Aug:Sep:Oct:Nov:Dec'
636 },
637 '%B' => {
638 'index' => 4,
639 'gettext_id' =>
640 'January:February:March:April:May:June:July:August:September:October:November:December'
641 },
642 '%p' => {
643 'index' => 2,
644 'gettext_id' => 'AM:PM'
645 },
646);
647
648sub gettext_strftime {
649 my $self = shift;
650 my $format = shift;
651 my @args = @_;
652
653 my $orig_locale = POSIX::setlocale(POSIX::LC_TIME());
654
655 ## if lang has not been set or 'en' is set, fallback to native
656 ## POSIX::strftime().
657 unless ($self->{lang} and $self->{lang} ne 'en') {
658 POSIX::setlocale(POSIX::LC_TIME(), 'C');
659 } else {
660 $format = $self->gettext($format);
661
662 ## If POSIX locale was not set, emulate format strings.
663 unless ($self->{locale_time}
664 and $self->{locale_time} ne 'C'
665 and $self->{locale_time} ne 'POSIX') {
666 my %names;
667 foreach my $k (keys %date_part_names) {
668 $names{$k} = [
669 split /:/,
670 $self->gettext($date_part_names{$k}->{'gettext_id'})
671 ];
672 }
673 $format =~ s{(\%[EO]?.)}{
674 my $index;
675 if ( $names{$1}
676 and defined(
677 $index = $args[$date_part_names{$1}->{'index'}]
678 )
679 ) {
680 $index = ($index < 12) ? 0 : 1
681 if $1 eq '%p';
682 $names{$1}->[$index];
683 } else {
684 $1;
685 }
686 }eg;
687 }
688
689 POSIX::setlocale(POSIX::LC_TIME(), $self->{locale_time});
690 }
691 my $ret = POSIX::strftime($format, @args);
692 Encode::_utf8_off($ret);
693
694 POSIX::setlocale(POSIX::LC_TIME(), $orig_locale);
695 return $ret;
696}
697
698sub maketext {
699 my $self = shift;
700 my $textdomain = shift;
701 my $template = shift;
702 my @args = @_;
703
704 my $orig_locale = POSIX::setlocale(POSIX::LC_NUMERIC());
705
706 unless ($self->{lang} and $self->{lang} ne 'en') {
707 POSIX::setlocale(POSIX::LC_NUMERIC(), 'C');
708 } else {
709 $template = $self->dgettext($textdomain, $template);
710 POSIX::setlocale(POSIX::LC_NUMERIC(), $self->{locale_numeric});
711 }
712 my $ret = $template;
713 # replace parameters in string
714 $ret =~ s/[%]([%]|\d+)/($1 eq '%') ? '%' : $args[$1 - 1]/eg;
715
716 POSIX::setlocale(POSIX::LC_NUMERIC(), $orig_locale);
717 return $ret;
718}
719
7201;
721__END__
 
# spent 449ms within Sympa::Language::CORE:match which was called 608167 times, avg 738ns/call: # 173706 times (231ms+0s) by Sympa::Language::canonic_lang at line 172, avg 1µs/call # 173706 times (73.4ms+0s) by Sympa::Language::canonic_lang at line 184, avg 422ns/call # 173706 times (35.7ms+0s) by Sympa::Language::canonic_lang at line 161, avg 205ns/call # 52388 times (6.08ms+0s) by Sympa::Language::implicated_langs at line 211, avg 116ns/call # 34661 times (103ms+0s) by Sympa::Language::_resolve_gettext_locale at line 385, avg 3µs/call
sub Sympa::Language::CORE:match; # opcode
# spent 162ms within Sympa::Language::CORE:regcomp which was called 347412 times, avg 467ns/call: # 173706 times (91.9ms+0s) by Sympa::Language::canonic_lang at line 161, avg 529ns/call # 173706 times (70.4ms+0s) by Sympa::Language::canonic_lang at line 172, avg 405ns/call
sub Sympa::Language::CORE:regcomp; # opcode
# spent 85.5ms within Sympa::Language::CORE:subst which was called 138644 times, avg 617ns/call: # 69322 times (64.8ms+0s) by Sympa::Language::_find_posix_locale at line 418, avg 935ns/call # 34661 times (13.1ms+0s) by Sympa::Language::_resolve_gettext_locale at line 378, avg 378ns/call # 34661 times (7.65ms+0s) by Sympa::Language::_resolve_gettext_locale at line 399, avg 221ns/call
sub Sympa::Language::CORE:subst; # opcode
# spent 46.4ms within Sympa::Language::CORE:substcont which was called 123574 times, avg 375ns/call: # 120560 times (45.3ms+0s) by Sympa::Language::_find_posix_locale at line 418, avg 376ns/call # 3014 times (1.08ms+0s) by Sympa::Language::_resolve_gettext_locale at line 378, avg 357ns/call
sub Sympa::Language::CORE:substcont; # opcode