home *** CD-ROM | disk | FTP | other *** search
/ Nebula 1 / Nebula One.iso / Internet / WWW / Perl_WWW_Utilities / MHonArc / lib / readmail.pl < prev    next >
Encoding:
Perl Script  |  1996-03-21  |  15.6 KB  |  469 lines
  1. ##---------------------------------------------------------------------------##
  2. ##  File:
  3. ##      readmail.pl
  4. ##  Author:
  5. ##      Earl Hood       ehood@convex.com
  6. ##  Description:
  7. ##      Library defining routines to parse MIME e-mail messages.  The
  8. ##    library is designed so it may be reused for other e-mail
  9. ##    filtering programs.  The default behavior is for mail->html
  10. ##    filtering, however, the defaults can be overridden to allow
  11. ##    mail->whatever filtering.
  12. ##  Date:
  13. ##    Thu Mar 21 13:31:27 CST 1996
  14. ##---------------------------------------------------------------------------##
  15. ##    Copyright (C) 1995    Earl Hood, ehood@convex.com
  16. ##
  17. ##    This program is free software; you can redistribute it and/or modify
  18. ##    it under the terms of the GNU General Public License as published by
  19. ##    the Free Software Foundation; either version 2 of the License, or
  20. ##    (at your option) any later version.
  21. ##
  22. ##    This program is distributed in the hope that it will be useful,
  23. ##    but WITHOUT ANY WARRANTY; without even the implied warranty of
  24. ##    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  25. ##    GNU General Public License for more details.
  26. ##
  27. ##    You should have received a copy of the GNU General Public License
  28. ##    along with this program; if not, write to the Free Software
  29. ##    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  30. ##---------------------------------------------------------------------------##
  31.  
  32. package readmail;
  33.  
  34. require "base64.pl" || die "ERROR: Unable to require base64.pl\n";
  35. require "qprint.pl" || die "ERROR: Unable to require qprint.pl\n";
  36.  
  37. ##---------------------------------------------------------------------------##
  38. ##    Scalar Variables
  39. ##
  40.  
  41. ##  Variable storing the mulitple fields separator value for the
  42. ##  the read header routines.
  43. ##
  44. $main'FieldSep    = "\034";
  45.  
  46. ##---------------------------------------------------------------------------##
  47. ##    Variables for folding information related to the functions used
  48. ##    for processing MIME data.  Variables are defined in the scope
  49. ##    of main.
  50.  
  51. ##  MIMEFilters is the associative array for storing functions that
  52. ##  process various content-types in the MAILread_body routine.
  53. ##
  54. ##    Keys => Content-type (should be in lowercase)
  55. ##    Values => function name.
  56. ##
  57. ##  Function names should be qualified with package identifiers.
  58. ##  Functions are called as follows:
  59. ##
  60. ##    $converted_data = &function($header, *parsed_header_assoc_array,
  61. ##                    *message_data, $decoded_flag,
  62. ##                    $optional_filter_arguments);
  63. ##
  64. ##  Functions can be registered for base types.  Example:
  65. ##
  66. ##    $MIMEFilters{"image/*"} = "mypackage'function";
  67. ##
  68. ##  To register a fallback function to be called if no function is
  69. ##  defined for a specific content-type, do something like the
  70. ##  following:
  71. ##
  72. ##    $MIMEFilters{"*/*"} = "mypackage'function";
  73. ##
  74. ##  IMPORTANT: If a function specified is not defined when MAILread_body
  75. ##  tries to invoke it, MAILread_body will silently ignore.  Make sure
  76. ##  that all functions are defined before invoking MAILread_body.
  77. ##
  78. %main'MIMEFilters    = ();
  79.  
  80. ##  MIMEDecoders is the associative array for storing functions for
  81. ##  decoding mime data.
  82. ##
  83. ##    Keys => content-transfer-encoding (should be in lowercase)
  84. ##    Values => function name.
  85. ##
  86. ##  Function names should be qualified with package identifiers.
  87. ##  Functions are called as follows:
  88. ##
  89. ##    $decoded_data = &function($data);
  90. ##
  91. ##  The value "as-is" may be used to allow the data to be passed without
  92. ##  decoding to the registered filter, but the decoded flag will be
  93. ##  set to true.
  94. ##
  95. %main'MIMEDecoders            = ();
  96. ##    Default settings:
  97. $main'MIMEDecoders{"7bit"}        = "as-is";
  98. $main'MIMEDecoders{"8bit"}        = "as-is";
  99. $main'MIMEDecoders{"binary"}        = "as-is";
  100. $main'MIMEDecoders{"base64"}        = "base64'b64decode";
  101. $main'MIMEDecoders{"quoted-printable"}    = "quoted_printable'qprdecode";
  102. $main'MIMEDecoders{"x-uuencode"}    = "base64'uudecode";
  103.  
  104. ##  MIMEFiltersArgs is the associative array for storing any optional
  105. ##  arguments to functions specified in MIMEFilters (the
  106. ##  $optional_filter_arguments from above).
  107. ##
  108. ##    Keys => Either one of the following: content-type, function name.
  109. ##    Values => Argument string (format determined by filter function).
  110. ##
  111. ##  Arguments listed for a content-type will be used over arguments
  112. ##  listed for a function if both are applicable.
  113. ##
  114. %main'MIMEFiltersArgs    = ();
  115.  
  116. ##---------------------------------------------------------------------------
  117. ##    Variables holding functions for generating processed output
  118. ##    for MAILread_body().  The default functions generate HTML.
  119. ##    However, the variables can be set to functions that generate
  120. ##    a different type of output.
  121. ##
  122. ##    $FormatHeaderFunc has no default, and must be defined by
  123. ##    the calling program.
  124. ##
  125. ##  Function that returns a message when failing to process a part of a
  126. ##  a multipart message.  The content-type of the message is passed
  127. ##  as an argument.
  128. ##
  129. $CantProcessPartFunc        = "cantProcessPart";
  130.  
  131. ##  Function that returns a message when a part is unrecognized in a
  132. ##  multipart/alternative message.  I.e. No part could be processed.
  133. ##  No arguments are passed to function.
  134. ##
  135. $UnrecognizedAltPartFunc    = "unrecognizedAltPart";
  136.  
  137. ##  Function that returns a string to go before any data generated generating
  138. ##  from processing an embedded message (message/rfc822 or message/news).
  139. ##  No arguments are passed to function.
  140. ##
  141. $BeginEmbeddedMesgFunc        = "beginEmbeddedMesg";
  142.  
  143. ##  Function that returns a string to go after any data generated generating
  144. ##  from processing an embedded message (message/rfc822 or message/news).
  145. ##  No arguments are passed to function.
  146. ##
  147. $EndEmbeddedMesgFunc        = "endEmbeddedMesg";
  148.  
  149. ##  Function to return a string that is a result of the functions
  150. ##  processing of a message header.  The function is called for
  151. ##  embedded messages (message/rfc822 and message/news).  The
  152. ##  arguments to function are:
  153. ##
  154. ##   1.    Pointer to associative array representing message header
  155. ##    contents with the keys as field labels (in all lower-case)
  156. ##    and the values as field values of the labels.
  157. ##
  158. ##   2. Pointer to associative array mapping lower-case keys of
  159. ##    argument 1 to original case.
  160. ##
  161. ##  Prototype: $return_data = &function(*fields, *lower2orig_fields);
  162. ##
  163. $FormatHeaderFunc        = "";
  164.  
  165. ###############################################################################
  166. ##    Public Routines                                 ##
  167. ###############################################################################
  168. ##---------------------------------------------------------------------------
  169. ##    MAILread_body() parses a MIME message body.  $header is the
  170. ##    header of the message.  $body is the actual message body.
  171. ##    $ctypeArg is the value of the Content-Type field and $encodingArg
  172. ##    is the value of the Content-Transfer-Encoding field (both
  173. ##    should be obtained from $header from the calling routine).  The
  174. ##    return value is an array:  The first item is the converted data
  175. ##    generated, and the other items are filenames of any derived
  176. ##    files.
  177. ##
  178. sub main'MAILread_body {
  179.     local($header, $body, $ctypeArg, $encodingArg) = @_;
  180.  
  181.     local($type, $subtype, $boundary, $ret, $tmp, $content, $ctype);
  182.     local($part, $parthead, $partcontent, $partencoding);
  183.     local(@parts, %partfields, %partl2o) = ();
  184.     local(@files) = ();
  185.     local(@array) = ();
  186.  
  187.     ## Get type/subtype
  188.     $content = $ctypeArg || 'text/plain';    # Default to text/plain 
  189.                         #     if no content-type
  190.     ($ctype) = $content =~ m%^\s*([\w-/]+)%;    # Extract content-type
  191.     $ctype =~ tr/A-Z/a-z/;            # Convert to lowercase
  192.     if ($ctype =~ m%/%) {            # Extract base and sub types
  193.     ($type,$subtype) = split(/\//, $ctype, 2);
  194.     } elsif ($ctype =~ /text/) {
  195.     $ctype = 'text/plain';
  196.     $type = 'text';  $subtype = 'plain';
  197.     } else {
  198.     $type = $subtype = '';
  199.     }
  200.  
  201.     ## Process message
  202.     $filter = $'MIMEFilters{$ctype};            # Specific filter
  203.     $filter = $'MIMEFilters{"$type/*"}    unless $filter; # Base type filter
  204.     $filter = $'MIMEFilters{"*/*"}    unless $filter;    # Last resort
  205.  
  206.     ## A filter is defined for given content-type
  207.     if ($filter && defined(&$filter)) {
  208.     local($tmphead) = ($header . "\n"); # Bogus header for MAILread_header
  209.     local($encoding) = ($encodingArg);
  210.     local($decodefunc, $decoded, $args) = ('', '', '');
  211.  
  212.     ## Check for filter arguments
  213.     $args = $'MIMEFiltersArgs{$ctype};
  214.     $args = $'MIMEFiltersArgs{"$type/*"} if $args eq '';
  215.     $args = $'MIMEFiltersArgs{$filter} if $args eq '';
  216.  
  217.     ## Parse message header for filter
  218.     &'MAILread_header(*tmphead, *partfields, *partl2o);
  219.  
  220.     ## Check encoding and decode data
  221.     $encoding =~ s/\s//g;  $encoding =~ tr/A-Z/a-z/;
  222.     $decodefunc = $'MIMEDecoders{$encoding};
  223.     if (defined(&$decodefunc)) {
  224.         $decoded = &$decodefunc($body);
  225.         @array = &$filter($header, *partfields, *decoded, 1, $args);
  226.     } else {
  227.         @array = &$filter($header, *partfields, *body,
  228.                   $decodefunc =~ /as-is/i, $args);
  229.     }
  230.  
  231.     ## Setup return variables
  232.     $ret = shift @array;                # Return string
  233.     push(@files, @array);                # Derived files
  234.  
  235.     ## No filter defined for given content-type
  236.     } else {
  237.     ## If multipart, recursively process each part
  238.     if ($type =~ /multipart/i) {
  239.  
  240.         ## Get boundary
  241.         if ($content =~ m%boundary\s*=\s*"([^"]*)"%i) {
  242.         $boundary = $1;
  243.         } else {
  244.         ($boundary) = $content =~ m%boundary\s*=\s*(\S+)%;
  245.         }
  246.         $boundary =~ s/(\W)/\\$1/g;
  247.  
  248.         ## Split parts and process each
  249.         $body = "\r\n" . $body;    # Pad data for splitting
  250.         if ($subtype =~ /alternative/i) {    # Go in reverse order
  251.         @parts = reverse split(/\r?\n--$boundary/, $body);
  252.         pop @parts;
  253.         while (@parts && ($parts[0] !~ /^--/)) { shift @parts; }
  254.         shift @parts;
  255.         } else {
  256.         @parts = split(/\r?\n--$boundary/, $body);
  257.         shift @parts;
  258.         while (@parts && ($parts[$#parts] !~ /^--/)) { pop @parts; }
  259.         pop @parts;
  260.         }
  261.  
  262.         ## Process parts
  263.         foreach $part (@parts) {
  264.         $part =~ s/^\r?\n//;    # Drop begining newline
  265.  
  266.         ## Read header to get content-type
  267.         $parthead = &'MAILread_header(*part, *partfields, *partl2o);
  268.         $partcontent = $partfields{'content-type'};
  269.         $partencoding = $partfields{'content-transfer-encoding'};
  270.  
  271.         ## If content-type not defined for part, then determine
  272.         ## content-type based upon mulipart subtype.
  273.         if (!$partcontent) {
  274.             if ($subtype =~ /digest/) {
  275.             $partcontent = 'message/rfc822';
  276.             }
  277.             else {
  278.             $partcontent = 'text/plain';
  279.             }
  280.         }
  281.  
  282.         ## Process part
  283.         @array = &'MAILread_body($parthead, $part,
  284.                      $partcontent, $partencoding);
  285.  
  286.         ## Only use last filterable part in alternate
  287.         if ($subtype =~ /alternative/) {
  288.             $ret = shift @array;
  289.             if ($ret) {
  290.             push(@files, @array);
  291.             last;
  292.             }
  293.         } else {
  294.             if (!$array[0]) {
  295.             $array[0] = &$CantProcessPartFunc(
  296.                     $partfields{'content-type'});
  297.             }
  298.             $ret .= shift @array;
  299.         }
  300.         push(@files, @array);
  301.         }
  302.         if (!$ret && ($subtype =~ /alternative/)) {
  303.         $ret = &$UnrecognizedAltPartFunc();
  304.         }
  305.  
  306.     ## Else if message/rfc822 or message/news
  307.     } elsif ($ctype =~ m%message/(rfc822|news)%i) {
  308.         $parthead = &'MAILread_header(*body, *partfields, *partl2o);
  309.         $partcontent = $partfields{'content-type'};
  310.         $partencoding = $partfields{'content-transfer-encoding'};
  311.  
  312.         $ret = &$BeginEmbeddedMesgFunc();
  313.         if ($FormatHeaderFunc && defined(&$FormatHeaderFunc)) {
  314.         $ret .= &$FormatHeaderFunc(*partfields, *partl2o);
  315.         } else {
  316.         warn "WARNING: readmail.pl: No message header formatting ",
  317.              "function defined\n";
  318.         }
  319.         @array = &'MAILread_body($parthead, $body,
  320.                      $partcontent, $partencoding);
  321.         $ret .= shift @array ||
  322.             &$CantProcessPartFunc($partfields{'content-type'});
  323.         $ret .= &$EndEmbeddedMesgFunc();
  324.  
  325.         push(@files, @array);
  326.  
  327.     ## Else cannot do anything
  328.     } else {
  329.         $ret = '';
  330.     }
  331.     }
  332.     ($ret, @files);
  333. }
  334. ##---------------------------------------------------------------------------
  335. ##    MAILread_header reads (and strips) a mail message header from the
  336. ##    variable *mesg.  *mesg is a pointer to the mail message.
  337. ##
  338. ##    *fields is a pointer to an associative array to put field
  339. ##    values indexed by field labels that have been converted to all
  340. ##    lowercase.  If a field repeats (eg Received fields), then each
  341. ##    value in $fields{$fieldname} will be a $'FieldSep separated
  342. ##    string representing the multiple values.
  343. ##
  344. ##    *l2o is an associative array to get the original label text
  345. ##    from the lowercase field label keys.
  346. ##    
  347. ##    The return value is the original (extracted) header text.
  348. ##
  349. sub main'MAILread_header {
  350.     local(*mesg, *fields, *l2o) = @_; local($label, $olabel, $value,
  351.     $tmp, $header);
  352.  
  353.     $header = '';  %fields = ();  %l2o = ();  $label = '';
  354.  
  355.     ## Read a line at a time.
  356.     while ($mesg =~ s/^([^\n]*\n)//) {
  357.     $tmp = $1;
  358.     last  if $tmp =~ /^[\r]?$/;    # Done if blank line
  359.     $header .= $tmp;
  360.     $tmp =~ s/\n/ /g;
  361.  
  362.     ## Check for continuation of a field
  363.     if ($tmp =~ /^\s/) {
  364.         $fields{$label} .= $tmp  if $label;
  365.         next;
  366.     }
  367.  
  368.     ## Separate head from field text
  369.     if ($tmp =~ /^([^:\s]+):\s*([\s\S]*)$/) {
  370.         ($olabel, $value) = ($1, $2);
  371.         ($label = $olabel) =~ tr/A-Z/a-z/;
  372.         $l2o{$label} = $olabel;
  373.         if ($fields{$label}) {
  374.         $fields{$label} .= $'FieldSep . $value;
  375.         } else {
  376.         $fields{$label} = $value;
  377.         }
  378.     }
  379.     }
  380.     $header;
  381. }
  382. ##---------------------------------------------------------------------------
  383. ##    MAILread_file_header reads (and strips) a mail message header
  384. ##    from the filehandle $handle.  The routine behaves in the
  385. ##    same manner as MAILread_header;
  386. ##    
  387. sub main'MAILread_file_header {
  388.     local($handle, *fields, *l2o) = @_;
  389.     local($label, $olabel, $value, $tmp, $header);
  390.     local($d) = ($/);
  391.  
  392.     $/ = "\n";  $label = '';
  393.     $header = '';  %fields = ();  %l2o = ();
  394.     while (($tmp = <$handle>) !~ /^[\r]?$/) {
  395.     $header .= $tmp;
  396.     $tmp =~ s/\n/ /g;
  397.  
  398.     ## Check for continuation of a field
  399.     if ($tmp =~ /^\s/) {
  400.         $fields{$label} .= $tmp  if $label;
  401.         next;
  402.     }
  403.  
  404.     ## Separate head from field text
  405.     if ($tmp =~ /^([^:\s]+):\s*([\s\S]*)$/) {
  406.         ($olabel, $value) = ($1, $2);
  407.         ($label = $olabel) =~ tr/A-Z/a-z/;
  408.         $l2o{$label} = $olabel;
  409.         if ($fields{$label}) {
  410.         $fields{$label} .= $'FieldSep . $value;
  411.         } else {
  412.         $fields{$label} = $value;
  413.         }
  414.     }
  415.     }
  416.     $/ = $d;
  417.     $header;
  418. }
  419.  
  420. ###############################################################################
  421. ##    Private Routines
  422. ###############################################################################
  423. ##---------------------------------------------------------------------------##
  424. ##    Default function for unable to process a part of a multipart
  425. ##    message.
  426. ##
  427. sub cantProcessPart {
  428.     local($ctype) = $_[0];
  429.  
  430.     warn "Warning: Could not process part with given Content-Type: ",
  431.      "$ctype\n";
  432.     join('',"<DL>\n",
  433.         "<DT><STRONG>Warning</STRONG></DT>\n",
  434.         "<DD>Could not process part with given ",
  435.         "Content-Type: <CODE>", $ctype, "</CODE>\n",
  436.         "</DD>\n",
  437.         "</DL>\n"
  438.         );
  439. }
  440. ##---------------------------------------------------------------------------##
  441. ##    Default function for unrecognizeable part in multipart/alternative.
  442. ##
  443. sub unrecognizedAltPart {
  444.     warn "Warning: No recognizable part in multipart/alternative\n";
  445.     join('',"<HR>\n",
  446.         "<P>No recognizable part in ",
  447.         "<CODE>multipart/alternative</CODE>.</P>\n",
  448.         "<HR>\n");
  449. }
  450. ##---------------------------------------------------------------------------##
  451. ##    Default function for beggining of embedded message
  452. ##    (ie message/rfc822 or message/news).
  453. ##
  454. sub beginEmbeddedMesg {
  455.     join('',"<P><EM>-- BEGIN included message</EM></P>\n",
  456.         "<BLOCKQUOTE>\n");
  457. }
  458. ##---------------------------------------------------------------------------##
  459. ##    Default function for end of embedded message
  460. ##    (ie message/rfc822 or message/news).
  461. ##
  462. sub endEmbeddedMesg {
  463.     join('',"</BLOCKQUOTE>\n",
  464.         "<P><EM>-- END included message</EM></P>\n");
  465.         
  466. }
  467. ##---------------------------------------------------------------------------##
  468. 1; # for require
  469.