← 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:12 2021

Filename/usr/local/lib/perl5/site_perl/MIME/Decoder.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sMIME::Decoder::::BEGIN@84MIME::Decoder::BEGIN@84
0000s0sMIME::Decoder::::BEGIN@85MIME::Decoder::BEGIN@85
0000s0sMIME::Decoder::::BEGIN@88MIME::Decoder::BEGIN@88
0000s0sMIME::Decoder::::BEGIN@89MIME::Decoder::BEGIN@89
0000s0sMIME::Decoder::::BEGIN@90MIME::Decoder::BEGIN@90
0000s0sMIME::Decoder::::BEGIN@93MIME::Decoder::BEGIN@93
0000s0sMIME::Decoder::::BEGIN@94MIME::Decoder::BEGIN@94
0000s0sMIME::Decoder::::__ANON__[:455]MIME::Decoder::__ANON__[:455]
0000s0sMIME::Decoder::::bestMIME::Decoder::best
0000s0sMIME::Decoder::::decodeMIME::Decoder::decode
0000s0sMIME::Decoder::::decode_itMIME::Decoder::decode_it
0000s0sMIME::Decoder::::encodeMIME::Decoder::encode
0000s0sMIME::Decoder::::encode_itMIME::Decoder::encode_it
0000s0sMIME::Decoder::::encodingMIME::Decoder::encoding
0000s0sMIME::Decoder::::filterMIME::Decoder::filter
0000s0sMIME::Decoder::::headMIME::Decoder::head
0000s0sMIME::Decoder::::initMIME::Decoder::init
0000s0sMIME::Decoder::::installMIME::Decoder::install
0000s0sMIME::Decoder::::newMIME::Decoder::new
0000s0sMIME::Decoder::::supportedMIME::Decoder::supported
0000s0sMIME::Decoder::::uninstallMIME::Decoder::uninstall
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package MIME::Decoder;
2
3
4=head1 NAME
5
6MIME::Decoder - an object for decoding the body part of a MIME stream
7
8
9=head1 SYNOPSIS
10
11Before reading further, you should see L<MIME::Tools> to make sure that
12you understand where this module fits into the grand scheme of things.
13Go on, do it now. I'll wait.
14
15Ready? Ok...
16
17
18=head2 Decoding a data stream
19
20Here's a simple filter program to read quoted-printable data from STDIN
21(until EOF) and write the decoded data to STDOUT:
22
23 use MIME::Decoder;
24
25 $decoder = new MIME::Decoder 'quoted-printable' or die "unsupported";
26 $decoder->decode(\*STDIN, \*STDOUT);
27
28
29=head2 Encoding a data stream
30
31Here's a simple filter program to read binary data from STDIN
32(until EOF) and write base64-encoded data to STDOUT:
33
34 use MIME::Decoder;
35
36 $decoder = new MIME::Decoder 'base64' or die "unsupported";
37 $decoder->encode(\*STDIN, \*STDOUT);
38
39
40=head2 Non-standard encodings
41
42You can B<write and install> your own decoders so that
43MIME::Decoder will know about them:
44
45 use MyBase64Decoder;
46
47 install MyBase64Decoder 'base64';
48
49You can also B<test> if a given encoding is supported:
50
51 if (supported MIME::Decoder 'x-uuencode') {
52 ### we can uuencode!
53 }
54
55
56=head1 DESCRIPTION
57
58This abstract class, and its private concrete subclasses (see below)
59provide an OO front end to the actions of...
60
61=over 4
62
63=item *
64
65Decoding a MIME-encoded stream
66
67=item *
68
69Encoding a raw data stream into a MIME-encoded stream.
70
71=back
72
73The constructor for MIME::Decoder takes the name of an encoding
74(C<base64>, C<7bit>, etc.), and returns an instance of a I<subclass>
75of MIME::Decoder whose C<decode()> method will perform the appropriate
76decoding action, and whose C<encode()> method will perform the appropriate
77encoding action.
78
79
80=cut
81
82
83### Pragmas:
84use strict;
85use vars qw($VERSION %DecoderFor);
86
87### System modules:
88use IPC::Open2;
89use IO::Select;
90use FileHandle;
91
92### Kit modules:
93use MIME::Tools qw(:config :msgs);
94use Carp;
95
96#------------------------------
97#
98# Globals
99#
100#------------------------------
101
102### The stream decoders:
103%DecoderFor = (
104
105 ### Standard...
106 '7bit' => 'MIME::Decoder::NBit',
107 '8bit' => 'MIME::Decoder::NBit',
108 'base64' => 'MIME::Decoder::Base64',
109 'binary' => 'MIME::Decoder::Binary',
110 'none' => 'MIME::Decoder::Binary',
111 'quoted-printable' => 'MIME::Decoder::QuotedPrint',
112
113 ### Non-standard...
114 'binhex' => 'MIME::Decoder::BinHex',
115 'binhex40' => 'MIME::Decoder::BinHex',
116 'mac-binhex40' => 'MIME::Decoder::BinHex',
117 'mac-binhex' => 'MIME::Decoder::BinHex',
118 'x-uu' => 'MIME::Decoder::UU',
119 'x-uuencode' => 'MIME::Decoder::UU',
120
121 ### This was removed, since I fear that x-gzip != x-gzip64...
122### 'x-gzip' => 'MIME::Decoder::Gzip64',
123
124 ### This is no longer installed by default, since not all folks have gzip:
125### 'x-gzip64' => 'MIME::Decoder::Gzip64',
126);
127
128### The package version, both in 1.23 style *and* usable by MakeMaker:
129$VERSION = "5.509";
130
131### Me:
132my $ME = 'MIME::Decoder';
133
134
135#------------------------------
136
137=head1 PUBLIC INTERFACE
138
139=head2 Standard interface
140
141If all you are doing is I<using> this class, here's all you'll need...
142
143=over 4
144
145=cut
146
147#------------------------------
148
149=item new ENCODING
150
151I<Class method, constructor.>
152Create and return a new decoder object which can handle the
153given ENCODING.
154
155 my $decoder = new MIME::Decoder "7bit";
156
157Returns the undefined value if no known decoders are appropriate.
158
159=cut
160
161sub new {
162 my ($class, @args) = @_;
163 my ($encoding) = @args;
164
165 ### Coerce the type to be legit:
166 $encoding = lc($encoding || '');
167
168 ### Get the class:
169 my $concrete_name = $DecoderFor{$encoding};
170
171 if( ! $concrete_name ) {
172 carp "no decoder for $encoding";
173 return undef;
174 }
175
176 ### Create the new object (if we can):
177 my $self = { MD_Encoding => lc($encoding) };
178 unless (eval "require $concrete_name;") {
179 carp $@;
180 return undef;
181 }
182 bless $self, $concrete_name;
183 $self->init(@args);
184}
185
186#------------------------------
187
188=item best ENCODING
189
190I<Class method, constructor.>
191Exactly like new(), except that this defaults any unsupported encoding to
192"binary", after raising a suitable warning (it's a fatal error if there's
193no binary decoder).
194
195 my $decoder = best MIME::Decoder "x-gzip64";
196
197Will either return a decoder, or a raise a fatal exception.
198
199=cut
200
201sub best {
202 my ($class, $enc, @args) = @_;
203 my $self = $class->new($enc, @args);
204 if (!$self) {
205 usage "unsupported encoding '$enc': using 'binary'";
206 $self = $class->new('binary') || croak "ack! no binary decoder!";
207 }
208 $self;
209}
210
211#------------------------------
212
213=item decode INSTREAM,OUTSTREAM
214
215I<Instance method.>
216Decode the document waiting in the input handle INSTREAM,
217writing the decoded information to the output handle OUTSTREAM.
218
219Read the section in this document on I/O handles for more information
220about the arguments. Note that you can still supply old-style
221unblessed filehandles for INSTREAM and OUTSTREAM.
222
223Returns true on success, throws exception on failure.
224
225=cut
226
227sub decode {
228 my ($self, $in, $out) = @_;
229
230 ### Set up the default input record separator to be CRLF:
231 ### $in->input_record_separator("\012\015");
232
233 ### Invoke back-end method to do the work:
234 $self->decode_it($in, $out) ||
235 die "$ME: ".$self->encoding." decoding failed\n";
236 1;
237}
238
239#------------------------------
240
241=item encode INSTREAM,OUTSTREAM
242
243I<Instance method.>
244Encode the document waiting in the input filehandle INSTREAM,
245writing the encoded information to the output stream OUTSTREAM.
246
247Read the section in this document on I/O handles for more information
248about the arguments. Note that you can still supply old-style
249unblessed filehandles for INSTREAM and OUTSTREAM.
250
251Returns true on success, throws exception on failure.
252
253=cut
254
255sub encode {
256 my ($self, $in, $out, $textual_type) = @_;
257
258 ### Invoke back-end method to do the work:
259 $self->encode_it($in, $out, $self->encoding eq 'quoted-printable' ? ($textual_type) : ()) ||
260 die "$ME: ".$self->encoding." encoding failed\n";
261}
262
263#------------------------------
264
265=item encoding
266
267I<Instance method.>
268Return the encoding that this object was created to handle,
269coerced to all lowercase (e.g., C<"base64">).
270
271=cut
272
273sub encoding {
274 shift->{MD_Encoding};
275}
276
277#------------------------------
278
279=item head [HEAD]
280
281I<Instance method.>
282Completely optional: some decoders need to know a little about the file
283they are encoding/decoding; e.g., x-uu likes to have the filename.
284The HEAD is any object which responds to messages like:
285
286 $head->mime_attr('content-disposition.filename');
287
288=cut
289
290sub head {
291 my ($self, $head) = @_;
292 $self->{MD_Head} = $head if @_ > 1;
293 $self->{MD_Head};
294}
295
296#------------------------------
297
298=item supported [ENCODING]
299
300I<Class method.>
301With one arg (an ENCODING name), returns truth if that encoding
302is currently handled, and falsity otherwise. The ENCODING will
303be automatically coerced to lowercase:
304
305 if (supported MIME::Decoder '7BIT') {
306 ### yes, we can handle it...
307 }
308 else {
309 ### drop back six and punt...
310 }
311
312With no args, returns a reference to a hash of all available decoders,
313where the key is the encoding name (all lowercase, like '7bit'),
314and the value is true (it happens to be the name of the class
315that handles the decoding, but you probably shouldn't rely on that).
316You may safely modify this hash; it will I<not> change the way the
317module performs its lookups. Only C<install> can do that.
318
319I<Thanks to Achim Bohnet for suggesting this method.>
320
321=cut
322
323sub supported {
324 my ($class, $decoder) = @_;
325 defined($decoder) ? $DecoderFor{lc($decoder)}: { %DecoderFor };
326}
327
328#------------------------------
329
330=back
331
332=head2 Subclass interface
333
334If you are writing (or installing) a new decoder subclass, there
335are some other methods you'll need to know about:
336
337=over 4
338
339=item decode_it INSTREAM,OUTSTREAM
340
341I<Abstract instance method.>
342The back-end of the B<decode> method. It takes an input handle
343opened for reading (INSTREAM), and an output handle opened for
344writing (OUTSTREAM).
345
346If you are writing your own decoder subclass, you must override this
347method in your class. Your method should read from the input
348handle via C<getline()> or C<read()>, decode this input, and print the
349decoded data to the output handle via C<print()>. You may do this
350however you see fit, so long as the end result is the same.
351
352Note that unblessed references and globrefs are automatically turned
353into I/O handles for you by C<decode()>, so you don't need to worry
354about it.
355
356Your method must return either C<undef> (to indicate failure),
357or C<1> (to indicate success).
358It may also throw an exception to indicate failure.
359
360=cut
361
362sub decode_it {
363 die "attempted to use abstract 'decode_it' method!";
364}
365
366=item encode_it INSTREAM,OUTSTREAM
367
368I<Abstract instance method.>
369The back-end of the B<encode> method. It takes an input handle
370opened for reading (INSTREAM), and an output handle opened for
371writing (OUTSTREAM).
372
373If you are writing your own decoder subclass, you must override this
374method in your class. Your method should read from the input
375handle via C<getline()> or C<read()>, encode this input, and print the
376encoded data to the output handle via C<print()>. You may do this
377however you see fit, so long as the end result is the same.
378
379Note that unblessed references and globrefs are automatically turned
380into I/O handles for you by C<encode()>, so you don't need to worry
381about it.
382
383Your method must return either C<undef> (to indicate failure),
384or C<1> (to indicate success).
385It may also throw an exception to indicate failure.
386
387=cut
388
389sub encode_it {
390 die "attempted to use abstract 'encode_it' method!";
391}
392
393=item filter IN, OUT, COMMAND...
394
395I<Class method, utility.>
396If your decoder involves an external program, you can invoke
397them easily through this method. The command must be a "filter": a
398command that reads input from its STDIN (which will come from the IN argument)
399and writes output to its STDOUT (which will go to the OUT argument).
400
401For example, here's a decoder that un-gzips its data:
402
403 sub decode_it {
404 my ($self, $in, $out) = @_;
405 $self->filter($in, $out, "gzip -d -");
406 }
407
408The usage is similar to IPC::Open2::open2 (which it uses internally),
409so you can specify COMMAND as a single argument or as an array.
410
411=cut
412
413sub filter
414{
415 my ($self, $in, $out, @cmd) = @_;
416 my $buf = '';
417
418 ### Open pipe:
419 STDOUT->flush; ### very important, or else we get duplicate output!
420
421 my $kidpid = open2(my $child_out, my $child_in, @cmd) || die "@cmd: open2 failed: $!";
422
423 ### We have to use select() for doing both reading and writing.
424 my $rsel = IO::Select->new( $child_out );
425 my $wsel = IO::Select->new( $child_in );
426
427 while (1) {
428
429 ### Wait for one hour; if that fails, it's too bad.
430 my ($read, $write) = IO::Select->select( $rsel, $wsel, undef, 3600);
431
432 if( !defined $read && !defined $write ) {
433 kill 1, $kidpid;
434 waitpid $kidpid, 0;
435 die "@cmd: select failed: $!";
436 }
437
438 ### If can read from child:
439 if( my $fh = shift @$read ) {
440 if( $fh->sysread(my $buf, 1024) ) {
441 $out->print($buf);
442 } else {
443 $rsel->remove($fh);
444 $fh->close();
445 }
446 }
447
448 ### If can write to child:
449 if( my $fh = shift @$write ) {
450 if($in->read(my $buf, 1024)) {
451 local $SIG{PIPE} = sub {
452 warn "got SIGPIPE from @cmd";
453 $wsel->remove($fh);
454 $fh->close();
455 };
456 $fh->syswrite( $buf );
457 } else {
458 $wsel->remove($fh);
459 $fh->close();
460 }
461 }
462
463 ### If both $child_out and $child_in are done:
464 last unless ($rsel->count() || $wsel->count());
465 }
466
467 ### Wait for it:
468 waitpid($kidpid, 0) == $kidpid or die "@cmd: couldn't reap child $kidpid";
469 ### Check if it failed:
470 $? == 0 or die "@cmd: bad exit status: \$? = $?";
471 1;
472}
473
474
475#------------------------------
476
477=item init ARGS...
478
479I<Instance method.>
480Do any necessary initialization of the new instance,
481taking whatever arguments were given to C<new()>.
482Should return the self object on success, undef on failure.
483
484=cut
485
486sub init {
487 $_[0];
488}
489
490#------------------------------
491
492=item install ENCODINGS...
493
494I<Class method>.
495Install this class so that each encoding in ENCODINGS is handled by it:
496
497 install MyBase64Decoder 'base64', 'x-base64super';
498
499You should not override this method.
500
501=cut
502
503sub install {
504 my $class = shift;
505 $DecoderFor{lc(shift @_)} = $class while (@_);
506}
507
508#------------------------------
509
510=item uninstall ENCODINGS...
511
512I<Class method>.
513Uninstall support for encodings. This is a way to turn off the decoding
514of "experimental" encodings. For safety, always use MIME::Decoder directly:
515
516 uninstall MIME::Decoder 'x-uu', 'x-uuencode';
517
518You should not override this method.
519
520=cut
521
522sub uninstall {
523 shift;
524 $DecoderFor{lc(shift @_)} = undef while (@_);
525}
526
5271;
528
529__END__