ext/MIME/Base64/QuotedPrint.pm

   1 #
   2 # $Id: QuotedPrint.pm,v 2.11 2003/01/05 08:01:33 gisle Exp $
   3
   4 package MIME::QuotedPrint;
   5
   6 =head1 NAME
   7
   8 MIME::QuotedPrint - Encoding and decoding of quoted-printable strings
   9
  10 =head1 SYNOPSIS
  11
  12  use MIME::QuotedPrint;
  13
  14  $encoded = encode_qp($decoded);
  15  $decoded = decode_qp($encoded);
  16
  17 =head1 DESCRIPTION
  18
  19 This module provides functions to encode and decode strings into the
  20 Quoted-Printable encoding specified in RFC 2045 - I<MIME (Multipurpose
  21 Internet Mail Extensions)>.  The Quoted-Printable encoding is intended
  22 to represent data that largely consists of bytes that correspond to
  23 printable characters in the ASCII character set.  Non-printable
  24 characters (as defined by english americans) are represented by a
  25 triplet consisting of the character "=" followed by two hexadecimal
  26 digits.
  27
  28 The following functions are provided:
  29
  30 =over 4
  31
  32 =item encode_qp($str)
  33
  34 =item encode_qp($str, $eol)
  35
  36 This function will return an encoded version of the string given as
  37 argument.  The second argument is the line ending sequence to use (it
  38 is optional and defaults to C<"\n">).
  39
  40 =item decode_qp($str);
  41
  42 This function will return the plain text version of the string given
  43 as argument.  Lines with be "\n" terminated.
  44
  45 =back
  46
  47
  48 If you prefer not to import these routines into your namespace you can
  49 call them as:
  50
  51   use MIME::QuotedPrint ();
  52   $encoded = MIME::QuotedPrint::encode($decoded);
  53   $decoded = MIME::QuotedPrint::decode($encoded);
  54
  55 =head1 COPYRIGHT
  56
  57 Copyright 1995-1997,2002-2003 Gisle Aas.
  58
  59 This library is free software; you can redistribute it and/or
  60 modify it under the same terms as Perl itself.
  61
  62 =cut
  63
  64 use strict;
  65 use vars qw(@ISA @EXPORT $VERSION);
  66 if (ord('A') == 193) { # on EBCDIC machines we need translation help
  67     require Encode;
  68 }
  69
  70 require Exporter;
  71 @ISA = qw(Exporter);
  72 @EXPORT = qw(encode_qp decode_qp);
  73
  74 use Carp qw(croak);
  75
  76 $VERSION = "2.16";
  77
  78 use MIME::Base64;  # try to load XS version of encode_qp
  79 unless (defined &encode_qp) {
  80     *encode_qp = \&old_encode_qp;
  81     *decode_qp = \&old_decode_qp;
  82 }
  83
  84 sub old_encode_qp ($;$)
  85 {
  86     my $res = shift;
  87     if ($] >= 5.006) {
  88         require bytes;
  89         if (bytes::length($res) > length($res) ||
  90             ($] >= 5.008 && $res =~ /[^\0-\xFF]/)) {
  91             croak("The Quoted-Printable encoding is only defined for bytes");
  92         }
  93     }
  94
  95     my $eol = shift;
  96     $eol = "\n" unless defined($eol) || length($eol);
  97
  98     # Do not mention ranges such as $res =~ s/([^ \t\n!-<>-~])/sprintf("=%02X", ord($1))/eg;
  99     # since that will not even compile on an EBCDIC machine (where ord('!') > ord('<')).
 100     if (ord('A') == 193) { # EBCDIC style machine
 101         if (ord('[') == 173) {
 102             $res =~ s/([^ \t\n!"#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~])/sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('cp1047',$1))))/eg;  # rule #2,#3
 103             $res =~ s/([ \t]+)$/
 104               join('', map { sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('cp1047',$_)))) }
 105                            split('', $1)
 106               )/egm;                        # rule #3 (encode whitespace at eol)
 107         }
 108         elsif (ord('[') == 187) {
 109             $res =~ s/([^ \t\n!"#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~])/sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('posix-bc',$1))))/eg;  # rule #2,#3
 110             $res =~ s/([ \t]+)$/
 111               join('', map { sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('posix-bc',$_)))) }
 112                            split('', $1)
 113               )/egm;                        # rule #3 (encode whitespace at eol)
 114         }
 115         elsif (ord('[') == 186) {
 116             $res =~ s/([^ \t\n!"#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~])/sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('cp37',$1))))/eg;  # rule #2,#3
 117             $res =~ s/([ \t]+)$/
 118               join('', map { sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('cp37',$_)))) }
 119                            split('', $1)
 120               )/egm;                        # rule #3 (encode whitespace at eol)
 121         }
 122     }
 123     else { # ASCII style machine
 124         $res =~  s/([^ \t\n!"#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~])/sprintf("=%02X", ord($1))/eg;  # rule #2,#3
 125         $res =~ s/([ \t]+)$/
 126           join('', map { sprintf("=%02X", ord($_)) }
 127                    split('', $1)
 128           )/egm;                        # rule #3 (encode whitespace at eol)
 129     }
 130
 131     # rule #5 (lines must be shorter than 76 chars, but we are not allowed
 132     # to break =XX escapes.  This makes things complicated :-( )
 133     my $brokenlines = "";
 134     $brokenlines .= "$1=$eol"
 135         while $res =~ s/(.*?^[^\n]{73} (?:
 136                  [^=\n]{2} (?! [^=\n]{0,1} $) # 75 not followed by .?\n
 137                 |[^=\n]    (?! [^=\n]{0,2} $) # 74 not followed by .?.?\n
 138                 |          (?! [^=\n]{0,3} $) # 73 not followed by .?.?.?\n
 139             ))//xsm;
 140
 141     "$brokenlines$res";
 142 }
 143
 144
 145 sub old_decode_qp ($)
 146 {
 147     my $res = shift;
 148     $res =~ s/\r\n/\n/g;            # normalize newlines
 149     $res =~ s/[ \t]+\n/\n/g;        # rule #3 (trailing space must be deleted)
 150     $res =~ s/=\n//g;               # rule #5 (soft line breaks)
 151     if (ord('A') == 193) { # EBCDIC style machine
 152         if (ord('[') == 173) {
 153             $res =~ s/=([\da-fA-F]{2})/Encode::encode('cp1047',Encode::decode('iso-8859-1',pack("C", hex($1))))/ge;
 154         }
 155         elsif (ord('[') == 187) {
 156             $res =~ s/=([\da-fA-F]{2})/Encode::encode('posix-bc',Encode::decode('iso-8859-1',pack("C", hex($1))))/ge;
 157         }
 158         elsif (ord('[') == 186) {
 159             $res =~ s/=([\da-fA-F]{2})/Encode::encode('cp37',Encode::decode('iso-8859-1',pack("C", hex($1))))/ge;
 160         }
 161     }
 162     else { # ASCII style machine
 163         $res =~ s/=([\da-fA-F]{2})/pack("C", hex($1))/ge;
 164     }
 165     $res;
 166 }
 167
 168 # Set up aliases so that these functions also can be called as
 169 #
 170 # MIME::QuotedPrint::encode();
 171 # MIME::QuotedPrint::decode();
 172
 173 *encode = \&encode_qp;
 174 *decode = \&decode_qp;
 175
 176 1;