ext/MIME/Base64/QuotedPrint.pm

   1 #
   2 # $Id: QuotedPrint.pm,v 2.3 1997/12/02 10:24:27 aas 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 This function will return an encoded version of the string given as
  35 argument.
  36
  37 Note that encode_qp() does not change newlines C<"\n"> to the CRLF
  38 sequence even though this might be considered the right thing to do
  39 (RFC 2045 (Q-P Rule #4)).
  40
  41 =item decode_qp($str);
  42
  43 This function will return the plain text version of the string given
  44 as argument.
  45
  46 =back
  47
  48
  49 If you prefer not to import these routines into your namespace you can
  50 call them as:
  51
  52   use MIME::QuotedPrint ();
  53   $encoded = MIME::QuotedPrint::encode($decoded);
  54   $decoded = MIME::QuotedPrint::decode($encoded);
  55
  56 =head1 COPYRIGHT
  57
  58 Copyright 1995-1997 Gisle Aas.
  59
  60 This library is free software; you can redistribute it and/or
  61 modify it under the same terms as Perl itself.
  62
  63 =cut
  64
  65 use strict;
  66 use vars qw(@ISA @EXPORT $VERSION);
  67 if (ord('A') == 193) { # on EBCDIC machines we need translation help
  68     require Encode; import Encode;
  69 }
  70
  71 require Exporter;
  72 @ISA = qw(Exporter);
  73 @EXPORT = qw(encode_qp decode_qp);
  74
  75 $VERSION = sprintf("%d.%02d", q$Revision: 2.3 $ =~ /(\d+)\.(\d+)/);
  76
  77 use re 'asciirange'; # ranges in regular expressions refer to ASCII
  78
  79 sub encode_qp ($)
  80 {
  81     my $res = shift;
  82     # Do not mention ranges such as $res =~ s/([^ \t\n!-<>-~])/sprintf("=%02X", ord($1))/eg;
  83     # since that will not even compile on an EBCDIC machine (where ord('!') > ord('<')).
  84     if (ord('A') == 193) { # EBCDIC style machine
  85         if (ord('[') == 173) {
  86             $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
  87             $res =~ s/([ \t]+)$/
  88               join('', map { sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('cp1047',$_)))) }
  89                            split('', $1)
  90               )/egm;                        # rule #3 (encode whitespace at eol)
  91         }
  92         elsif (ord('[') == 187) {
  93             $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
  94             $res =~ s/([ \t]+)$/
  95               join('', map { sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('posix-bc',$_)))) }
  96                            split('', $1)
  97               )/egm;                        # rule #3 (encode whitespace at eol)
  98         }
  99         elsif (ord('[') == 186) {
 100             $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
 101             $res =~ s/([ \t]+)$/
 102               join('', map { sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('cp37',$_)))) }
 103                            split('', $1)
 104               )/egm;                        # rule #3 (encode whitespace at eol)
 105         }
 106     }
 107     else { # ASCII style machine
 108         $res =~  s/([^ \t\n!"#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~])/sprintf("=%02X", ord($1))/eg;  # rule #2,#3
 109         $res =~ s/([ \t]+)$/
 110           join('', map { sprintf("=%02X", ord($_)) }
 111                    split('', $1)
 112           )/egm;                        # rule #3 (encode whitespace at eol)
 113     }
 114
 115     # rule #5 (lines must be shorter than 76 chars, but we are not allowed
 116     # to break =XX escapes.  This makes things complicated :-( )
 117     my $brokenlines = "";
 118     $brokenlines .= "$1=\n"
 119         while $res =~ s/(.*?^[^\n]{73} (?:
 120                  [^=\n]{2} (?! [^=\n]{0,1} $) # 75 not followed by .?\n
 121                 |[^=\n]    (?! [^=\n]{0,2} $) # 74 not followed by .?.?\n
 122                 |          (?! [^=\n]{0,3} $) # 73 not followed by .?.?.?\n
 123             ))//xsm;
 124
 125     "$brokenlines$res";
 126 }
 127
 128
 129 sub decode_qp ($)
 130 {
 131     my $res = shift;
 132     $res =~ s/[ \t]+?(\r?\n)/$1/g;  # rule #3 (trailing space must be deleted)
 133     $res =~ s/=\r?\n//g;            # rule #5 (soft line breaks)
 134     if (ord('A') == 193) { # EBCDIC style machine
 135         if (ord('[') == 173) {
 136             $res =~ s/=([\da-fA-F]{2})/Encode::encode('cp1047',Encode::decode('iso-8859-1',pack("C", hex($1))))/ge;
 137         }
 138         elsif (ord('[') == 187) {
 139             $res =~ s/=([\da-fA-F]{2})/Encode::encode('posix-bc',Encode::decode('iso-8859-1',pack("C", hex($1))))/ge;
 140         }
 141         elsif (ord('[') == 186) {
 142             $res =~ s/=([\da-fA-F]{2})/Encode::encode('cp37',Encode::decode('iso-8859-1',pack("C", hex($1))))/ge;
 143         }
 144     }
 145     else { # ASCII style machine
 146         $res =~ s/=([\da-fA-F]{2})/pack("C", hex($1))/ge;
 147     }
 148     $res;
 149 }
 150
 151 # Set up aliases so that these functions also can be called as
 152 #
 153 # MIME::QuotedPrint::encode();
 154 # MIME::QuotedPrint::decode();
 155
 156 *encode = \&encode_qp;
 157 *decode = \&decode_qp;
 158
 159 # Methods for use as a PerlIO layer object
 160
 161 sub PUSHED
 162 {
 163  my ($class,$mode) = @_;
 164  # When writing we buffer the data
 165  my $write = '';
 166  return bless \$write,$class;
 167 }
 168
 169 sub FILL
 170 {
 171  my ($obj,$fh) = @_;
 172  my $line = <$fh>;
 173  return (defined $line) ? decode_qp($line) : undef;
 174  return undef;
 175 }
 176
 177 sub WRITE
 178 {
 179  my ($obj,$buf,$fh) = @_;
 180  $$obj .= encode_qp($buf);
 181  return length($buf);
 182 }
 183
 184 sub FLUSH
 185 {
 186  my ($obj,$fh) = @_;
 187  print $fh $$obj or return -1;
 188  $$obj = '';
 189  return 0;
 190 }
 191
 192
 193 1;