home *** CD-ROM | disk | FTP | other *** search
/ PC World 2003 March / PCWorld_2003-03_cd.bin / Software / Topware / activeperl / ActivePerl / Perl / lib / MIME / QuotedPrint.pm < prev   
Encoding:
Perl POD Document  |  2002-07-13  |  5.5 KB  |  163 lines
  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;
  69. }
  70.  
  71. require Exporter;
  72. @ISA = qw(Exporter);
  73. @EXPORT = qw(encode_qp decode_qp);
  74.  
  75. use Carp qw(croak);
  76.  
  77. $VERSION = sprintf("%d.%02d", q$Revision: 2.3 $ =~ /(\d+)\.(\d+)/);
  78.  
  79. sub encode_qp ($)
  80. {
  81.     my $res = shift;
  82.     croak("The Quoted-Printable encoding is only defined for bytes")
  83.     if $res =~ /[^\0-\xFF]/;
  84.  
  85.     # Do not mention ranges such as $res =~ s/([^ \t\n!-<>-~])/sprintf("=%02X", ord($1))/eg;
  86.     # since that will not even compile on an EBCDIC machine (where ord('!') > ord('<')).
  87.     if (ord('A') == 193) { # EBCDIC style machine
  88.         if (ord('[') == 173) {
  89.             $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
  90.             $res =~ s/([ \t]+)$/
  91.               join('', map { sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('cp1047',$_)))) }
  92.                    split('', $1)
  93.               )/egm;                        # rule #3 (encode whitespace at eol)
  94.         }
  95.         elsif (ord('[') == 187) {
  96.             $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
  97.             $res =~ s/([ \t]+)$/
  98.               join('', map { sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('posix-bc',$_)))) }
  99.                    split('', $1)
  100.               )/egm;                        # rule #3 (encode whitespace at eol)
  101.         }
  102.         elsif (ord('[') == 186) {
  103.             $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
  104.             $res =~ s/([ \t]+)$/
  105.               join('', map { sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('cp37',$_)))) }
  106.                    split('', $1)
  107.               )/egm;                        # rule #3 (encode whitespace at eol)
  108.         }
  109.     }
  110.     else { # ASCII style machine
  111.         $res =~  s/([^ \t\n!"#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~])/sprintf("=%02X", ord($1))/eg;  # rule #2,#3
  112.         $res =~ s/([ \t]+)$/
  113.           join('', map { sprintf("=%02X", ord($_)) }
  114.                split('', $1)
  115.           )/egm;                        # rule #3 (encode whitespace at eol)
  116.     }
  117.  
  118.     # rule #5 (lines must be shorter than 76 chars, but we are not allowed
  119.     # to break =XX escapes.  This makes things complicated :-( )
  120.     my $brokenlines = "";
  121.     $brokenlines .= "$1=\n"
  122.     while $res =~ s/(.*?^[^\n]{73} (?:
  123.          [^=\n]{2} (?! [^=\n]{0,1} $) # 75 not followed by .?\n
  124.         |[^=\n]    (?! [^=\n]{0,2} $) # 74 not followed by .?.?\n
  125.         |          (?! [^=\n]{0,3} $) # 73 not followed by .?.?.?\n
  126.         ))//xsm;
  127.  
  128.     "$brokenlines$res";
  129. }
  130.  
  131.  
  132. sub decode_qp ($)
  133. {
  134.     my $res = shift;
  135.     $res =~ s/[ \t]+?(\r?\n)/$1/g;  # rule #3 (trailing space must be deleted)
  136.     $res =~ s/=\r?\n//g;            # rule #5 (soft line breaks)
  137.     if (ord('A') == 193) { # EBCDIC style machine
  138.         if (ord('[') == 173) {
  139.             $res =~ s/=([\da-fA-F]{2})/Encode::encode('cp1047',Encode::decode('iso-8859-1',pack("C", hex($1))))/ge;
  140.         }
  141.         elsif (ord('[') == 187) {
  142.             $res =~ s/=([\da-fA-F]{2})/Encode::encode('posix-bc',Encode::decode('iso-8859-1',pack("C", hex($1))))/ge;
  143.         }
  144.         elsif (ord('[') == 186) {
  145.             $res =~ s/=([\da-fA-F]{2})/Encode::encode('cp37',Encode::decode('iso-8859-1',pack("C", hex($1))))/ge;
  146.         }
  147.     }
  148.     else { # ASCII style machine
  149.         $res =~ s/=([\da-fA-F]{2})/pack("C", hex($1))/ge;
  150.     }
  151.     $res;
  152. }
  153.  
  154. # Set up aliases so that these functions also can be called as
  155. #
  156. # MIME::QuotedPrint::encode();
  157. # MIME::QuotedPrint::decode();
  158.  
  159. *encode = \&encode_qp;
  160. *decode = \&decode_qp;
  161.  
  162. 1;
  163.