File Coverage

blib/lib/MIME/Decoder.pm
Criterion Covered Total %
statement 70 88 79.5
branch 21 32 65.6
condition 5 13 38.4
subroutine 16 21 76.1
pod 13 13 100.0
total 125 167 74.8


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