Filename | /usr/local/lib/perl5/5.32/mach/Encode.pm |
Statements | Executed 0 statements in 0s |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
71622 | 1 | 1 | 37.1ms | 37.1ms | _utf8_off (xsub) | Encode::
345 | 1 | 1 | 2.22ms | 3.12ms | decode (xsub) | Encode::utf8::
345 | 1 | 1 | 2.15ms | 5.27ms | decode_utf8 (xsub) | Encode::
690 | 2 | 1 | 471µs | 471µs | is_utf8 (xsub) | Encode::
345 | 1 | 1 | 424µs | 424µs | encode_utf8 (xsub) | Encode::
0 | 0 | 0 | 0s | 0s | BEGIN@15 | Encode::
0 | 0 | 0 | 0s | 0s | BEGIN@17 | Encode::
0 | 0 | 0 | 0s | 0s | BEGIN@5 | Encode::
0 | 0 | 0 | 0s | 0s | BEGIN@53 | Encode::
0 | 0 | 0 | 0s | 0s | BEGIN@54 | Encode::
0 | 0 | 0 | 0s | 0s | BEGIN@56 | Encode::
0 | 0 | 0 | 0s | 0s | BEGIN@6 | Encode::
0 | 0 | 0 | 0s | 0s | BEGIN@7 | Encode::
0 | 0 | 0 | 0s | 0s | BEGIN@9 | Encode::
0 | 0 | 0 | 0s | 0s | CORE:match (opcode) | Encode::
0 | 0 | 0 | 0s | 0s | CORE:subst (opcode) | Encode::
0 | 0 | 0 | 0s | 0s | BEGIN@207 | Encode::Internal::
0 | 0 | 0 | 0s | 0s | decode | Encode::Internal::
0 | 0 | 0 | 0s | 0s | BEGIN@178 | Encode::UTF_EBCDIC::
0 | 0 | 0 | 0s | 0s | decode | Encode::UTF_EBCDIC::
0 | 0 | 0 | 0s | 0s | encode | Encode::UTF_EBCDIC::
0 | 0 | 0 | 0s | 0s | BEGIN@222 | Encode::XS::
0 | 0 | 0 | 0s | 0s | __ANON__ (xsub) | Encode::
0 | 0 | 0 | 0s | 0s | clone_encoding | Encode::
0 | 0 | 0 | 0s | 0s | define_alias | Encode::
0 | 0 | 0 | 0s | 0s | define_encoding | Encode::
0 | 0 | 0 | 0s | 0s | encodings | Encode::
0 | 0 | 0 | 0s | 0s | find_alias | Encode::
0 | 0 | 0 | 0s | 0s | find_encoding | Encode::
0 | 0 | 0 | 0s | 0s | find_mime_encoding | Encode::
0 | 0 | 0 | 0s | 0s | getEncoding | Encode::
0 | 0 | 0 | 0s | 0s | onBOOT (xsub) | Encode::
0 | 0 | 0 | 0s | 0s | perlio_ok | Encode::
0 | 0 | 0 | 0s | 0s | resolve_alias | Encode::
0 | 0 | 0 | 0s | 0s | BEGIN@227 | Encode::utf8::
0 | 0 | 0 | 0s | 0s | BEGIN@241 | Encode::utf8::
0 | 0 | 0 | 0s | 0s | cat_decode | Encode::utf8::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | # | ||||
2 | # $Id: Encode.pm,v 3.06 2020/05/02 02:31:14 dankogai Exp $ | ||||
3 | # | ||||
4 | package Encode; | ||||
5 | use strict; | ||||
6 | use warnings; | ||||
7 | use constant DEBUG => !!$ENV{PERL_ENCODE_DEBUG}; | ||||
8 | our $VERSION; | ||||
9 | BEGIN { | ||||
10 | $VERSION = sprintf "%d.%02d", q$Revision: 3.06 $ =~ /(\d+)/g; | ||||
11 | require XSLoader; | ||||
12 | XSLoader::load( __PACKAGE__, $VERSION ); | ||||
13 | } | ||||
14 | |||||
15 | use Exporter 5.57 'import'; | ||||
16 | |||||
17 | use Carp (); | ||||
18 | our @CARP_NOT = qw(Encode::Encoder); | ||||
19 | |||||
20 | # Public, encouraged API is exported by default | ||||
21 | |||||
22 | our @EXPORT = qw( | ||||
23 | decode decode_utf8 encode encode_utf8 str2bytes bytes2str | ||||
24 | encodings find_encoding find_mime_encoding clone_encoding | ||||
25 | ); | ||||
26 | our @FB_FLAGS = qw( | ||||
27 | DIE_ON_ERR WARN_ON_ERR RETURN_ON_ERR LEAVE_SRC | ||||
28 | PERLQQ HTMLCREF XMLCREF STOP_AT_PARTIAL | ||||
29 | ); | ||||
30 | our @FB_CONSTS = qw( | ||||
31 | FB_DEFAULT FB_CROAK FB_QUIET FB_WARN | ||||
32 | FB_PERLQQ FB_HTMLCREF FB_XMLCREF | ||||
33 | ); | ||||
34 | our @EXPORT_OK = ( | ||||
35 | qw( | ||||
36 | _utf8_off _utf8_on define_encoding from_to is_16bit is_8bit | ||||
37 | is_utf8 perlio_ok resolve_alias utf8_downgrade utf8_upgrade | ||||
38 | ), | ||||
39 | @FB_FLAGS, @FB_CONSTS, | ||||
40 | ); | ||||
41 | |||||
42 | our %EXPORT_TAGS = ( | ||||
43 | all => [ @EXPORT, @EXPORT_OK ], | ||||
44 | default => [ @EXPORT ], | ||||
45 | fallbacks => [ @FB_CONSTS ], | ||||
46 | fallback_all => [ @FB_CONSTS, @FB_FLAGS ], | ||||
47 | ); | ||||
48 | |||||
49 | # Documentation moved after __END__ for speed - NI-S | ||||
50 | |||||
51 | our $ON_EBCDIC = ( ord("A") == 193 ); | ||||
52 | |||||
53 | use Encode::Alias (); | ||||
54 | use Encode::MIME::Name; | ||||
55 | |||||
56 | use Storable; | ||||
57 | |||||
58 | # Make a %Encoding package variable to allow a certain amount of cheating | ||||
59 | our %Encoding; | ||||
60 | our %ExtModule; | ||||
61 | require Encode::Config; | ||||
62 | # See | ||||
63 | # https://bugzilla.redhat.com/show_bug.cgi?id=435505#c2 | ||||
64 | # to find why sig handlers inside eval{} are disabled. | ||||
65 | eval { | ||||
66 | local $SIG{__DIE__}; | ||||
67 | local $SIG{__WARN__}; | ||||
68 | local @INC = @INC || (); | ||||
69 | pop @INC if $INC[-1] eq '.'; | ||||
70 | require Encode::ConfigLocal; | ||||
71 | }; | ||||
72 | |||||
73 | sub encodings { | ||||
74 | my %enc; | ||||
75 | my $arg = $_[1] || ''; | ||||
76 | if ( $arg eq ":all" ) { | ||||
77 | %enc = ( %Encoding, %ExtModule ); | ||||
78 | } | ||||
79 | else { | ||||
80 | %enc = %Encoding; | ||||
81 | for my $mod ( map { m/::/ ? $_ : "Encode::$_" } @_ ) { | ||||
82 | DEBUG and warn $mod; | ||||
83 | for my $enc ( keys %ExtModule ) { | ||||
84 | $ExtModule{$enc} eq $mod and $enc{$enc} = $mod; | ||||
85 | } | ||||
86 | } | ||||
87 | } | ||||
88 | return sort { lc $a cmp lc $b } | ||||
89 | grep { !/^(?:Internal|Unicode|Guess)$/o } keys %enc; | ||||
90 | } | ||||
91 | |||||
92 | sub perlio_ok { | ||||
93 | my $obj = ref( $_[0] ) ? $_[0] : find_encoding( $_[0] ); | ||||
94 | $obj->can("perlio_ok") and return $obj->perlio_ok(); | ||||
95 | return 0; # safety net | ||||
96 | } | ||||
97 | |||||
98 | sub define_encoding { | ||||
99 | my $obj = shift; | ||||
100 | my $name = shift; | ||||
101 | $Encoding{$name} = $obj; | ||||
102 | my $lc = lc($name); | ||||
103 | define_alias( $lc => $obj ) unless $lc eq $name; | ||||
104 | while (@_) { | ||||
105 | my $alias = shift; | ||||
106 | define_alias( $alias, $obj ); | ||||
107 | } | ||||
108 | my $class = ref($obj); | ||||
109 | push @Encode::CARP_NOT, $class unless grep { $_ eq $class } @Encode::CARP_NOT; | ||||
110 | push @Encode::Encoding::CARP_NOT, $class unless grep { $_ eq $class } @Encode::Encoding::CARP_NOT; | ||||
111 | return $obj; | ||||
112 | } | ||||
113 | |||||
114 | sub getEncoding { | ||||
115 | my ( $class, $name, $skip_external ) = @_; | ||||
116 | |||||
117 | defined($name) or return; | ||||
118 | |||||
119 | $name =~ s/\s+//g; # https://rt.cpan.org/Ticket/Display.html?id=65796 | ||||
120 | |||||
121 | ref($name) && $name->can('renew') and return $name; | ||||
122 | exists $Encoding{$name} and return $Encoding{$name}; | ||||
123 | my $lc = lc $name; | ||||
124 | exists $Encoding{$lc} and return $Encoding{$lc}; | ||||
125 | |||||
126 | my $oc = $class->find_alias($name); | ||||
127 | defined($oc) and return $oc; | ||||
128 | $lc ne $name and $oc = $class->find_alias($lc); | ||||
129 | defined($oc) and return $oc; | ||||
130 | |||||
131 | unless ($skip_external) { | ||||
132 | if ( my $mod = $ExtModule{$name} || $ExtModule{$lc} ) { | ||||
133 | $mod =~ s,::,/,g; | ||||
134 | $mod .= '.pm'; | ||||
135 | eval { require $mod; }; | ||||
136 | exists $Encoding{$name} and return $Encoding{$name}; | ||||
137 | } | ||||
138 | } | ||||
139 | return; | ||||
140 | } | ||||
141 | |||||
142 | # HACK: These two functions must be defined in Encode and because of | ||||
143 | # cyclic dependency between Encode and Encode::Alias, Exporter does not work | ||||
144 | sub find_alias { | ||||
145 | goto &Encode::Alias::find_alias; | ||||
146 | } | ||||
147 | sub define_alias { | ||||
148 | goto &Encode::Alias::define_alias; | ||||
149 | } | ||||
150 | |||||
151 | sub find_encoding($;$) { | ||||
152 | my ( $name, $skip_external ) = @_; | ||||
153 | return __PACKAGE__->getEncoding( $name, $skip_external ); | ||||
154 | } | ||||
155 | |||||
156 | sub find_mime_encoding($;$) { | ||||
157 | my ( $mime_name, $skip_external ) = @_; | ||||
158 | my $name = Encode::MIME::Name::get_encode_name( $mime_name ); | ||||
159 | return find_encoding( $name, $skip_external ); | ||||
160 | } | ||||
161 | |||||
162 | sub resolve_alias($) { | ||||
163 | my $obj = find_encoding(shift); | ||||
164 | defined $obj and return $obj->name; | ||||
165 | return; | ||||
166 | } | ||||
167 | |||||
168 | sub clone_encoding($) { | ||||
169 | my $obj = find_encoding(shift); | ||||
170 | ref $obj or return; | ||||
171 | return Storable::dclone($obj); | ||||
172 | } | ||||
173 | |||||
174 | onBOOT; | ||||
175 | |||||
176 | if ($ON_EBCDIC) { | ||||
177 | package Encode::UTF_EBCDIC; | ||||
178 | use parent 'Encode::Encoding'; | ||||
179 | my $obj = bless { Name => "UTF_EBCDIC" } => "Encode::UTF_EBCDIC"; | ||||
180 | Encode::define_encoding($obj, 'Unicode'); | ||||
181 | sub decode { | ||||
182 | my ( undef, $str, $chk ) = @_; | ||||
183 | my $res = ''; | ||||
184 | for ( my $i = 0 ; $i < length($str) ; $i++ ) { | ||||
185 | $res .= | ||||
186 | chr( | ||||
187 | utf8::unicode_to_native( ord( substr( $str, $i, 1 ) ) ) | ||||
188 | ); | ||||
189 | } | ||||
190 | $_[1] = '' if $chk; | ||||
191 | return $res; | ||||
192 | } | ||||
193 | sub encode { | ||||
194 | my ( undef, $str, $chk ) = @_; | ||||
195 | my $res = ''; | ||||
196 | for ( my $i = 0 ; $i < length($str) ; $i++ ) { | ||||
197 | $res .= | ||||
198 | chr( | ||||
199 | utf8::native_to_unicode( ord( substr( $str, $i, 1 ) ) ) | ||||
200 | ); | ||||
201 | } | ||||
202 | $_[1] = '' if $chk; | ||||
203 | return $res; | ||||
204 | } | ||||
205 | } else { | ||||
206 | package Encode::Internal; | ||||
207 | use parent 'Encode::Encoding'; | ||||
208 | my $obj = bless { Name => "Internal" } => "Encode::Internal"; | ||||
209 | Encode::define_encoding($obj, 'Unicode'); | ||||
210 | sub decode { | ||||
211 | my ( undef, $str, $chk ) = @_; | ||||
212 | utf8::upgrade($str); | ||||
213 | $_[1] = '' if $chk; | ||||
214 | return $str; | ||||
215 | } | ||||
216 | *encode = \&decode; | ||||
217 | } | ||||
218 | |||||
219 | { | ||||
220 | # https://rt.cpan.org/Public/Bug/Display.html?id=103253 | ||||
221 | package Encode::XS; | ||||
222 | use parent 'Encode::Encoding'; | ||||
223 | } | ||||
224 | |||||
225 | { | ||||
226 | package Encode::utf8; | ||||
227 | use parent 'Encode::Encoding'; | ||||
228 | my %obj = ( | ||||
229 | 'utf8' => { Name => 'utf8' }, | ||||
230 | 'utf-8-strict' => { Name => 'utf-8-strict', strict_utf8 => 1 } | ||||
231 | ); | ||||
232 | for ( keys %obj ) { | ||||
233 | bless $obj{$_} => __PACKAGE__; | ||||
234 | Encode::define_encoding( $obj{$_} => $_ ); | ||||
235 | } | ||||
236 | sub cat_decode { | ||||
237 | # ($obj, $dst, $src, $pos, $trm, $chk) | ||||
238 | # currently ignores $chk | ||||
239 | my ( undef, undef, undef, $pos, $trm ) = @_; | ||||
240 | my ( $rdst, $rsrc, $rpos ) = \@_[ 1, 2, 3 ]; | ||||
241 | use bytes; | ||||
242 | if ( ( my $npos = index( $$rsrc, $trm, $pos ) ) >= 0 ) { | ||||
243 | $$rdst .= | ||||
244 | substr( $$rsrc, $pos, $npos - $pos + length($trm) ); | ||||
245 | $$rpos = $npos + length($trm); | ||||
246 | return 1; | ||||
247 | } | ||||
248 | $$rdst .= substr( $$rsrc, $pos ); | ||||
249 | $$rpos = length($$rsrc); | ||||
250 | return ''; | ||||
251 | } | ||||
252 | } | ||||
253 | |||||
254 | 1; | ||||
255 | |||||
256 | __END__ | ||||
# spent 37.1ms within Encode::_utf8_off which was called 71622 times, avg 518ns/call:
# 71622 times (37.1ms+0s) by Locale::Messages::turn_utf_8_off at line 9 of (eval 234)[Locale/Messages.pm:138], avg 518ns/call | |||||
# spent 5.27ms (2.15+3.12) within Encode::decode_utf8 which was called 345 times, avg 15µs/call:
# 345 times (2.15ms+3.12ms) by Sympa::Tools::Text::canonic_text at line 135 of /usr/local/libexec/sympa/Sympa/Tools/Text.pm, avg 15µs/call | |||||
# spent 424µs within Encode::encode_utf8 which was called 345 times, avg 1µs/call:
# 345 times (424µs+0s) by Sympa::Tools::Text::canonic_text at line 148 of /usr/local/libexec/sympa/Sympa/Tools/Text.pm, avg 1µs/call | |||||
# spent 471µs within Encode::is_utf8 which was called 690 times, avg 683ns/call:
# 345 times (338µs+0s) by Sympa::Tools::Text::canonic_text at line 129 of /usr/local/libexec/sympa/Sympa/Tools/Text.pm, avg 981ns/call
# 345 times (133µs+0s) by Sympa::Tools::Text::canonic_text at line 145 of /usr/local/libexec/sympa/Sympa/Tools/Text.pm, avg 386ns/call | |||||
# spent 3.12ms (2.22+900µs) within Encode::utf8::decode which was called 345 times, avg 9µs/call:
# 345 times (2.22ms+900µs) by Encode::decode_utf8 at line 135 of /usr/local/libexec/sympa/Sympa/Tools/Text.pm, avg 9µs/call |