File Coverage

blib/lib/MIME/Decoder/QuotedPrint.pm
Criterion Covered Total %
statement 40 49 81.6
branch 8 12 66.6
condition 1 3 33.3
subroutine 10 10 100.0
pod 2 4 50.0
total 61 78 78.2


line stmt bran cond sub pod time code
1             package MIME::Decoder::QuotedPrint;
2 7     7   1005 use strict;
  7         11  
  7         165  
3 7     7   19 use warnings;
  7         7  
  7         230  
4              
5              
6             =head1 NAME
7              
8             MIME::Decoder::QuotedPrint - encode/decode a "quoted-printable" stream
9              
10              
11             =head1 SYNOPSIS
12              
13             A generic decoder object; see L for usage.
14              
15              
16             =head1 DESCRIPTION
17              
18             A MIME::Decoder subclass for the C<"quoted-printable"> encoding.
19             The name was chosen to jibe with the pre-existing MIME::QuotedPrint
20             utility package, which this class actually uses to translate each line.
21              
22             =over 4
23              
24             =item *
25              
26             The B does a line-by-line translation from input to output.
27              
28             =item *
29              
30             The B does a line-by-line translation, breaking lines
31             so that they fall under the standard 76-character limit for this
32             encoding.
33              
34             =back
35              
36              
37             B just like MIME::QuotedPrint, we currently use the
38             native C<"\n"> for line breaks, and not C. This may
39             need to change in future versions.
40              
41             =head1 SEE ALSO
42              
43             L
44              
45             =head1 AUTHOR
46              
47             Eryq (F), ZeeGee Software Inc (F).
48              
49             All rights reserved. This program is free software; you can redistribute
50             it and/or modify it under the same terms as Perl itself.
51              
52             =cut
53              
54 7     7   20 use vars qw(@ISA $VERSION);
  7         8  
  7         272  
55 7     7   20 use MIME::Decoder;
  7         7  
  7         103  
56 7     7   388 use MIME::QuotedPrint;
  7         159  
  7         641  
57              
58             @ISA = qw(MIME::Decoder);
59              
60             # The package version, both in 1.23 style *and* usable by MakeMaker:
61             $VERSION = "5.508";
62              
63             #------------------------------
64             # If we have MIME::QuotedPrint 3.03 or later, use the three-argument
65             # version. If we have an earlier version of MIME::QuotedPrint, we
66             # may get the wrong results. However, on some systems (RH Linux,
67             # for example), MIME::QuotedPrint is part of the Perl package and
68             # upgrading it separately breaks their magic auto-update tools.
69             # We are supporting older versions of MIME::QuotedPrint even though
70             # they may give incorrect results simply because it's too painful
71             # for many people to upgrade.
72              
73             # The following code is horrible. I know. Beat me up. --dfs
74             BEGIN {
75 7 50   7   37 if (!defined(&encode_qp_threearg)) {
76 7 50       35 if ($::MIME::QuotedPrint::VERSION >= 3.03) {
77 7     65 0 2754 eval 'sub encode_qp_threearg ( $$$ ) { encode_qp(shift, shift, shift); }';
  65         276  
78             } else {
79 0         0 eval 'sub encode_qp_threearg ( $$$ ) { encode_qp(shift); }';
80             }
81             }
82             }
83              
84             #------------------------------
85             #
86             # encode_qp_really STRING TEXTUAL_TYPE_FLAG
87             #
88             # Encode QP, and then follow guideline 8 from RFC 2049 (thanks to Denis
89             # N. Antonioli) whereby we make things a little safer for the transport
90             # and storage of messages. WARNING: we can only do this if the line won't
91             # grow beyond 76 characters!
92             #
93             sub encode_qp_really {
94 65     65 0 4353 my $enc = encode_qp_threearg(shift, undef, not shift);
95 65 100       117 if (length($enc) < 74) {
96 59         56 $enc =~ s/^\.\n/=2E\n/g; # force encoding of /^\.$/
97 59         46 $enc =~ s/^From /=46rom /g; # force encoding of /^From /
98             }
99 65         118 $enc;
100             }
101              
102             #------------------------------
103             #
104             # decode_it IN, OUT
105             #
106             sub decode_it {
107 13     13 1 23 my ($self, $in, $out) = @_;
108 13         15 my $init = 0;
109 13         17 my $badpdf = 0;
110              
111 13         16 local $_;
112 13         289 while (defined($_ = $in->getline)) {
113             #
114             # Dirty hack to fix QP-Encoded PDFs from MS-Outlook.
115             #
116             # Check if we have a PDF file and if it has been encoded
117             # on Windows. Unix encoded files are fine. If we have
118             # one encoded CR after the PDF init string but are missing
119             # an encoded CR before the newline this means the PDF is broken.
120             #
121 318 100       9606 if (!$init) {
122 13         17 $init = 1;
123 13 50 33     156 if ($_ =~ /^%PDF-[0-9\.]+=0D/ && $_ !~ /=0D\n$/) {
124 0         0 $badpdf = 1;
125             }
126             }
127             #
128             # Decode everything with decode_qp() except corrupted PDFs.
129             #
130 318 50       328 if ($badpdf) {
131 0         0 my $output = $_;
132 0         0 $output =~ s/[ \t]+?(\r?\n)/$1/g;
133 0         0 $output =~ s/=\r?\n//g;
134 0         0 $output =~ s/(^|[^\r])\n\Z/$1\r\n/;
135 0         0 $output =~ s/=([\da-fA-F]{2})/pack("C", hex($1))/ge;
  0         0  
136 0         0 $out->print($output);
137             } else {
138 318         762 $out->print(decode_qp($_));
139             }
140             }
141 13         495 1;
142             }
143              
144             #------------------------------
145             #
146             # encode_it IN, OUT
147             #
148             sub encode_it {
149 8     8 1 10 my ($self, $in, $out, $textual_type) = @_;
150              
151 8         11 local $_;
152 8         163 while (defined($_ = $in->getline)) {
153 57         1704 $out->print(encode_qp_really($_, $textual_type));
154             }
155 8         278 1;
156             }
157              
158             #------------------------------
159             1;