← Index
NYTProf Performance Profile   « line view »
For svc/members/upsert
  Run on Tue Jan 13 11:50:22 2015
Reported on Tue Jan 13 12:09:47 2015

Filename/usr/share/perl5/Locale/Maketext/Lexicon.pm
StatementsExecuted 14 statements in 1.94ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11116µs16µsLocale::Maketext::Lexicon::::BEGIN@3Locale::Maketext::Lexicon::BEGIN@3
1119µs18µsLocale::Maketext::Lexicon::::BEGIN@205Locale::Maketext::Lexicon::BEGIN@205
1117µs17µsLocale::Maketext::Lexicon::::BEGIN@128Locale::Maketext::Lexicon::BEGIN@128
1117µs15µsLocale::Maketext::Lexicon::::BEGIN@264Locale::Maketext::Lexicon::BEGIN@264
1116µs17µsLocale::Maketext::Lexicon::::BEGIN@4Locale::Maketext::Lexicon::BEGIN@4
0000s0sLocale::Maketext::Lexicon::::CLEARLocale::Maketext::Lexicon::CLEAR
0000s0sLocale::Maketext::Lexicon::::DELETELocale::Maketext::Lexicon::DELETE
0000s0sLocale::Maketext::Lexicon::::EXISTSLocale::Maketext::Lexicon::EXISTS
0000s0sLocale::Maketext::Lexicon::::FETCHLocale::Maketext::Lexicon::FETCH
0000s0sLocale::Maketext::Lexicon::::FIRSTKEYLocale::Maketext::Lexicon::FIRSTKEY
0000s0sLocale::Maketext::Lexicon::::NEXTKEYLocale::Maketext::Lexicon::NEXTKEY
0000s0sLocale::Maketext::Lexicon::::SCALARLocale::Maketext::Lexicon::SCALAR
0000s0sLocale::Maketext::Lexicon::::STORELocale::Maketext::Lexicon::STORE
0000s0sLocale::Maketext::Lexicon::::TIEHASHLocale::Maketext::Lexicon::TIEHASH
0000s0sLocale::Maketext::Lexicon::::__ANON__[:176]Locale::Maketext::Lexicon::__ANON__[:176]
0000s0sLocale::Maketext::Lexicon::::__ANON__[:195]Locale::Maketext::Lexicon::__ANON__[:195]
0000s0sLocale::Maketext::Lexicon::::_forceLocale::Maketext::Lexicon::_force
0000s0sLocale::Maketext::Lexicon::::_style_gettextLocale::Maketext::Lexicon::_style_gettext
0000s0sLocale::Maketext::Lexicon::::encodingLocale::Maketext::Lexicon::encoding
0000s0sLocale::Maketext::Lexicon::::importLocale::Maketext::Lexicon::import
0000s0sLocale::Maketext::Lexicon::::lexicon_findLocale::Maketext::Lexicon::lexicon_find
0000s0sLocale::Maketext::Lexicon::::lexicon_getLocale::Maketext::Lexicon::lexicon_get
0000s0sLocale::Maketext::Lexicon::::lexicon_get_Locale::Maketext::Lexicon::lexicon_get_
0000s0sLocale::Maketext::Lexicon::::lexicon_get_arrayLocale::Maketext::Lexicon::lexicon_get_array
0000s0sLocale::Maketext::Lexicon::::lexicon_get_globLocale::Maketext::Lexicon::lexicon_get_glob
0000s0sLocale::Maketext::Lexicon::::lexicon_get_hashLocale::Maketext::Lexicon::lexicon_get_hash
0000s0sLocale::Maketext::Lexicon::::lexicon_get_scalarLocale::Maketext::Lexicon::lexicon_get_scalar
0000s0sLocale::Maketext::Lexicon::::optionLocale::Maketext::Lexicon::option
0000s0sLocale::Maketext::Lexicon::::set_optionLocale::Maketext::Lexicon::set_option
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package Locale::Maketext::Lexicon;
21400ns$Locale::Maketext::Lexicon::VERSION = '1.00';
3241µs116µs
# spent 16µs within Locale::Maketext::Lexicon::BEGIN@3 which was called: # once (16µs+0s) by Locale::Maketext::Simple::load_loc at line 3
use 5.004;
# spent 16µs making 1 call to Locale::Maketext::Lexicon::BEGIN@3
42708µs228µs
# spent 17µs (6+11) within Locale::Maketext::Lexicon::BEGIN@4 which was called: # once (6µs+11µs) by Locale::Maketext::Simple::load_loc at line 4
use strict;
# spent 17µs making 1 call to Locale::Maketext::Lexicon::BEGIN@4 # spent 11µs making 1 call to strict::import
5
6# ABSTRACT: Use other catalog formats in Maketext
7
8
91200nsour %Opts;
10sub option { shift if ref( $_[0] ); $Opts{ lc $_[0] } }
11sub set_option { shift if ref( $_[0] ); $Opts{ lc $_[0] } = $_[1] }
12
13sub encoding {
14 my $encoding = option( @_, 'encoding' ) or return;
15 return $encoding unless lc($encoding) eq 'locale';
16
17 local $^W; # no warnings 'uninitialized', really.
18 my ( $country_language, $locale_encoding );
19
20 local $@;
21 eval {
22 require I18N::Langinfo;
23 $locale_encoding
24 = I18N::Langinfo::langinfo( I18N::Langinfo::CODESET() );
25 } or eval {
26 require Win32::Console;
27 $locale_encoding = 'cp' . Win32::Console::OutputCP();
28 };
29 if ( !$locale_encoding ) {
30 foreach my $key (qw( LANGUAGE LC_ALL LC_MESSAGES LANG )) {
31 $ENV{$key} =~ /^([^.]+)\.([^.:]+)/ or next;
32 ( $country_language, $locale_encoding ) = ( $1, $2 );
33 last;
34 }
35 }
36 if ( defined $locale_encoding
37 && lc($locale_encoding) eq 'euc'
38 && defined $country_language )
39 {
40 if ( $country_language =~ /^ja_JP|japan(?:ese)?$/i ) {
41 $locale_encoding = 'euc-jp';
42 }
43 elsif ( $country_language =~ /^ko_KR|korean?$/i ) {
44 $locale_encoding = 'euc-kr';
45 }
46 elsif ( $country_language =~ /^zh_CN|chin(?:a|ese)?$/i ) {
47 $locale_encoding = 'euc-cn';
48 }
49 elsif ( $country_language =~ /^zh_TW|taiwan(?:ese)?$/i ) {
50 $locale_encoding = 'euc-tw';
51 }
52 }
53
54 return $locale_encoding;
55}
56
57sub import {
58 my $class = shift;
59 return unless @_;
60
61 my %entries;
62 if ( UNIVERSAL::isa( $_[0], 'HASH' ) ) {
63
64 # a hashref with $lang as keys, [$format, $src ...] as values
65 %entries = %{ $_[0] };
66 }
67 elsif ( @_ % 2 == 0 ) {
68 %entries = ( '' => [ splice @_, 0, 2 ], @_ );
69 }
70
71 # expand the wildcard entry
72 if ( my $wild_entry = delete $entries{'*'} ) {
73 while ( my ( $format, $src ) = splice( @$wild_entry, 0, 2 ) ) {
74 next if ref($src); # XXX: implement globbing for the 'Tie' backend
75
76 my $pattern = quotemeta($src);
77 $pattern =~ s/\\\*(?=[^*]+$)/\([-\\w]+\)/g or next;
78 $pattern =~ s/\\\*/.*?/g;
79 $pattern =~ s/\\\?/./g;
80 $pattern =~ s/\\\[/[/g;
81 $pattern =~ s/\\\]/]/g;
82 $pattern =~ s[\\\{(.*?)\\\\}][
83 '(?:'.join('|', split(/,/, $1)).')'
84 ]eg;
85
86 require File::Glob;
87 foreach my $file ( File::Glob::bsd_glob($src) ) {
88 $file =~ /$pattern/ or next;
89 push @{ $entries{$1} }, ( $format => $file ) if $1;
90 }
91 delete $entries{$1}
92 unless !defined($1)
93 or exists $entries{$1} and @{ $entries{$1} };
94 }
95 }
96
97 %Opts = ();
98 foreach my $key ( grep /^_/, keys %entries ) {
99 set_option( lc( substr( $key, 1 ) ) => delete( $entries{$key} ) );
100 }
101 my $OptsRef = {%Opts};
102
103 while ( my ( $lang, $entry ) = each %entries ) {
104 my $export = caller;
105
106 if ( length $lang ) {
107
108 # normalize language tag to Maketext's subclass convention
109 $lang = lc($lang);
110 $lang =~ s/-/_/g;
111 $export .= "::$lang";
112 }
113
114 my @pairs = @{ $entry || [] } or die "no format specified";
115
116 while ( my ( $format, $src ) = splice( @pairs, 0, 2 ) ) {
117 if ( defined($src) and !ref($src) and $src =~ /\*/ ) {
118 unshift( @pairs, $format => $_ )
119 for File::Glob::bsd_glob($src);
120 next;
121 }
122
123 my @content
124 = eval { $class->lexicon_get( $src, scalar caller(1), $lang ); };
125 next if $@ and $@ =~ /^next\b/;
126 die $@ if $@;
127
1282397µs226µs
# spent 17µs (7+10) within Locale::Maketext::Lexicon::BEGIN@128 which was called: # once (7µs+10µs) by Locale::Maketext::Simple::load_loc at line 128
no strict 'refs';
# spent 17µs making 1 call to Locale::Maketext::Lexicon::BEGIN@128 # spent 10µs making 1 call to strict::unimport
129 eval "use $class\::$format; 1" or die $@;
130
131 if ( %{"$export\::Lexicon"} ) {
132 my $lexicon = \%{"$export\::Lexicon"};
133 if ( my $obj = tied %$lexicon ) {
134
135 # if it's our tied hash then force loading
136 # otherwise late load will rewrite
137 $obj->_force if $obj->isa(__PACKAGE__);
138 }
139
140 # clear the memoized cache for old entries:
141 Locale::Maketext->clear_isa_scan;
142
143 my $new = "$class\::$format"->parse(@content);
144
145 # avoid hash rebuild, on big sets
146 @{$lexicon}{ keys %$new } = values %$new;
147 }
148 else {
149 local $^W if $] >= 5.009; # no warnings 'once', really.
150 tie %{"$export\::Lexicon"}, __PACKAGE__,
151 {
152 Opts => $OptsRef,
153 Export => "$export\::Lexicon",
154 Class => "$class\::$format",
155 Content => \@content,
156 };
157 tied( %{"$export\::Lexicon"} )->_force
158 if $OptsRef->{'preload'};
159 }
160
161 length $lang or next;
162
163 # Avoid re-entry
164 my $caller = caller();
165 next if $export->isa($caller);
166
167 push( @{"$export\::ISA"}, scalar caller );
168
169 if ( my $style = option('style') ) {
170 my $cref
171 = $class->can( lc("_style_$style") )
172 ->( $class, $export->can('maketext') )
173 or die "Unknown style: $style";
174
175 # Avoid redefinition warnings
176 local $SIG{__WARN__} = sub {1};
177 *{"$export\::maketext"} = $cref;
178 }
179 }
180 }
181}
182
183sub _style_gettext {
184 my ( $self, $orig ) = @_;
185
186 require Locale::Maketext::Lexicon::Gettext;
187
188 sub {
189 my $lh = shift;
190 my $str = shift;
191 return $orig->(
192 $lh,
193 Locale::Maketext::Lexicon::Gettext::_gettext_to_maketext($str), @_
194 );
195 }
196}
197
198sub TIEHASH {
199 my ( $class, $args ) = @_;
200 return bless( $args, $class );
201
202}
203
204{
2053406µs227µs
# spent 18µs (9+9) within Locale::Maketext::Lexicon::BEGIN@205 which was called: # once (9µs+9µs) by Locale::Maketext::Simple::load_loc at line 205
no strict 'refs';
# spent 18µs making 1 call to Locale::Maketext::Lexicon::BEGIN@205 # spent 9µs making 1 call to strict::unimport
206
207 sub _force {
208 my $args = shift;
209 unless ( $args->{'Done'} ) {
210 $args->{'Done'} = 1;
211 local *Opts = $args->{Opts};
212 *{ $args->{Export} }
213 = $args->{Class}->parse( @{ $args->{Content} } );
214 $args->{'Export'}{'_AUTO'} = 1
215 if option('auto');
216 }
217 return $args->{'Export'};
218 }
219 sub FETCH { _force( $_[0] )->{ $_[1] } }
220 sub EXISTS { _force( $_[0] )->{ $_[1] } }
221 sub DELETE { delete _force( $_[0] )->{ $_[1] } }
222 sub SCALAR { scalar %{ _force( $_[0] ) } }
223 sub STORE { _force( $_[0] )->{ $_[1] } = $_[2] }
224 sub CLEAR { %{ _force( $_[0] )->{ $_[1] } } = () }
225 sub NEXTKEY { each %{ _force( $_[0] ) } }
226
227 sub FIRSTKEY {
228 my $hash = _force( $_[0] );
229 my $a = scalar keys %$hash;
230 each %$hash;
231 }
232}
233
234sub lexicon_get {
235 my ( $class, $src, $caller, $lang ) = @_;
236 return unless defined $src;
237
238 foreach my $type ( qw(ARRAY HASH SCALAR GLOB), ref($src) ) {
239 next unless UNIVERSAL::isa( $src, $type );
240
241 my $method = 'lexicon_get_' . lc($type);
242 die "cannot handle source $type for $src: no $method defined"
243 unless $class->can($method);
244
245 return $class->$method( $src, $caller, $lang );
246 }
247
248 # default handler
249 return $class->lexicon_get_( $src, $caller, $lang );
250}
251
252# for scalarrefs and arrayrefs we just dereference the $src
253sub lexicon_get_scalar { ${ $_[1] } }
254sub lexicon_get_array { @{ $_[1] } }
255
256sub lexicon_get_hash {
257 my ( $class, $src, $caller, $lang ) = @_;
258 return map { $_ => $src->{$_} } sort keys %$src;
259}
260
261sub lexicon_get_glob {
262 my ( $class, $src, $caller, $lang ) = @_;
263
2642387µs224µs
# spent 15µs (7+8) within Locale::Maketext::Lexicon::BEGIN@264 which was called: # once (7µs+8µs) by Locale::Maketext::Simple::load_loc at line 264
no strict 'refs';
# spent 15µs making 1 call to Locale::Maketext::Lexicon::BEGIN@264 # spent 8µs making 1 call to strict::unimport
265 local $^W if $] >= 5.009; # no warnings 'once', really.
266
267 # be extra magical and check for DATA section
268 if ( eof($src) and $src eq \*{"$caller\::DATA"}
269 or $src eq \*{"main\::DATA"} )
270 {
271
272 # okay, the *DATA isn't initiated yet. let's read.
273 #
274 require FileHandle;
275 my $fh = FileHandle->new;
276 my $package = ( ( $src eq \*{"main\::DATA"} ) ? 'main' : $caller );
277
278 if ( $package eq 'main' and -e $0 ) {
279 $fh->open($0) or die "Can't open $0: $!";
280 }
281 else {
282 my $level = 1;
283 while ( my ( $pkg, $filename ) = caller( $level++ ) ) {
284 next unless $pkg eq $package;
285 next unless -e $filename;
286 next;
287
288 $fh->open($filename) or die "Can't open $filename: $!";
289 last;
290 }
291 }
292
293 while (<$fh>) {
294
295 # okay, this isn't foolproof, but good enough
296 last if /^__DATA__$/;
297 }
298
299 return <$fh>;
300 }
301
302 # fh containing the lines
303 my $pos = tell($src);
304 my @lines = <$src>;
305 seek( $src, $pos, 0 );
306 return @lines;
307}
308
309# assume filename - search path, open and return its contents
310sub lexicon_get_ {
311 my ( $class, $src, $caller, $lang ) = @_;
312 $src = $class->lexicon_find( $src, $caller, $lang );
313 defined $src or die 'next';
314
315 require FileHandle;
316 my $fh = FileHandle->new;
317 $fh->open($src) or die "Cannot read $src (called by $caller): $!";
318 binmode($fh);
319 return <$fh>;
320}
321
322sub lexicon_find {
323 my ( $class, $src, $caller, $lang ) = @_;
324 return $src if -e $src;
325
326 require File::Spec;
327
328 my @path = split '::', $caller;
329 push @path, $lang if length $lang;
330
331 while (@path) {
332 foreach (@INC) {
333 my $file = File::Spec->catfile( $_, @path, $src );
334 return $file if -e $file;
335 }
336 pop @path;
337 }
338
339 return undef;
340}
341
34212µs1;
343
344__END__
Report produced by the NYTProf 5.06 Perl profiler, developed by Tim Bunce and Adam Kaplan.