← Index
NYTProf Performance Profile   « line view »
For ./view
  Run on Fri Jul 31 19:05:14 2015
Reported on Fri Jul 31 19:08:10 2015

Filename/usr/share/perl5/I18N/LangTags/Detect.pm
StatementsExecuted 18 statements in 1.93ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
11128µs123µsI18N::LangTags::Detect::::BEGIN@16I18N::LangTags::Detect::BEGIN@16
11128µs58µsI18N::LangTags::Detect::::BEGIN@6I18N::LangTags::Detect::BEGIN@6
11127µs37µsI18N::LangTags::Detect::::BEGIN@76I18N::LangTags::Detect::BEGIN@76
11124µs55µsI18N::LangTags::Detect::::BEGIN@138I18N::LangTags::Detect::BEGIN@138
11123µs54µsI18N::LangTags::Detect::::BEGIN@139I18N::LangTags::Detect::BEGIN@139
11121µs134µsI18N::LangTags::Detect::::BEGIN@8I18N::LangTags::Detect::BEGIN@8
11112µs12µsI18N::LangTags::Detect::::BEGIN@11I18N::LangTags::Detect::BEGIN@11
0000s0sI18N::LangTags::Detect::::_normalizeI18N::LangTags::Detect::_normalize
0000s0sI18N::LangTags::Detect::::_try_useI18N::LangTags::Detect::_try_use
0000s0sI18N::LangTags::Detect::::_uniqI18N::LangTags::Detect::_uniq
0000s0sI18N::LangTags::Detect::::ambient_langprefsI18N::LangTags::Detect::ambient_langprefs
0000s0sI18N::LangTags::Detect::::detectI18N::LangTags::Detect::detect
0000s0sI18N::LangTags::Detect::::http_accept_langsI18N::LangTags::Detect::http_accept_langs
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1
2# Time-stamp: "2004-06-20 21:47:55 ADT"
3
417µsrequire 5;
5package I18N::LangTags::Detect;
6272µs287µs
# spent 58µs (28+30) within I18N::LangTags::Detect::BEGIN@6 which was called: # once (28µs+30µs) by Locale::Maketext::BEGIN@8 at line 6
use strict;
# spent 58µs making 1 call to I18N::LangTags::Detect::BEGIN@6 # spent 30µs making 1 call to strict::import
7
8111µs1113µs
# spent 134µs (21+113) within I18N::LangTags::Detect::BEGIN@8 which was called: # once (21µs+113µs) by Locale::Maketext::BEGIN@8 at line 9
use vars qw( @ISA $VERSION $MATCH_SUPERS $USING_LANGUAGE_TAGS
# spent 113µs making 1 call to vars::import
91106µs1134µs $USE_LITERALS $MATCH_SUPERS_TIGHTLY);
# spent 134µs making 1 call to I18N::LangTags::Detect::BEGIN@8
10
11184µs112µs
# spent 12µs within I18N::LangTags::Detect::BEGIN@11 which was called: # once (12µs+0s) by Locale::Maketext::BEGIN@8 at line 11
BEGIN { unless(defined &DEBUG) { *DEBUG = sub () {0} } }
# spent 12µs making 1 call to I18N::LangTags::Detect::BEGIN@11
12 # define the constant 'DEBUG' at compile-time
13
141500ns$VERSION = "1.05";
1514µs@ISA = ();
162636µs2218µs
# spent 123µs (28+95) within I18N::LangTags::Detect::BEGIN@16 which was called: # once (28µs+95µs) by Locale::Maketext::BEGIN@8 at line 16
use I18N::LangTags qw(alternate_language_tags locale2language_tag);
# spent 123µs making 1 call to I18N::LangTags::Detect::BEGIN@16 # spent 95µs making 1 call to Exporter::import
17
18sub _uniq { my %seen; return grep(!($seen{$_}++), @_); }
19sub _normalize {
20 my(@languages) =
21 map lc($_),
22 grep $_,
23 map {; $_, alternate_language_tags($_) } @_;
24 return _uniq(@languages) if wantarray;
25 return $languages[0];
26}
27
28#---------------------------------------------------------------------------
29# The extent of our functional interface:
30
31sub detect () { return __PACKAGE__->ambient_langprefs; }
32
33#===========================================================================
34
35sub ambient_langprefs { # always returns things untainted
36 my $base_class = $_[0];
37
38 return $base_class->http_accept_langs
39 if length( $ENV{'REQUEST_METHOD'} || '' ); # I'm a CGI
40 # it's off in its own routine because it's complicated
41
42 # Not running as a CGI: try to puzzle out from the environment
43 my @languages;
44
45 foreach my $envname (qw( LANGUAGE LC_ALL LC_MESSAGES LANG )) {
46 next unless $ENV{$envname};
47 DEBUG and print "Noting \$$envname: $ENV{$envname}\n";
48 push @languages,
49 map locale2language_tag($_),
50 # if it's a lg tag, fine, pass thru (untainted)
51 # if it's a locale ID, try converting to a lg tag (untainted),
52 # otherwise nix it.
53
54 split m/[,:]/,
55 $ENV{$envname}
56 ;
57 last; # first one wins
58 }
59
60 if($ENV{'IGNORE_WIN32_LOCALE'}) {
61 # no-op
62 } elsif(&_try_use('Win32::Locale')) {
63 # If we have that module installed...
64 push @languages, Win32::Locale::get_language() || ''
65 if defined &Win32::Locale::get_language;
66 }
67 return _normalize @languages;
68}
69
70#---------------------------------------------------------------------------
71
72sub http_accept_langs {
73 # Deal with HTTP "Accept-Language:" stuff. Hassle.
74 # This code is more lenient than RFC 3282, which you must read.
75 # Hm. Should I just move this into I18N::LangTags at some point?
762634µs246µs
# spent 37µs (27+10) within I18N::LangTags::Detect::BEGIN@76 which was called: # once (27µs+10µs) by Locale::Maketext::BEGIN@8 at line 76
no integer;
# spent 37µs making 1 call to I18N::LangTags::Detect::BEGIN@76 # spent 10µs making 1 call to integer::unimport
77
78 my $in = (@_ > 1) ? $_[1] : $ENV{'HTTP_ACCEPT_LANGUAGE'};
79 # (always ends up untainting)
80
81 return() unless defined $in and length $in;
82
83 $in =~ s/\([^\)]*\)//g; # nix just about any comment
84
85 if( $in =~ m/^\s*([a-zA-Z][-a-zA-Z]+)\s*$/s ) {
86 # Very common case: just one language tag
87 return _normalize $1;
88 } elsif( $in =~ m/^\s*[a-zA-Z][-a-zA-Z]+(?:\s*,\s*[a-zA-Z][-a-zA-Z]+)*\s*$/s ) {
89 # Common case these days: just "foo, bar, baz"
90 return _normalize( $in =~ m/([a-zA-Z][-a-zA-Z]+)/g );
91 }
92
93 # Else it's complicated...
94
95 $in =~ s/\s+//g; # Yes, we can just do without the WS!
96 my @in = $in =~ m/([^,]+)/g;
97 my %pref;
98
99 my $q;
100 foreach my $tag (@in) {
101 next unless $tag =~
102 m/^([a-zA-Z][-a-zA-Z]+)
103 (?:
104 ;q=
105 (
106 \d* # a bit too broad of a RE, but so what.
107 (?:
108 \.\d+
109 )?
110 )
111 )?
112 $
113 /sx
114 ;
115 $q = (defined $2 and length $2) ? $2 : 1;
116 #print "$1 with q=$q\n";
117 push @{ $pref{$q} }, lc $1;
118 }
119
120 return _normalize(
121 # Read off %pref, in descending key order...
122 map @{$pref{$_}},
123 sort {$b <=> $a}
124 keys %pref
125 );
126}
127
128#===========================================================================
129
1301600nsmy %tried = ();
131 # memoization of whether we've used this module, or found it unusable.
132
133sub _try_use { # Basically a wrapper around "require Modulename"
134 # "Many men have tried..." "They tried and failed?" "They tried and died."
135 return $tried{$_[0]} if exists $tried{$_[0]}; # memoization
136
137 my $module = $_[0]; # ASSUME sane module name!
138266µs286µs
# spent 55µs (24+31) within I18N::LangTags::Detect::BEGIN@138 which was called: # once (24µs+31µs) by Locale::Maketext::BEGIN@8 at line 138
{ no strict 'refs';
# spent 55µs making 1 call to I18N::LangTags::Detect::BEGIN@138 # spent 31µs making 1 call to strict::unimport
1392308µs286µs
# spent 54µs (23+31) within I18N::LangTags::Detect::BEGIN@139 which was called: # once (23µs+31µs) by Locale::Maketext::BEGIN@8 at line 139
no warnings 'once';
# spent 54µs making 1 call to I18N::LangTags::Detect::BEGIN@139 # spent 31µs making 1 call to warnings::unimport
140 return($tried{$module} = 1)
141 if %{$module . "::Lexicon"} or @{$module . "::ISA"};
142 # weird case: we never use'd it, but there it is!
143 }
144
145 print " About to use $module ...\n" if DEBUG;
146 {
147 local $SIG{'__DIE__'};
148 eval "require $module"; # used to be "use $module", but no point in that.
149 }
150 if($@) {
151 print "Error using $module \: $@\n" if DEBUG > 1;
152 return $tried{$module} = 0;
153 } else {
154 print " OK, $module is used\n" if DEBUG;
155 return $tried{$module} = 1;
156 }
157}
158
159#---------------------------------------------------------------------------
16014µs1;
161__END__