Filename | /usr/share/perl5/I18N/LangTags/Detect.pm |
Statements | Executed 18 statements in 1.93ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 28µs | 123µs | BEGIN@16 | I18N::LangTags::Detect::
1 | 1 | 1 | 28µs | 58µs | BEGIN@6 | I18N::LangTags::Detect::
1 | 1 | 1 | 27µs | 37µs | BEGIN@76 | I18N::LangTags::Detect::
1 | 1 | 1 | 24µs | 55µs | BEGIN@138 | I18N::LangTags::Detect::
1 | 1 | 1 | 23µs | 54µs | BEGIN@139 | I18N::LangTags::Detect::
1 | 1 | 1 | 21µs | 134µs | BEGIN@8 | I18N::LangTags::Detect::
1 | 1 | 1 | 12µs | 12µs | BEGIN@11 | I18N::LangTags::Detect::
0 | 0 | 0 | 0s | 0s | _normalize | I18N::LangTags::Detect::
0 | 0 | 0 | 0s | 0s | _try_use | I18N::LangTags::Detect::
0 | 0 | 0 | 0s | 0s | _uniq | I18N::LangTags::Detect::
0 | 0 | 0 | 0s | 0s | ambient_langprefs | I18N::LangTags::Detect::
0 | 0 | 0 | 0s | 0s | detect | I18N::LangTags::Detect::
0 | 0 | 0 | 0s | 0s | http_accept_langs | I18N::LangTags::Detect::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | |||||
2 | # Time-stamp: "2004-06-20 21:47:55 ADT" | ||||
3 | |||||
4 | 1 | 7µs | require 5; | ||
5 | package I18N::LangTags::Detect; | ||||
6 | 2 | 72µs | 2 | 87µ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 # spent 58µs making 1 call to I18N::LangTags::Detect::BEGIN@6
# spent 30µs making 1 call to strict::import |
7 | |||||
8 | 1 | 11µs | 1 | 113µ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 # spent 113µs making 1 call to vars::import |
9 | 1 | 106µs | 1 | 134µs | $USE_LITERALS $MATCH_SUPERS_TIGHTLY); # spent 134µs making 1 call to I18N::LangTags::Detect::BEGIN@8 |
10 | |||||
11 | 1 | 84µs | 1 | 12µ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 # spent 12µs making 1 call to I18N::LangTags::Detect::BEGIN@11 |
12 | # define the constant 'DEBUG' at compile-time | ||||
13 | |||||
14 | 1 | 500ns | $VERSION = "1.05"; | ||
15 | 1 | 4µs | @ISA = (); | ||
16 | 2 | 636µs | 2 | 218µ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 # spent 123µs making 1 call to I18N::LangTags::Detect::BEGIN@16
# spent 95µs making 1 call to Exporter::import |
17 | |||||
18 | sub _uniq { my %seen; return grep(!($seen{$_}++), @_); } | ||||
19 | sub _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 | |||||
31 | sub detect () { return __PACKAGE__->ambient_langprefs; } | ||||
32 | |||||
33 | #=========================================================================== | ||||
34 | |||||
35 | sub 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 | |||||
72 | sub 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? | ||||
76 | 2 | 634µs | 2 | 46µ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 # 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 | |||||
130 | 1 | 600ns | my %tried = (); | ||
131 | # memoization of whether we've used this module, or found it unusable. | ||||
132 | |||||
133 | sub _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! | ||||
138 | 2 | 66µs | 2 | 86µ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 # spent 55µs making 1 call to I18N::LangTags::Detect::BEGIN@138
# spent 31µs making 1 call to strict::unimport |
139 | 2 | 308µs | 2 | 86µ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 # 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 | #--------------------------------------------------------------------------- | ||||
160 | 1 | 4µs | 1; | ||
161 | __END__ |