← Index
NYTProf Performance Profile   « line view »
For nd2: #2 manager: init
  Run on Thu May 2 17:38:58 2019
Reported on Thu May 2 17:40:49 2019

Filename/usr/lib/perl5/5.18.2/x86_64-linux-thread-multi/Encode.pm
StatementsExecuted 660 statements in 1.11ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
3311409µs1.33msEncode::::encode Encode::encode
3311332µs588µsEncode::::getEncoding Encode::getEncoding
3311199µs787µsEncode::::find_encoding Encode::find_encoding
3311137µs137µsEncode::utf8::::encode_xs Encode::utf8::encode_xs (xsub)
331134µs34µsEncode::::CORE:subst Encode::CORE:subst (opcode)
0000s0sEncode::::BEGIN Encode::BEGIN
0000s0sEncode::Internal::::__ANON__[:287] Encode::Internal::__ANON__[:287]
0000s0sEncode::UTF_EBCDIC::::__ANON__[:262]Encode::UTF_EBCDIC::__ANON__[:262]
0000s0sEncode::UTF_EBCDIC::::__ANON__[:274]Encode::UTF_EBCDIC::__ANON__[:274]
0000s0sEncode::::clone_encoding Encode::clone_encoding
0000s0sEncode::::decode Encode::decode
0000s0sEncode::::decode_utf8 Encode::decode_utf8
0000s0sEncode::::define_encoding Encode::define_encoding
0000s0sEncode::::encode_utf8 Encode::encode_utf8
0000s0sEncode::::encodings Encode::encodings
0000s0sEncode::::from_to Encode::from_to
0000s0sEncode::::perlio_ok Encode::perlio_ok
0000s0sEncode::::predefine_encodings Encode::predefine_encodings
0000s0sEncode::::resolve_alias Encode::resolve_alias
0000s0sEncode::utf8::::BEGIN Encode::utf8::BEGIN
0000s0sEncode::utf8::::__ANON__[:315] Encode::utf8::__ANON__[:315]
0000s0sEncode::utf8::::__ANON__[:321] Encode::utf8::__ANON__[:321]
0000s0sEncode::utf8::::__ANON__[:337] Encode::utf8::__ANON__[:337]
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1#
2# $Id: Encode.pm,v 2.49 2013/03/05 03:13:47 dankogai Exp dankogai $
3#
4package Encode;
5use strict;
6use warnings;
7our $VERSION = sprintf "%d.%02d", q$Revision: 2.49 $ =~ /(\d+)/g;
8use constant DEBUG => !!$ENV{PERL_ENCODE_DEBUG};
9use XSLoader ();
10XSLoader::load( __PACKAGE__, $VERSION );
11
12require Exporter;
13use base qw/Exporter/;
14
15# Public, encouraged API is exported by default
16
17our @EXPORT = qw(
18 decode decode_utf8 encode encode_utf8 str2bytes bytes2str
19 encodings find_encoding clone_encoding
20);
21our @FB_FLAGS = qw(
22 DIE_ON_ERR WARN_ON_ERR RETURN_ON_ERR LEAVE_SRC
23 PERLQQ HTMLCREF XMLCREF STOP_AT_PARTIAL
24);
25our @FB_CONSTS = qw(
26 FB_DEFAULT FB_CROAK FB_QUIET FB_WARN
27 FB_PERLQQ FB_HTMLCREF FB_XMLCREF
28);
29our @EXPORT_OK = (
30 qw(
31 _utf8_off _utf8_on define_encoding from_to is_16bit is_8bit
32 is_utf8 perlio_ok resolve_alias utf8_downgrade utf8_upgrade
33 ),
34 @FB_FLAGS, @FB_CONSTS,
35);
36
37our %EXPORT_TAGS = (
38 all => [ @EXPORT, @EXPORT_OK ],
39 default => [ @EXPORT ],
40 fallbacks => [ @FB_CONSTS ],
41 fallback_all => [ @FB_CONSTS, @FB_FLAGS ],
42);
43
44# Documentation moved after __END__ for speed - NI-S
45
46our $ON_EBCDIC = ( ord("A") == 193 );
47
48use Encode::Alias;
49
50# Make a %Encoding package variable to allow a certain amount of cheating
51our %Encoding;
52our %ExtModule;
53require Encode::Config;
54# See
55# https://bugzilla.redhat.com/show_bug.cgi?id=435505#c2
56# to find why sig handers inside eval{} are disabled.
57eval {
58 local $SIG{__DIE__};
59 local $SIG{__WARN__};
60 local @INC = @INC;
61 pop @INC if $INC[-1] eq '.';
62 require Encode::ConfigLocal;
63};
64
65sub encodings {
66 my %enc;
67 my $arg = $_[1] || '';
68 if ( $arg eq ":all" ) {
69 %enc = ( %Encoding, %ExtModule );
70 }
71 else {
72 %enc = %Encoding;
73 for my $mod ( map { m/::/ ? $_ : "Encode::$_" } @_ ) {
74 DEBUG and warn $mod;
75 for my $enc ( keys %ExtModule ) {
76 $ExtModule{$enc} eq $mod and $enc{$enc} = $mod;
77 }
78 }
79 }
80 return sort { lc $a cmp lc $b }
81 grep { !/^(?:Internal|Unicode|Guess)$/o } keys %enc;
82}
83
84sub perlio_ok {
85 my $obj = ref( $_[0] ) ? $_[0] : find_encoding( $_[0] );
86 $obj->can("perlio_ok") and return $obj->perlio_ok();
87 return 0; # safety net
88}
89
90sub define_encoding {
91 my $obj = shift;
92 my $name = shift;
93 $Encoding{$name} = $obj;
94 my $lc = lc($name);
95 define_alias( $lc => $obj ) unless $lc eq $name;
96 while (@_) {
97 my $alias = shift;
98 define_alias( $alias, $obj );
99 }
100 return $obj;
101}
102
103
# spent 588µs (332+256) within Encode::getEncoding which was called 33 times, avg 18µs/call: # 33 times (332µs+256µs) by Encode::find_encoding at line 131, avg 18µs/call
sub getEncoding {
1043325µs my ( $class, $name, $skip_external ) = @_;
105
10633100µs3334µs $name =~ s/\s+//g; # https://rt.cpan.org/Ticket/Display.html?id=65796
# spent 34µs making 33 calls to Encode::CORE:subst, avg 1µs/call
107
1083312µs ref($name) && $name->can('renew') and return $name;
1093334µs exists $Encoding{$name} and return $Encoding{$name};
1103322µs my $lc = lc $name;
1113316µs exists $Encoding{$lc} and return $Encoding{$lc};
112
11333104µs33223µs my $oc = $class->find_alias($name);
# spent 223µs making 33 calls to Encode::Alias::find_alias, avg 7µs/call
1143366µs defined($oc) and return $oc;
115 $lc ne $name and $oc = $class->find_alias($lc);
116 defined($oc) and return $oc;
117
118 unless ($skip_external) {
119 if ( my $mod = $ExtModule{$name} || $ExtModule{$lc} ) {
120 $mod =~ s,::,/,g;
121 $mod .= '.pm';
122 eval { require $mod; };
123 exists $Encoding{$name} and return $Encoding{$name};
124 }
125 }
126 return;
127}
128
129
# spent 787µs (199+588) within Encode::find_encoding which was called 33 times, avg 24µs/call: # 33 times (199µs+588µs) by Encode::encode at line 157, avg 24µs/call
sub find_encoding($;$) {
1303319µs my ( $name, $skip_external ) = @_;
13133154µs33588µs return __PACKAGE__->getEncoding( $name, $skip_external );
# spent 588µs making 33 calls to Encode::getEncoding, avg 18µs/call
132}
133
134sub resolve_alias($) {
135 my $obj = find_encoding(shift);
136 defined $obj and return $obj->name;
137 return;
138}
139
140sub clone_encoding($) {
141 my $obj = find_encoding(shift);
142 ref $obj or return;
143 eval { require Storable };
144 $@ and return;
145 return Storable::dclone($obj);
146}
147
148
# spent 1.33ms (409µs+924µs) within Encode::encode which was called 33 times, avg 40µs/call: # 33 times (409µs+924µs) by Dancer::Logger::Abstract::format_message at line 66 of Dancer/Logger/Abstract.pm, avg 40µs/call
sub encode($$;$) {
1493327µs my ( $name, $string, $check ) = @_;
1503315µs return undef unless defined $string;
1513328µs $string .= ''; # stringify;
1523314µs $check ||= 0;
1533312µs unless ( defined $name ) {
154 require Carp;
155 Carp::croak("Encoding name should not be undef");
156 }
1573387µs33787µs my $enc = find_encoding($name);
# spent 787µs making 33 calls to Encode::find_encoding, avg 24µs/call
1583314µs unless ( defined $enc ) {
159 require Carp;
160 Carp::croak("Unknown encoding '$name'");
161 }
16233260µs33137µs my $octets = $enc->encode( $string, $check );
# spent 137µs making 33 calls to Encode::utf8::encode_xs, avg 4µs/call
1633310µs $_[1] = $string if $check and !ref $check and !( $check & LEAVE_SRC() );
1643391µs return $octets;
165}
166*str2bytes = \&encode;
167
168sub decode($$;$) {
169 my ( $name, $octets, $check ) = @_;
170 return undef unless defined $octets;
171 $octets .= '';
172 $check ||= 0;
173 my $enc = find_encoding($name);
174 unless ( defined $enc ) {
175 require Carp;
176 Carp::croak("Unknown encoding '$name'");
177 }
178 my $string = $enc->decode( $octets, $check );
179 $_[1] = $octets if $check and !ref $check and !( $check & LEAVE_SRC() );
180 return $string;
181}
182*bytes2str = \&decode;
183
184sub from_to($$$;$) {
185 my ( $string, $from, $to, $check ) = @_;
186 return undef unless defined $string;
187 $check ||= 0;
188 my $f = find_encoding($from);
189 unless ( defined $f ) {
190 require Carp;
191 Carp::croak("Unknown encoding '$from'");
192 }
193 my $t = find_encoding($to);
194 unless ( defined $t ) {
195 require Carp;
196 Carp::croak("Unknown encoding '$to'");
197 }
198 my $uni = $f->decode($string);
199 $_[0] = $string = $t->encode( $uni, $check );
200 return undef if ( $check && length($uni) );
201 return defined( $_[0] ) ? length($string) : undef;
202}
203
204sub encode_utf8($) {
205 my ($str) = @_;
206 utf8::encode($str);
207 return $str;
208}
209
210my $utf8enc;
211
212sub decode_utf8($;$) {
213 my ( $octets, $check ) = @_;
214 return $octets if is_utf8($octets);
215 return undef unless defined $octets;
216 $octets .= '' if ref $octets;
217 $check ||= 0;
218 $utf8enc ||= find_encoding('utf8');
219 my $string = $utf8enc->decode( $octets, $check );
220 $_[0] = $octets if $check and !ref $check and !( $check & LEAVE_SRC() );
221 return $string;
222}
223
224# sub decode_utf8($;$) {
225# my ( $str, $check ) = @_;
226# return $str if is_utf8($str);
227# if ($check) {
228# return decode( "utf8", $str, $check );
229# }
230# else {
231# return decode( "utf8", $str );
232# return $str;
233# }
234# }
235
236predefine_encodings(1);
237
238#
239# This is to restore %Encoding if really needed;
240#
241
242sub predefine_encodings {
243 require Encode::Encoding;
244 no warnings 'redefine';
245 my $use_xs = shift;
246 if ($ON_EBCDIC) {
247
248 # was in Encode::UTF_EBCDIC
249 package Encode::UTF_EBCDIC;
250 push @Encode::UTF_EBCDIC::ISA, 'Encode::Encoding';
251 *decode = sub {
252 my ( undef, $str, $chk ) = @_;
253 my $res = '';
254 for ( my $i = 0 ; $i < length($str) ; $i++ ) {
255 $res .=
256 chr(
257 utf8::unicode_to_native( ord( substr( $str, $i, 1 ) ) )
258 );
259 }
260 $_[1] = '' if $chk;
261 return $res;
262 };
263 *encode = sub {
264 my ( undef, $str, $chk ) = @_;
265 my $res = '';
266 for ( my $i = 0 ; $i < length($str) ; $i++ ) {
267 $res .=
268 chr(
269 utf8::native_to_unicode( ord( substr( $str, $i, 1 ) ) )
270 );
271 }
272 $_[1] = '' if $chk;
273 return $res;
274 };
275 $Encode::Encoding{Unicode} =
276 bless { Name => "UTF_EBCDIC" } => "Encode::UTF_EBCDIC";
277 }
278 else {
279
280 package Encode::Internal;
281 push @Encode::Internal::ISA, 'Encode::Encoding';
282 *decode = sub {
283 my ( undef, $str, $chk ) = @_;
284 utf8::upgrade($str);
285 $_[1] = '' if $chk;
286 return $str;
287 };
288 *encode = \&decode;
289 $Encode::Encoding{Unicode} =
290 bless { Name => "Internal" } => "Encode::Internal";
291 }
292
293 {
294
295 # was in Encode::utf8
296 package Encode::utf8;
297 push @Encode::utf8::ISA, 'Encode::Encoding';
298
299 #
300 if ($use_xs) {
301 Encode::DEBUG and warn __PACKAGE__, " XS on";
302 *decode = \&decode_xs;
303 *encode = \&encode_xs;
304 }
305 else {
306 Encode::DEBUG and warn __PACKAGE__, " XS off";
307 *decode = sub {
308 my ( undef, $octets, $chk ) = @_;
309 my $str = Encode::decode_utf8($octets);
310 if ( defined $str ) {
311 $_[1] = '' if $chk;
312 return $str;
313 }
314 return undef;
315 };
316 *encode = sub {
317 my ( undef, $string, $chk ) = @_;
318 my $octets = Encode::encode_utf8($string);
319 $_[1] = '' if $chk;
320 return $octets;
321 };
322 }
323 *cat_decode = sub { # ($obj, $dst, $src, $pos, $trm, $chk)
324 # currently ignores $chk
325 my ( undef, undef, undef, $pos, $trm ) = @_;
326 my ( $rdst, $rsrc, $rpos ) = \@_[ 1, 2, 3 ];
327 use bytes;
328 if ( ( my $npos = index( $$rsrc, $trm, $pos ) ) >= 0 ) {
329 $$rdst .=
330 substr( $$rsrc, $pos, $npos - $pos + length($trm) );
331 $$rpos = $npos + length($trm);
332 return 1;
333 }
334 $$rdst .= substr( $$rsrc, $pos );
335 $$rpos = length($$rsrc);
336 return '';
337 };
338 $Encode::Encoding{utf8} =
339 bless { Name => "utf8" } => "Encode::utf8";
340 $Encode::Encoding{"utf-8-strict"} =
341 bless { Name => "utf-8-strict", strict_utf8 => 1 }
342 => "Encode::utf8";
343 }
344}
345
3461;
347
348__END__
 
# spent 34µs within Encode::CORE:subst which was called 33 times, avg 1µs/call: # 33 times (34µs+0s) by Encode::getEncoding at line 106, avg 1µs/call
sub Encode::CORE:subst; # opcode
# spent 137µs within Encode::utf8::encode_xs which was called 33 times, avg 4µs/call: # 33 times (137µs+0s) by Encode::encode at line 162, avg 4µs/call
sub Encode::utf8::encode_xs; # xsub
Report produced by the NYTProf 6.06 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.