← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:08 2021

Filename/usr/local/lib/perl5/5.32/mach/Encode/MIME/Header.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sEncode::MIME::Header::::BEGIN@2Encode::MIME::Header::BEGIN@2
0000s0sEncode::MIME::Header::::BEGIN@3Encode::MIME::Header::BEGIN@3
0000s0sEncode::MIME::Header::::BEGIN@41Encode::MIME::Header::BEGIN@41
0000s0sEncode::MIME::Header::::BEGIN@7Encode::MIME::Header::BEGIN@7
0000s0sEncode::MIME::Header::::BEGIN@8Encode::MIME::Header::BEGIN@8
0000s0sEncode::MIME::Header::::BEGIN@9Encode::MIME::Header::BEGIN@9
0000s0sEncode::MIME::Header::::CORE:matchEncode::MIME::Header::CORE:match (opcode)
0000s0sEncode::MIME::Header::::CORE:qrEncode::MIME::Header::CORE:qr (opcode)
0000s0sEncode::MIME::Header::::CORE:regcompEncode::MIME::Header::CORE:regcomp (opcode)
0000s0sEncode::MIME::Header::::_decode_bEncode::MIME::Header::_decode_b
0000s0sEncode::MIME::Header::::_decode_octetsEncode::MIME::Header::_decode_octets
0000s0sEncode::MIME::Header::::_decode_qEncode::MIME::Header::_decode_q
0000s0sEncode::MIME::Header::::_encode_bEncode::MIME::Header::_encode_b
0000s0sEncode::MIME::Header::::_encode_qEncode::MIME::Header::_encode_q
0000s0sEncode::MIME::Header::::_encode_stringEncode::MIME::Header::_encode_string
0000s0sEncode::MIME::Header::::_encode_wordEncode::MIME::Header::_encode_word
0000s0sEncode::MIME::Header::::_encoded_b_lenEncode::MIME::Header::_encoded_b_len
0000s0sEncode::MIME::Header::::_encoded_q_lenEncode::MIME::Header::_encoded_q_len
0000s0sEncode::MIME::Header::::_encoded_word_lenEncode::MIME::Header::_encoded_word_len
0000s0sEncode::MIME::Header::::_fold_lineEncode::MIME::Header::_fold_line
0000s0sEncode::MIME::Header::::decodeEncode::MIME::Header::decode
0000s0sEncode::MIME::Header::::encodeEncode::MIME::Header::encode
0000s0sEncode::MIME::Header::::needs_linesEncode::MIME::Header::needs_lines
0000s0sEncode::MIME::Header::::perlio_okEncode::MIME::Header::perlio_ok
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Encode::MIME::Header;
2use strict;
3use warnings;
4
5our $VERSION = do { my @r = ( q$Revision: 2.28 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r };
6
7use Carp ();
8use Encode ();
9use MIME::Base64 ();
10
11my %seed = (
12 decode_b => 1, # decodes 'B' encoding ?
13 decode_q => 1, # decodes 'Q' encoding ?
14 encode => 'B', # encode with 'B' or 'Q' ?
15 charset => 'UTF-8', # encode charset
16 bpl => 75, # bytes per line
17);
18
19my @objs;
20
21push @objs, bless {
22 %seed,
23 Name => 'MIME-Header',
24} => __PACKAGE__;
25
26push @objs, bless {
27 %seed,
28 decode_q => 0,
29 Name => 'MIME-B',
30} => __PACKAGE__;
31
32push @objs, bless {
33 %seed,
34 decode_b => 0,
35 encode => 'Q',
36 Name => 'MIME-Q',
37} => __PACKAGE__;
38
39Encode::define_encoding($_, $_->{Name}) foreach @objs;
40
41use parent qw(Encode::Encoding);
42
43sub needs_lines { 1 }
44sub perlio_ok { 0 }
45
46# RFC 2047 and RFC 2231 grammar
47my $re_charset = qr/[!"#\$%&'+\-0-9A-Z\\\^_`a-z\{\|\}~]+/;
48my $re_language = qr/[A-Za-z]{1,8}(?:-[0-9A-Za-z]{1,8})*/;
49my $re_encoding = qr/[QqBb]/;
50my $re_encoded_text = qr/[^\?]*/;
51my $re_encoded_word = qr/=\?$re_charset(?:\*$re_language)?\?$re_encoding\?$re_encoded_text\?=/;
52my $re_capture_encoded_word = qr/=\?($re_charset)((?:\*$re_language)?)\?($re_encoding\?$re_encoded_text)\?=/;
53my $re_capture_encoded_word_split = qr/=\?($re_charset)((?:\*$re_language)?)\?($re_encoding)\?($re_encoded_text)\?=/;
54
55# in strict mode check also for valid base64 characters and also for valid quoted printable codes
56my $re_encoding_strict_b = qr/[Bb]/;
57my $re_encoding_strict_q = qr/[Qq]/;
58my $re_encoded_text_strict_b = qr/[0-9A-Za-z\+\/]*={0,2}/;
59my $re_encoded_text_strict_q = qr/(?:[\x21-\x3C\x3E\x40-\x7E]|=[0-9A-Fa-f]{2})*/; # NOTE: first part are printable US-ASCII except ?, =, SPACE and TAB
60my $re_encoded_word_strict = qr/=\?$re_charset(?:\*$re_language)?\?(?:$re_encoding_strict_b\?$re_encoded_text_strict_b|$re_encoding_strict_q\?$re_encoded_text_strict_q)\?=/;
61my $re_capture_encoded_word_strict = qr/=\?($re_charset)((?:\*$re_language)?)\?($re_encoding_strict_b\?$re_encoded_text_strict_b|$re_encoding_strict_q\?$re_encoded_text_strict_q)\?=/;
62
63my $re_newline = qr/(?:\r\n|[\r\n])/;
64
65# in strict mode encoded words must be always separated by spaces or tabs (or folded newline)
66# except in comments when separator between words and comment round brackets can be omitted
67my $re_word_begin_strict = qr/(?:(?:[ \t]|\A)\(?|(?:[^\\]|\A)\)\()/;
68my $re_word_sep_strict = qr/(?:$re_newline?[ \t])+/;
69my $re_word_end_strict = qr/(?:\)\(|\)?(?:$re_newline?[ \t]|\z))/;
70
71my $re_match = qr/()((?:$re_encoded_word\s*)*$re_encoded_word)()/;
72my $re_match_strict = qr/($re_word_begin_strict)((?:$re_encoded_word_strict$re_word_sep_strict)*$re_encoded_word_strict)(?=$re_word_end_strict)/;
73
74my $re_capture = qr/$re_capture_encoded_word(?:\s*)?/;
75my $re_capture_strict = qr/$re_capture_encoded_word_strict$re_word_sep_strict?/;
76
77our $STRICT_DECODE = 0;
78
79sub decode($$;$) {
80 my ($obj, $str, $chk) = @_;
81 return undef unless defined $str;
82
83 my $re_match_decode = $STRICT_DECODE ? $re_match_strict : $re_match;
84 my $re_capture_decode = $STRICT_DECODE ? $re_capture_strict : $re_capture;
85
86 my $stop = 0;
87 my $output = substr($str, 0, 0); # to propagate taintedness
88
89 # decode each line separately, match whole continuous folded line at one call
90 1 while not $stop and $str =~ s{^((?:[^\r\n]*(?:$re_newline[ \t])?)*)($re_newline)?}{
91
92 my $line = $1;
93 my $sep = defined $2 ? $2 : '';
94
95 $stop = 1 unless length($line) or length($sep);
96
97 # NOTE: this code partially could break $chk support
98 # in non strict mode concat consecutive encoded mime words with same charset, language and encoding
99 # fixes breaking inside multi-byte characters
100 1 while not $STRICT_DECODE and $line =~ s/$re_capture_encoded_word_split\s*=\?\1\2\?\3\?($re_encoded_text)\?=/=\?$1$2\?$3\?$4$5\?=/so;
101
102 # process sequence of encoded MIME words at once
103 1 while not $stop and $line =~ s{^(.*?)$re_match_decode}{
104
105 my $begin = $1 . $2;
106 my $words = $3;
107
108 $begin =~ tr/\r\n//d;
109 $output .= $begin;
110
111 # decode one MIME word
112 1 while not $stop and $words =~ s{^(.*?)($re_capture_decode)}{
113
114 $output .= $1;
115 my $orig = $2;
116 my $charset = $3;
117 my ($mime_enc, $text) = split /\?/, $5;
118
119 $text =~ tr/\r\n//d;
120
121 my $enc = Encode::find_mime_encoding($charset);
122
123 # in non strict mode allow also perl encoding aliases
124 if ( not defined $enc and not $STRICT_DECODE ) {
125 # make sure that decoded string will be always strict UTF-8
126 $charset = 'UTF-8' if lc($charset) eq 'utf8';
127 $enc = Encode::find_encoding($charset);
128 }
129
130 if ( not defined $enc ) {
131 Carp::croak qq(Unknown charset "$charset") if not ref $chk and $chk and $chk & Encode::DIE_ON_ERR;
132 Carp::carp qq(Unknown charset "$charset") if not ref $chk and $chk and $chk & Encode::WARN_ON_ERR;
133 $stop = 1 if not ref $chk and $chk and $chk & Encode::RETURN_ON_ERR;
134 $output .= ($output =~ /(?:\A|[ \t])$/ ? '' : ' ') . $orig unless $stop; # $orig mime word is separated by whitespace
135 $stop ? $orig : '';
136 } else {
137 if ( uc($mime_enc) eq 'B' and $obj->{decode_b} ) {
138 my $decoded = _decode_b($enc, $text, $chk);
139 $stop = 1 if not defined $decoded and not ref $chk and $chk and $chk & Encode::RETURN_ON_ERR;
140 $output .= (defined $decoded ? $decoded : $text) unless $stop;
141 $stop ? $orig : '';
142 } elsif ( uc($mime_enc) eq 'Q' and $obj->{decode_q} ) {
143 my $decoded = _decode_q($enc, $text, $chk);
144 $stop = 1 if not defined $decoded and not ref $chk and $chk and $chk & Encode::RETURN_ON_ERR;
145 $output .= (defined $decoded ? $decoded : $text) unless $stop;
146 $stop ? $orig : '';
147 } else {
148 Carp::croak qq(MIME "$mime_enc" unsupported) if not ref $chk and $chk and $chk & Encode::DIE_ON_ERR;
149 Carp::carp qq(MIME "$mime_enc" unsupported) if not ref $chk and $chk and $chk & Encode::WARN_ON_ERR;
150 $stop = 1 if not ref $chk and $chk and $chk & Encode::RETURN_ON_ERR;
151 $output .= ($output =~ /(?:\A|[ \t])$/ ? '' : ' ') . $orig unless $stop; # $orig mime word is separated by whitespace
152 $stop ? $orig : '';
153 }
154 }
155
156 }se;
157
158 if ( not $stop ) {
159 $output .= $words;
160 $words = '';
161 }
162
163 $words;
164
165 }se;
166
167 if ( not $stop ) {
168 $line =~ tr/\r\n//d;
169 $output .= $line . $sep;
170 $line = '';
171 $sep = '';
172 }
173
174 $line . $sep;
175
176 }se;
177
178 $_[1] = $str if not ref $chk and $chk and !($chk & Encode::LEAVE_SRC);
179 return $output;
180}
181
182sub _decode_b {
183 my ($enc, $text, $chk) = @_;
184 # MIME::Base64::decode ignores everything after a '=' padding character
185 # in non strict mode split string after each sequence of padding characters and decode each substring
186 my $octets = $STRICT_DECODE ?
187 MIME::Base64::decode($text) :
188 join('', map { MIME::Base64::decode($_) } split /(?<==)(?=[^=])/, $text);
189 return _decode_octets($enc, $octets, $chk);
190}
191
192sub _decode_q {
193 my ($enc, $text, $chk) = @_;
194 $text =~ s/_/ /go;
195 $text =~ s/=([0-9A-Fa-f]{2})/pack('C', hex($1))/ego;
196 return _decode_octets($enc, $text, $chk);
197}
198
199sub _decode_octets {
200 my ($enc, $octets, $chk) = @_;
201 $chk = 0 unless defined $chk;
202 $chk &= ~Encode::LEAVE_SRC if not ref $chk and $chk;
203 my $output = $enc->decode($octets, $chk);
204 return undef if not ref $chk and $chk and $octets ne '';
205 return $output;
206}
207
208sub encode($$;$) {
209 my ($obj, $str, $chk) = @_;
210 return undef unless defined $str;
211 my $output = $obj->_fold_line($obj->_encode_string($str, $chk));
212 $_[1] = $str if not ref $chk and $chk and !($chk & Encode::LEAVE_SRC);
213 return $output . substr($str, 0, 0); # to propagate taintedness
214}
215
216sub _fold_line {
217 my ($obj, $line) = @_;
218 my $bpl = $obj->{bpl};
219 my $output = '';
220
221 while ( length($line) ) {
222 if ( $line =~ s/^(.{0,$bpl})(\s|\z)// ) {
223 $output .= $1;
224 $output .= "\r\n" . $2 if length($line);
225 } elsif ( $line =~ s/(\s)(.*)$// ) {
226 $output .= $line;
227 $line = $2;
228 $output .= "\r\n" . $1 if length($line);
229 } else {
230 $output .= $line;
231 last;
232 }
233 }
234
235 return $output;
236}
237
238sub _encode_string {
239 my ($obj, $str, $chk) = @_;
240 my $wordlen = $obj->{bpl} > 76 ? 76 : $obj->{bpl};
241 my $enc = Encode::find_mime_encoding($obj->{charset});
242 my $enc_chk = $chk;
243 $enc_chk = 0 unless defined $enc_chk;
244 $enc_chk |= Encode::LEAVE_SRC if not ref $enc_chk and $enc_chk;
245 my @result = ();
246 my $octets = '';
247 while ( length( my $chr = substr($str, 0, 1, '') ) ) {
248 my $seq = $enc->encode($chr, $enc_chk);
249 if ( not length($seq) ) {
250 substr($str, 0, 0, $chr);
251 last;
252 }
253 if ( $obj->_encoded_word_len($octets . $seq) > $wordlen ) {
254 push @result, $obj->_encode_word($octets);
255 $octets = '';
256 }
257 $octets .= $seq;
258 }
259 length($octets) and push @result, $obj->_encode_word($octets);
260 $_[1] = $str if not ref $chk and $chk and !($chk & Encode::LEAVE_SRC);
261 return join(' ', @result);
262}
263
264sub _encode_word {
265 my ($obj, $octets) = @_;
266 my $charset = $obj->{charset};
267 my $encode = $obj->{encode};
268 my $text = $encode eq 'B' ? _encode_b($octets) : _encode_q($octets);
269 return "=?$charset?$encode?$text?=";
270}
271
272sub _encoded_word_len {
273 my ($obj, $octets) = @_;
274 my $charset = $obj->{charset};
275 my $encode = $obj->{encode};
276 my $text_len = $encode eq 'B' ? _encoded_b_len($octets) : _encoded_q_len($octets);
277 return length("=?$charset?$encode??=") + $text_len;
278}
279
280sub _encode_b {
281 my ($octets) = @_;
282 return MIME::Base64::encode($octets, '');
283}
284
285sub _encoded_b_len {
286 my ($octets) = @_;
287 return ( length($octets) + 2 ) / 3 * 4;
288}
289
290my $re_invalid_q_char = qr/[^0-9A-Za-z !*+\-\/]/;
291
292sub _encode_q {
293 my ($octets) = @_;
294 $octets =~ s{($re_invalid_q_char)}{
295 join('', map { sprintf('=%02X', $_) } unpack('C*', $1))
296 }egox;
297 $octets =~ s/ /_/go;
298 return $octets;
299}
300
301sub _encoded_q_len {
302 my ($octets) = @_;
303 my $invalid_count = () = $octets =~ /$re_invalid_q_char/sgo;
304 return ( $invalid_count * 3 ) + ( length($octets) - $invalid_count );
305}
306
3071;
308__END__