##---------------------------------------------------------------------------##
##  File:
##	$Id: readmail.pl,v 2.45 2014/04/22 02:33:10 ehood Exp $
##  Author:
##      Earl Hood       mhonarc AT mhonarc DOT org
##  Description:
##      Library defining routines to parse MIME e-mail messages.  The
##	library is designed so it may be reused for other e-mail
##	filtering programs.  The default behavior is for mail->html
##	filtering, however, the defaults can be overridden to allow
##	mail->whatever filtering.
##
##	Public Functions:
##	----------------
##	$data 		= MAILdecode_1522_str($str);
##	($data, @files) = MAILread_body($fields_hash_ref, $body_ref);
##	$hash_ref 	= MAILread_file_header($handle);
##	$hash_ref 	= MAILread_header($mesg_str_ref);
##
##	($disp, $file, $raw, $html_name)  =
##			  MAILhead_get_disposition($fields_hash_ref, $do_html);
##	$boolean 	= MAILis_excluded($content_type);
##	$parm_hash_ref  = MAILparse_parameter_str($header_field);
##	$parm_hash_ref  = MAILparse_parameter_str($header_field, 1);
##
##---------------------------------------------------------------------------##
##    Copyright (C) 1996-2003	Earl Hood, mhonarc AT mhonarc DOT org
##
##    This program is free software; you can redistribute it and/or modify
##    it under the terms of the GNU General Public License as published by
##    the Free Software Foundation; either version 2 of the License, or
##    (at your option) any later version.
##
##    This program is distributed in the hope that it will be useful,
##    but WITHOUT ANY WARRANTY; without even the implied warranty of
##    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##    GNU General Public License for more details.
##
##    You should have received a copy of the GNU General Public License
##    along with this program; if not, write to the Free Software
##    Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
##    02111-1307, USA
##---------------------------------------------------------------------------##

package readmail;

no warnings qw(deprecated);

$DEBUG = 0;

###############################################################################
##	Private Globals							     ##
###############################################################################

#my $Url	  = '(\w+://|\w+:)';
my @_MIMEAltPrefs = ();
my %_MIMEAltPrefs = ();

###############################################################################
##	Public Globals							     ##
###############################################################################

##---------------------------------------------------------------------------##
##	Constants
##

## String for matching the start of a URL: It seems unnecessary to
#  try to recognize all valid schemes, so we use a simplier regex.
#  Keep the old one around just in case we need to resurrect it.
#$UrlRxStr	  =
#    '(?:(?:https?|ftp|afs|wais|telnet|ldap|gopher|z39\.50[rs]|vemmi|imap|'.
#          'nfs|acap|rtspu?|tip|pop|sip|(?:soap|xmlrpc)\.beeps?|go|ipp|'.
#          'tftp)://|'.
#       'news:(?://)?|'.
#       '(?:nntp|mid|cid|mailto|prospero|data|service|tel|fax|modem|h\.323):)';
$UrlRxStr	  =
    '(?:(?:https?|ftp|ldap|gopher)://|news:(?://)?|(?:nntp|mailto):)';

##  Constants for use as second argument to MAILdecode_1522_str().
sub JUST_DECODE() { 1; }
sub DECODE_ALL()  { 2; }
sub TEXT_ENCODE() { 3; }

##---------------------------------------------------------------------------##

##---------------------------------------------------------------------------##
##	Scalar Variables
##

##  Flag if message headers are decoded in the parse header routines:
##  MAILread_header, MAILread_file_header.  This only affects the
##  values of the field hash created.  The original header is still
##  passed as the return value.
##
##  The only 1522 data that will be decoded is data encoded with charsets
##  set to "-decode-" in the %MIMECharSetConverters hash.

$DecodeHeader	= 0;

##---------------------------------------------------------------------------##
##	Variables for holding information related to the functions used
##	for processing MIME data.  Variables are defined in the scope
##	of main.

## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
##  %MIMEDecoders is the associative array for storing functions for
##  decoding mime data.
##
##	Keys => content-transfer-encoding (should be in lowercase)
##	Values => function name.
##
##  Function names should be qualified with package identifiers.
##  Functions are called as follows:
##
##	$decoded_data = &function($data);
##
##  The value "as-is" may be used to allow the data to be passed without
##  decoding to the registered filter, but the decoded flag will be
##  set to true.

%MIMEDecoders			= ()
    unless %MIMEDecoders;
%MIMEDecodersSrc		= ()
    unless %MIMEDecodersSrc;

## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
##  %MIMECharSetConverters is the associative array for storing functions
##  for converting data in a particular charset to a destination format
##  within the MAILdecode_1522_str() routine. Destination format is defined
##  by the function.
##
##	Keys => charset (should be in lowercase)
##	Values => function name.
##
##  Charset values take on a form like "iso-8859-1" or "us-ascii".
##              NOTE: Values need to be in lower-case.
##
##  The key "default" can be assigned to define the default function
##  to call if no explicit charset function is defined.
##
##  The key "plain" can be set to a function for decoded regular text not
##  encoded in 1522 format.
##
##  Function names are name of defined perl function and should be
##  qualified with package identifiers. Functions are called as follows:
##
##	$converted_data = &function($data, $charset);
##
##  A function called "-decode-" implies that the data should be
##  decoded, but no converter is to be invoked.
##
##  A function called "-ignore-" implies that the data should
##  not be decoded and converted.  Ie.  For the specified charset,
##  the encoding will stay unprocessed and passed back in the return
##  string.

%MIMECharSetConverters			= ()
    unless %MIMECharSetConverters;
%MIMECharSetConvertersSrc		= ()
    unless %MIMECharSetConvertersSrc;

## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
##  %MIMEFilters is the associative array for storing functions that
##  process various content-types in the MAILread_body routine.
##
##	Keys => Content-type (should be in lowercase)
##	Values => function name.
##
##  Function names should be qualified with package identifiers.
##  Functions are called as follows:
##
##	$converted_data = &function($header, *parsed_header_assoc_array,
##				    *message_data, $decoded_flag,
##				    $optional_filter_arguments);
##
##  Functions can be registered for base types.  Example:
##
##	$MIMEFilters{"image/*"} = "mypackage'function";
##
##  IMPORTANT: If a function specified is not defined when MAILread_body
##  tries to invoke it, MAILread_body will silently ignore.  Make sure
##  that all functions are defined before invoking MAILread_body.

%MIMEFilters	= ()
    unless %MIMEFilters;
%MIMEFiltersSrc	= ()
    unless %MIMEFiltersSrc;

## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
##  %MIMEFiltersArgs is the associative array for storing any optional
##  arguments to functions specified in MIMEFilters (the
##  $optional_filter_arguments from above).
##
##	Keys => Either one of the following: content-type, function name.
##	Values => Argument string (format determined by filter function).
##
##  Arguments listed for a content-type will be used over arguments
##  listed for a function if both are applicable.

%MIMEFiltersArgs	= ()
    unless %MIMEFiltersArgs;

## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
##  %MIMEExcs is the associative array listing which data types
##  should be auto-excluded during parsing:
##
##	Keys => content-type, or base-type
##	Values => <should evaluate to a true expression>

%MIMEExcs			= ()
    unless %MIMEExcs;

## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
##  %MIMEIncs is the associative array listing which data types
##  should be auto-included during parsing:
##
##	Keys => content-type, or base-type
##	Values => <should evaluate to a true expression>
##
##  If there are any keys defined in %MIMEIncs, then any content-type
##  not in the hash is automatically excluded.  I.e.  %MIMEIncs can
##  be used to only allow a well-defined set of content-types.

%MIMEIncs			= ()
    unless %MIMEIncs;

## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
##  %MIMECharsetAliases is a mapping of charset names to charset names.
##  The MAILset_charset_aliases() routine should be used to set the
##  values of this hash.
##
##	Keys => charset name
##	Values => real charset name
##
%MIMECharsetAliases = ()
    unless %MIMECharsetAliases;

##---------------------------------------------------------------------------
##	Text entity-related variables
##

##  Default character set if none specified.
$TextDefCharset = 'us-ascii'
    unless defined($TextDefCharset);

##  Destination character encoding for text entities.
$TextEncode = undef
    unless defined($TextEncode);
##  Text encoding function.
$TextEncoderFunc = undef
    unless defined($TextEncoderFunc);
##  Text encoding function source file.
$TextEncoderSrc = undef
    unless defined($TextEncoderSrc);

##  Prefilter function
$TextPreFilter  = undef
    unless defined($TextPreFilter);

##---------------------------------------------------------------------------
##	Variables holding functions for generating processed output
##	for MAILread_body().  The default functions generate HTML.
##	However, the variables can be set to functions that generate
##	a different type of output.
##
##	$FormatHeaderFunc has no default, and must be defined by
##	the calling program.
##
##  Function that returns a message when failing to process a part of a
##  a multipart message.  The content-type of the message is passed
##  as an argument.

$CantProcessPartFunc		= \&cantProcessPart
    unless(defined($CantProcessPartFunc));

##  Function that returns a message when a part is excluded via %MIMEExcs.

$ExcludedPartFunc	= \&excludedPart
    unless(defined($ExcludedPartFunc));

##  Function that returns a message when a part is unrecognized in a
##  multipart/alternative message.  I.e. No part could be processed.
##  No arguments are passed to function.

$UnrecognizedAltPartFunc	= \&unrecognizedAltPart
    unless(defined($UnrecognizedAltPartFunc));

##  Function that returns a string to go before any data generated generating
##  from processing an embedded message (message/rfc822 or message/news).
##  No arguments are passed to function.

$BeginEmbeddedMesgFunc		= \&beginEmbeddedMesg
    unless(defined($BeginEmbeddedMesgFunc));

##  Function that returns a string to go after any data generated generating
##  from processing an embedded message (message/rfc822 or message/news).
##  No arguments are passed to function.

$EndEmbeddedMesgFunc		= \&endEmbeddedMesg
    unless(defined($EndEmbeddedMesgFunc));

##  Function to return a string that is a result of the functions
##  processing of a message header.  The function is called for
##  embedded messages (message/rfc822 and message/news).  The
##  arguments to function are:
##
##   1.	Pointer to associative array representing message header
##	contents with the keys as field labels (in all lower-case)
##	and the values as field values of the labels.
##
##   2. Pointer to associative array mapping lower-case keys of
##	argument 1 to original case.
##
##  Prototype: $return_data = &function(*fields, *lower2orig_fields);

$FormatHeaderFunc		= undef
    unless(defined($FormatHeaderFunc));

###############################################################################
##	Public Routines							     ##
###############################################################################
##---------------------------------------------------------------------------##
##	MAILdecode_1522_str() decodes a string encoded in a format
##	specified by RFC 1522.  The decoded string is the return value.
##	If no MIMECharSetConverters is registered for a charset, then
##	the decoded data is returned "as-is".
##
##	Usage:
##
##	    $ret_data = &MAILdecode_1522_str($str, $dec_flag);
##
##	If $dec_flag is JUST_DECODE, $str will be decoded for only
##	the charsets specified as "-decode-".  If it is equal to
##	DECODE_ALL, all encoded data is decoded without any conversion.
##	If $dec_flag is TEXT_ENCODE, then all data will be converted
##	and encoded according to $readmail::TextEncode and
##	$readmail::TextEncoderFunc.
##
sub MAILdecode_1522_str {
    my $str      = shift;
    my $dec_flag = shift || 0;
    my $ret      = ('');
    my($charset,
       $encoding,
       $pos,
       $dec,
       $charcnv,
       $real_charset,
       $plaincnv,
       $plain_real_charset,
       $strtxt,
       $str_before);

    # Get text encoder
    my $encfunc  = undef;
    if ($dec_flag == TEXT_ENCODE) {
	$encfunc = load_textencoder();
	if (!defined($encfunc)) {
	    $encfunc = undef  unless defined($encfunc);
	    $dec_flag = 0;
	}
    }

    # Get plain converter
    ($plaincnv, $plain_real_charset) = MAILload_charset_converter('plain');
    $plain_real_charset = 'us-ascii'  if $plain_real_charset eq 'plain';

    # Decode string
    my $firsttime = 1;
    while ($str =~ /(=\?([^?]+)\?(.)\?([^?]*)\?=)/g) {
	# Grab components
	$pos = pos($str);
	($charset, $encoding, $strtxt) = (lc($2), lc($3), $4);
	$str_before = substr($str, 0, $pos-length($1));
	substr($str, 0, $pos) = '';
	pos($str) = 0;

	# Check encoding method and grab proper decoder
	if ($encoding eq 'b') {
	    $dec = &load_decoder('base64');
	} else {
	    $dec = &load_decoder('quoted-printable');
	}

	# Convert before (unencoded) text
	if ($firsttime || $str_before =~ /\S/) {
	    if (defined($encfunc)) {			# encoding
		&$encfunc(\$str_before, $plain_real_charset, $TextEncode);
		$ret .= $str_before;
	    } elsif ($dec_flag) {			# ignore if just decode
		$ret .= $str_before;
	    } elsif (defined(&$plaincnv)) {		# decode and convert
		$ret .= &$plaincnv($str_before, $plain_real_charset);
	    } else {					# ignore
		$ret .= $str_before;
	    }
	}
	$firsttime = 0;

	# Encoding text
	if (defined($encfunc)) {
	    $real_charset = $MIMECharsetAliases{$charset}
			    ? $MIMECharsetAliases{$charset} : $charset;
	    $strtxt =~ s/_/ /g;
	    $strtxt =  &$dec($strtxt);
            $strtxt =~ s/[\r\n]/ /g;
	    &$encfunc(\$strtxt, $real_charset, $TextEncode);
	    $ret   .= $strtxt;

	# Regular conversion
	} else {
	    if ($dec_flag == DECODE_ALL) {
		$charcnv = '-decode-';
	    } else {
		($charcnv, $real_charset) =
		    MAILload_charset_converter($charset);
	    }
	    # Decode only
	    if ($charcnv eq '-decode-') {
		$strtxt =~ s/_/ /g;
		$strtxt =  &$dec($strtxt);
                $strtxt =~ s/[\r\n]/ /g;
		$ret .= $strtxt;

	    # Ignore if just decoding
	    } elsif ($dec_flag) {
		$ret .= "=?$charset?$encoding?$strtxt?=";

	    # Decode and convert
	    } elsif (defined(&$charcnv)) {
		$strtxt =~ s/_/ /g;
		$strtxt =  &$dec($strtxt);
                $strtxt =~ s/[\r\n]/ /g;
		$ret .= &$charcnv($strtxt, $real_charset);

	    # Fallback is to ignore
	    } else {
		$ret .= "=?$charset?$encoding?$strtxt?=";
	    }
	}
    }

    # Convert left-over unencoded text
    if (defined($encfunc)) {			# encoding
	&$encfunc(\$str, $plain_real_charset, $TextEncode);
	$ret .= $str;
    } elsif ($dec_flag) {			# ignore if just decode
	$ret .= $str;
    } elsif (defined(&$plaincnv)) {		# decode and convert
	$ret .= &$plaincnv($str, $plain_real_charset);
    } else {					# ignore
	$ret .= $str;
    }

    $ret;
}

##---------------------------------------------------------------------------##
##	MAILread_body() parses a MIME message body.
##	Usage:
##	  ($data, @files) =
##	      MAILread_body($fields_hash_ref, $body_data_ref);
##
##	Parameters:
##	  $fields_hash_ref
##		      A reference to hash of message/part header
##		      fields.  Keys are field names in lowercase
##		      and values are array references containing the
##		      field values.  For example, to obtain the
##		      content-type, if defined, one would do:
##
##			$fields_hash_ref->{'content-type'}[0]
##
##		      Values for a fields are stored in arrays since
##		      duplication of fields are possible.  For example,
##		      the Received: header field is typically repeated
##		      multiple times.  For fields that only occur once,
##		      then array for the field will only contain one
##		      item.
##
##	  $body_data_ref
##		      Reference to body data.  It is okay for the
##		      filter to modify the text in-place.
##
##	Return:
##	  The first item in the return list is the text that should
##	  printed to the message page.	Any other items in the return
##	  list are derived filenames created.
##
##	See Also:
##	  MAILread_header(), MAILread_file_header()
##
sub MAILread_body {
    my($fields,		# Parsed header hash
       $body,		# Reference to raw body text
       $inaltArg) = @_; # Flag if in multipart/alternative

    my($type, $subtype, $boundary, $content, $ctype, $pos,
       $encoding, $decodefunc, $args, $part, $uribase);
    my(@parts) = ();
    my(@files) = ();
    my(@array) = ();
    my $ret = "";

    ## Get type/subtype
    if (defined($fields->{'content-type'})) {
	$content = $fields->{'content-type'}->[0];
    }
    $content = 'text/plain'  unless $content;
    ($ctype) = $content =~ m%^\s*([\w\-\./]+)%;	# Extract content-type
    $ctype =~ tr/A-Z/a-z/;			# Convert to lowercase
    if ($ctype =~ m%/%) {			# Extract base and sub types
	($type,$subtype) = split(/\//, $ctype, 2);
    } elsif ($ctype =~ /text/i) {
	$ctype = 'text/plain';
	$type = 'text';  $subtype = 'plain';
    } else {
	$type = $subtype = '';
    }
    $fields->{'x-mha-content-type'} = $ctype;

    ## Check if type is excluded
    if (MAILis_excluded($ctype)) {
	return (&$ExcludedPartFunc($ctype));
    }

    ## Get entity URI base
    if (defined($fields->{'content-base'}) &&
	    ($uribase = $fields->{'content-base'}[0])) {
	$uribase =~ s/['"\s]//g;
    } elsif (defined($fields->{'content-location'}) &&
		($uribase = $fields->{'content-location'}[0])) {
	$uribase =~ s/['"\s]//g;
    }
    $uribase =~ s|(.*/).*|$1|  if $uribase;

    ## Load content-type filter
    if ( (!defined($filter = &load_filter($ctype)) || !defined(&$filter)) &&
	 (!defined($filter = &load_filter("$type/*")) || !defined(&$filter)) &&
	 (!$inaltArg &&
	  (!defined($filter = &load_filter('*/*')) || !defined(&$filter)) &&
	     $ctype !~ m^\bmessage/(?:rfc822|news)\b^i &&
	     $type  !~ /\bmultipart\b/) ) {
	warn qq|Warning: Unrecognized content-type, "$ctype", |,
	     qq|assuming "application/octet-stream"\n|;
	$filter = &load_filter('application/octet-stream');
    }

    ## Check for filter arguments
    $args = get_filter_args($ctype, "$type/*", $filter);

    ## Check encoding
    if (defined($fields->{'content-transfer-encoding'})) {
	$encoding = lc $fields->{'content-transfer-encoding'}[0];
	$encoding =~ s/\s//g;
	$decodefunc = &load_decoder($encoding);
    } else {
	$encoding = undef;
	$decodefunc = undef;
    }
    my $decoded = 0;
    if (defined($decodefunc) && defined(&$decodefunc)) {
	$$body = &$decodefunc($$body);
	$decoded = 1;
    } elsif ($decodefunc =~ /as-is/i) {
	$decoded = 1;
    }

    ## Convert text encoding
    if ($type eq 'text') {
	my $charset = extract_charset($content, $subtype, $body);
	$fields->{'x-mha-charset'} = $charset;
	my $textfunc = load_textencoder();
	if (defined($textfunc)) {
            if ($DEBUG) {
              print STDERR "MAILread_body: have textfunc: $textfunc\n";
            }
	    $fields->{'x-mha-charset'} = $TextEncode
		if defined(&$textfunc($body, $charset, $TextEncode));
	}
	if (defined($TextPreFilter) && defined(&$TextPreFilter)) {
            if ($DEBUG) {
              print STDERR 'MAILread_body: have TextPreFilter: ',
                           $TextPreFilter, "\n";
            }
	    &$TextPreFilter($fields, $body);
	}
    } else {
	# define x-mha-charset in case text filter associated with
	# a non-text type
	$fields->{'x-mha-charset'} = $TextDefCharset;
    }
    if ($DEBUG) {
      print STDERR 'MAILread_body: charset: ',$fields->{'x-mha-charset'},"\n";
    }

    ## A filter is defined for given content-type
    if ($filter && defined(&$filter)) {
	@array = &$filter($fields, $body, $decoded, $args);
	## Setup return variables
	$ret = shift @array;				# Return string
	push(@files, @array);				# Derived files

    ## No filter defined for given content-type
    } else {
	## If multipart, recursively process each part
	if ($type =~ /\bmultipart\b/i) {
	    local(%Cid) = ( )  unless scalar(caller) eq 'readmail';
	    my($isalt) = $subtype =~ /\balternative\b/i;

	    ## Get boundary
	    $boundary = "";
	    if ($content =~ m/\bboundary\s*=\s*"([^"]*)"/i) {
		$boundary = $1;
	    } else {
		($boundary) = $content =~ m/\bboundary\s*=\s*([^\s;]+)/i;
		$boundary =~ s/;$//;  # chop ';' if grabbed
	    }

	    ## If boundary defined, split body into parts
	    if ($boundary =~ /\S/) {
		my $found = 0;
		my $have_end = 0;
		my $start_pos = 0;
		substr($$body, 0, 0) = "\n";
		substr($boundary, 0, 0) = "\n--";
		my $blen = length($boundary);
		my $bchkstr;

		while (($pos = index($$body, $boundary, $start_pos)) > -1) {
		    # have to check for case when boundary is a substring
		    #	of another boundary, yuck!
		    $bchkstr = substr($$body, $pos+$blen, 2);
		    unless ($bchkstr =~ /\A\r?\n/ || $bchkstr =~ /\A--/) {
			# incomplete match, continue search
			$start_pos = $pos+$blen;
			next;
		    }
		    $found = 1;
		    push(@parts, substr($$body, 0, $pos));
		    $parts[$#parts] =~ s/^\r//;

		    # prune out part data just grabbed
		    substr($$body, 0, $pos+$blen) = "";

		    # check if hit end
		    if ($$body =~ /\A--/) {
			$have_end = 1;
			last;
		    }

		    # remove EOL at the beginning
		    $$body =~ s/\A\r?\n//;
		    $start_pos = 0;
		}
		if ($found) {
		    if (!$have_end) {
			warn qq/Warning: No end boundary delimiter found in /,
			     qq/message body\n/;
			push(@parts, $$body);
			$parts[$#parts] =~ s/^\r//;
			$$body = "";
		    } else {
			# discard front-matter
			shift(@parts);
		    }
		} else {
		    # no boundary separators in message!
		    warn qq/Warning: No boundary delimiters found in /,
			 qq/multipart body\n/;
		    if ($$body =~ m/\A\n[\w\-]+:\s/) {
			# remove \n added above if part looks like it has
			# headers.  we keep if it does not to avoid body
			# data being parsed as a header below.
			substr($$body, 0, 1) = "";
		    }
		    push(@parts, $$body);
		}

	    ## Else treat body as one part
	    } else {
		@parts = ($$body);
	    }

	    ## Process parts
	    my(@entity) = ();
	    my($cid, $href, $pctype);
	    my %alt_exc = ( );
	    my $have_alt_prefs = $isalt && scalar(@_MIMEAltPrefs);
	    my $partno = 0;
	    @parts = \(@parts);
	    while (defined($part = shift(@parts))) {
		$href = { };
		$partfields = $href->{'fields'} = (MAILread_header($part))[0];
		$href->{'body'} = $part;
		$href->{'filtered'} = 0;
		$partfields->{'x-mha-part-number'} = ++$partno;
		$pctype = extract_ctype(
		    $partfields->{'content-type'}, $ctype);

		## check alternative preferences
		if ($have_alt_prefs) {
		  next  if ($alt_exc{$pctype});
		  my $pos = $_MIMEAltPrefs{$pctype};
		  if (defined($pos)) {
		      for (++$pos; $pos <= $#_MIMEAltPrefs; ++$pos) {
			  $alt_exc{$_MIMEAltPrefs[$pos]} = 1;
		      }
		  }
		}

		## only add to %Cid if not excluded
		if (!&MAILis_excluded($pctype)) {
		    if ($isalt) {
			unshift(@entity, $href);
		    } else {
			push(@entity, $href);
		    }
		    $cid = $partfields->{'content-id'}[0] ||
			   $partfields->{'message-id'}[0];
		    if (defined($cid)) {
			$cid =~ s/[\s<>]//g;
			$Cid{"cid:$cid"} = $href  if $cid =~ /\S/;
		    }
		    $cid = undef;
		    if (defined($partfields->{'content-location'}) &&
			    ($cid = $partfields->{'content-location'}[0])) {
			my $partbase = $uribase;
			$cid =~ s/['"\s]//g;
			if (defined($partfields->{'content-base'})) {
			    $partbase = $partfields->{'content-base'}[0];
			}
			$cid = apply_base_url($partbase, $cid);
			if ($cid =~ /\S/ && !$Cid{$cid}) {
			    $Cid{$cid} = $href;
			}
		    }
		    if ($cid) {
			$partfields->{'content-location'} = [ $cid ];
		    } elsif (!defined($partfields->{'content-base'})) {
			$partfields->{'content-base'} = [ $uribase ];
		    }

		    $partfields->{'x-mha-parent-header'} = $fields;
		}
	    }

	    my($entity);
	    ENTITY: foreach $entity (@entity) {
		if ($entity->{'filtered'}) {
		    next ENTITY;
		}

		## If content-type not defined for part, then determine
		## content-type based upon multipart subtype.
		$partfields = $entity->{'fields'};
		if (!defined($partfields->{'content-type'})) {
		    $partfields->{'content-type'} =
		      [ ($subtype =~ /digest/) ?
			    'message/rfc822' : 'text/plain' ];
		}

		## Process part
		@array = MAILread_body(
			    $partfields,
			    $entity->{'body'},
			    $isalt);

		## Only use last filterable part in alternate
		if ($isalt) {
		    $ret = shift @array;
		    if ($ret) {
			push(@files, @array);
			$entity->{'filtered'} = 1;
			last ENTITY;
		    }
		} else {
		    if (!$array[0]) {
			$array[0] = &$CantProcessPartFunc(
					$partfields->{'content-type'}[0]);
		    }
		    $ret .= shift @array;
		}
		push(@files, @array);
		$entity->{'filtered'} = 1;
	    }

	    ## Check if multipart/alternative, and no success
	    if (!$ret && $isalt) {
		warn qq|Warning: No recognized part in multipart/alternative; |,
		     qq|will try to decode last part\n|;
		$entity = $entity[0];
		@array = &MAILread_body(
			    $entity->{'fields'},
			    $entity->{'body'});
		$ret = shift @array;
		if ($ret) {
		    push(@files, @array);
		} else {
		    $ret = &$UnrecognizedAltPartFunc();
		}
	    }

	    ## Aid garbage collection(?)
	    foreach $entity (@entity) {
		delete $entity->{'fields'}{'x-mha-parent-header'};
	    }

	## Else if message/rfc822 or message/news
	} elsif ($ctype =~ m^\bmessage/(?:rfc822|news)\b^i) {
	    $partfields = (MAILread_header($body))[0];

	    # propogate parent and part no to message/* header
	    $partfields->{'x-mha-parent-header'} =
		$fields->{'x-mha-parent-header'};
	    $partfields->{'x-mha-part-number'} =
		$fields->{'x-mha-part-number'};

	    $ret = &$BeginEmbeddedMesgFunc();
	    if ($FormatHeaderFunc && defined(&$FormatHeaderFunc)) {
		$ret .= &$FormatHeaderFunc($partfields);
	    } else {
		warn "Warning: readmail: No message header formatting ",
		     "function defined\n";
	    }
	    @array = MAILread_body($partfields, $body);
	    $ret .= shift @array ||
			&$CantProcessPartFunc(
			    $partfields->{'content-type'}[0] || 'text/plain');
	    $ret .= &$EndEmbeddedMesgFunc();

	    push(@files, @array);
	    delete $partfields->{'x-mha-parent-header'};

	## Else cannot handle type
	} else {
	    $ret = '';
	}
    }

    ($ret, @files);
}

##---------------------------------------------------------------------------##
##	MAILread_header reads (and strips) a mail message header from the
##	variable $mesg.  $mesg is a reference to the mail message in
##	a string.
##
##	$fields is a reference to a hash to put field values indexed by
##	field labels that have been converted to all lowercase.
##	Field values are array references to the values
##	for each field.
##
##	($fields_hash_ref, $header_txt) = MAILread_header($mesg_data);
##
sub MAILread_header {
    my $mesg   = shift;

    my $fields = { };
    my $label = '';
    my $header = '';
    my($value, $tmp, $pos);

    ## Read a line at a time.
    for ($pos=0; $pos >= 0; ) {
	$pos = index($$mesg, "\n");
	if ($pos >= 0) {
	    $tmp = substr($$mesg, 0, $pos+1);
	    substr($$mesg, 0, $pos+1) = "";
	    last  if $tmp =~ /^\r?$/;	# Done if blank line

	    $header .= $tmp;
	    chop $tmp;			# Chop newline
	    $tmp =~ s/\r$//;		# Delete <CR> characters
	} else {
	    $tmp = $$mesg;
	    $header .= $tmp;
	}

	## Check for continuation of a field
	if ($tmp =~ /^\s/) {
	    $fields->{$label}[-1] .= $tmp  if $label;
	    next;
	}

	## Separate head from field text
	if ($tmp =~ /^([^:\s]+):\s*([\s\S]*)$/) {
	    ($label, $value) = (lc($1), $2);
	    if ($fields->{$label}) {
		push(@{$fields->{$label}}, $value);
	    } else {
		$fields->{$label} = [ $value ];
	    }
	}
    }
    decode_1522_fields($fields);
    ($fields, $header);
}

##---------------------------------------------------------------------------##
##	MAILread_file_header reads (and strips) a mail message header
##	from the filehandle $handle.  The routine behaves in the
##	same manner as MAILread_header;
##
##	($fields_hash, $header_text) = MAILread_file_header($filehandle);
##	
sub MAILread_file_header {
    my $handle = shift;
    my $encode = shift;

    my $label  = '';
    my $header = '';
    my $fields = { };
    local $/   = "\n";

    my($value, $tmp);
    while (($tmp = <$handle>) !~ /^[\r]?$/) {
	## Save raw text
	$header .= $tmp;

	## Delete eol characters
	$tmp =~ s/[\r\n]//g;

	## Check for continuation of a field
	if ($tmp =~ /^\s/) {
	    $fields->{$label}[-1] .= $tmp  if $label;
	    next;
	}

	## Separate head from field text
	if ($tmp =~ /^([^:\s]+):\s*([\s\S]*)$/) {
	    ($label, $value) = (lc($1), $2);
	    if (defined($fields->{$label})) {
		push(@{$fields->{$label}}, $value);
	    } else {
		$fields->{$label} = [ $value ];
	    }
	}
    }
    decode_1522_fields($fields);
    ($fields, $header);
}

##---------------------------------------------------------------------------##
##	MAILis_excluded() checks if specified content-type has been
##	specified to be excluded.
##
sub MAILis_excluded {
    my $ctype = lc($_[0]) || 'text/plain';
    my $btype = undef;

    $ctype =~ s/\/x-/\//;
    if ($ctype =~ m|([^/]+)/|) {
	$btype = $1;
    }

    MIMEINCS: {
	# Treat multipart special: It is always included unless present
	# in MIMEExcs.
	last  MIMEINCS  if ($ctype =~ /^multipart\b/);

	if (%MIMEIncs) {
	    if ($MIMEIncs{$ctype} || (defined($btype) && $MIMEIncs{$btype})) {
		last MIMEINCS;
	    } else {
		return 1;
	    }
	}
    }
    if ($MIMEExcs{$ctype} || (defined($btype) && $MIMEExcs{$btype})) {
	return 1;
    }
    0;
}

##---------------------------------------------------------------------------##
##	MAILhead_get_disposition gets the content disposition and
##	filename from $hfields, $hfields is a hash produced by the
##	MAILread_header and MAILread_file_header routines.
##
sub MAILhead_get_disposition {
    my $hfields = shift;
    my $do_html = shift;

    my($disp, $filename, $raw) = ('', '', '');
    my $html_name = undef;
    local($_);

    if (defined($hfields->{'content-disposition'}) &&
	    ($_ = $hfields->{'content-disposition'}->[0])) {
	($disp)	= /^\s*([^\s;]+)/;
	if (/filename="([^"]+)"/i) {
	    $raw = $1;
	} elsif (/filename=(\S+)/i) {
	    ($raw = $1) =~ s/;\s*$//g;
	}
    }
    if (!$raw && defined($_ = $hfields->{'content-type'}[0])) {
	if (/name="([^"]+)"/i) {
	    $raw = $1;
	} elsif (/name=(\S+)/i) {
	    ($raw = $1) =~ s/;\s*$//g;
	}
    }
    $filename = MAILdecode_1522_str($raw, DECODE_ALL);
    $filename =~ s%.*[/\\:]%%;	# Remove any path component
    $filename =~ s/^\s+//;	# Remove leading whitespace
    $filename =~ s/\s+$//;	# Remove trailing whitespace
    $filename =~ tr/\0-\40\t\n\r?:*"'<>|\177-\377/_/;
				# Remove questionable/invalid characters

    # Only provide HTML display version if requested
    $html_name = MAILdecode_1522_str($raw)  if $do_html;

    ($disp, $filename, $raw, $html_name);
}

##---------------------------------------------------------------------------##
##	MAILparse_parameter_str(): parses a parameter/value string.
##	Support for RFC 2184 extensions exists.  The $hasmain flag tells
##	the method if there is an intial main value for the sting.  For
##      example:
##
##          text/plain; charset=us-ascii
##      ----^^^^^^^^^^
##
##      The "text/plain" part is not a parameter/value pair, but having
##      an initial value is common among some header fields that can have
##      parameter/value pairs (egs: Content-Type, Content-Disposition).
##
##	Return Value:
##	    Reference to a hash.  Each key is the attribute name.
##	    The special key, 'x-main', is the main value if the
##	    $hasmain flag is set.
##
##	    Each hash value is a hash reference with three keys:
##	    'charset', 'lang', 'value'.  'charset' and 'lang' may be
##	    undef if character set or language information is not
##	    specified.
##
##	Example Usage:
##
##	    $content_type_field = 'text/plain; charset=us-ascii';
##	    $parms = MAILparse_parameter_str($content_type_field, 1);
##	    $ctype = $parms->{'x-main'};
##	    $mesg_body_charset = $parms->{'charset'}{'value'};
##
sub MAILparse_parameter_str {
    my $str     = shift;        # Input string
    my $hasmain = shift;        # Flag if there is a main value to extract

    require MHonArc::RFC822;

    my $parm	= { };
    my @toks    = MHonArc::RFC822::uncomment($str);
    my($tok, $name, $value, $charset, $lang, $isPart);

    $parm->{'x-main'} = shift @toks  if $hasmain;

    ## Loop thru token list
    while ($tok = shift @toks) {
        next if $tok eq ";";
        ($name, $value) = split(/=/, $tok, 2);
        ## Check if charset/lang specified
        if ($name =~ s/\*$//) {
            if ($value =~ s/^([^']*)'([^']*)'//) {
                ($charset, $lang) = ($1, $2);
            } else {
                ($charset, $lang) = (undef, undef);
            }
        }
        ## Check if parameter is only part
        if ($name =~ s/\*(\d+)$//) {
            $isPart = 1;
        } else {
            $isPart = 0;
        }
        ## Set values for parameter
        $name = lc $name;
        $parm->{$name} = {}  unless defined($parm->{$name});
        $parm->{$name}{'charset'} = $charset;
        $parm->{$name}{'lang'} = $lang;
        ## Check if value is next token
        if ($value eq "") {
            ## If value next token, than it must be quoted
            $value = shift @toks;
            $value =~ s/^"//;  $value =~ s/"$//;  $value =~ s/\\//g;
        }
        if ($isPart && defined($parm->{$name}{'vlist'})) {
          push(@{$parm->{$name}{'vlist'}}, $value);
        } else {
          $parm->{$name}{'vlist'} = [ $value ];
        }
    }

    ## Now we loop thru each parameter and define the final values from
    ## the parts
    foreach $name (keys %$parm) {
	next  if $name eq 'x-main';
        $parm->{$name}{'value'} = join("", @{$parm->{$name}{'vlist'}});
    }

    $parm;
}

##---------------------------------------------------------------------------##
##	MAILset_alternative_prefs() is used to set content-type
##	preferences for multipart/alternative entities.  The list
##	specified will supercede the prefered format as denoted by
##	the ording of parts in the entity.
##
##	A content-type listed earlier in the array will be prefered
##	over one later.  For example:
##
##	  MAILset_alternative_prefs('text/plain', 'text/html');
##
##	States that if a multipart/alternative entity contains a
##	text/plain part and a text/html part, the text/plain part will
##	be prefered over the text/html part.
##
sub MAILset_alternative_prefs {
    @_MIMEAltPrefs = map { lc } @_;
    %_MIMEAltPrefs = ();
    my $i = 0;
    my $ctype;
    foreach $ctype (@_MIMEAltPrefs) {
	$_MIMEAltPrefs{$ctype} = $i++;
    }
}

##---------------------------------------------------------------------------##
##	MAILset_charset_aliases() is used to define name aliases for
##	charset names.
##
##	Example usage:
##	  MAILset_charset_aliases( {
##	    'iso-8859-1' =>  [ 'latin1', 'iso_8859_1', '8859-1' ],
##	    'iso-8859-15' => [ 'latin9', 'iso_8859_15', '8859-15' ],
##	  }, $override );
##	  
sub MAILset_charset_aliases {
    my $map = shift;
    my $override = shift;

    %MIMECharsetAliases = ()  if $override;
    my($charset, $aliases, $alias);
    while (($charset, $aliases) = each(%$map)) {
	$charset = lc $charset;
	foreach $alias (@$aliases) {
	    $MIMECharsetAliases{lc $alias} = $charset;
	}
    }
}

##---------------------------------------------------------------------------##
##	MAILload_charset_converter() loads the charset converter function
##	associated with given charset name.
##
##	Example usage:
##	  ($func, $real_charset) = MAILload_charset_converter($charset);
##	
##	$func is the reference to the converter function, which may be
##	undef.  $real_charset is the real charset name that should be
##	used when invoking the function.
##
sub MAILload_charset_converter {
    my $charset = lc shift;
    $charset = $MIMECharsetAliases{$charset}  if $MIMECharsetAliases{$charset};
    my $func = load_charset($charset);
    if (!defined($func) || !defined(&$func)) {
	$func = load_charset('default');
    }
    ($func, $charset);
}

###############################################################################
##	Private Routines
###############################################################################

##---------------------------------------------------------------------------##
##	Default function for unable to process a part of a multipart
##	message.
##
sub cantProcessPart {
    my($ctype) = $_[0];
    warn "Warning: Could not process part with given Content-Type: ",
	 "$ctype\n";
    "<br><tt>&lt;&lt;&lt; $ctype: Unrecognized &gt;&gt;&gt;</tt><br>\n";
}
##---------------------------------------------------------------------------##
##	Default function returning message for content-types excluded.
##
sub excludedPart {
    my($ctype) = $_[0];
    "<br><tt>&lt;&lt;&lt; $ctype: EXCLUDED &gt;&gt;&gt;</tt><br>\n";
}
##---------------------------------------------------------------------------##
##	Default function for unrecognizeable part in multipart/alternative.
##
sub unrecognizedAltPart {
    warn "Warning: No recognizable part in multipart/alternative\n";
    "<br><tt>&lt;&lt;&lt; multipart/alternative: ".
    "No recognizable part &gt;&gt;&gt;</tt><br>\n";
}
##---------------------------------------------------------------------------##
##	Default function for beggining of embedded message
##	(ie message/rfc822 or message/news).
##
sub beginEmbeddedMesg {
qq|<blockquote><small>---&nbsp;<i>Begin&nbsp;Message</i>&nbsp;---</small>\n|;
}
##---------------------------------------------------------------------------##
##	Default function for end of embedded message
##	(ie message/rfc822 or message/news).
##
sub endEmbeddedMesg {
qq|<br><small>---&nbsp;<i>End Message</i>&nbsp;---</small></blockquote>\n|;
}

##---------------------------------------------------------------------------##

sub load_charset {
    require $MIMECharSetConvertersSrc{$_[0]}
	if defined($MIMECharSetConvertersSrc{$_[0]}) &&
	   $MIMECharSetConvertersSrc{$_[0]};
    $MIMECharSetConverters{$_[0]};
}
sub load_decoder {
    my $enc = lc shift; $enc =~ s/\s//;
    require $MIMEDecodersSrc{$enc}
	if defined($MIMEDecodersSrc{$enc}) &&
	   $MIMEDecodersSrc{$enc};
    $MIMEDecoders{$enc};
}
sub load_filter {
    require $MIMEFiltersSrc{$_[0]}
	if defined($MIMEFiltersSrc{$_[0]}) &&
	   $MIMEFiltersSrc{$_[0]};
    $MIMEFilters{$_[0]};
}
sub get_filter_args {
    my $args	= '';
    my $s;
    foreach $s (@_) {
	next  unless defined $s;
	$args = $MIMEFiltersArgs{$s};
	last  if defined($args) && ($args ne '');
    }
    $args;
}
sub load_textencoder {
    return undef  unless $TextEncode;
    TRY: {
	if (!defined($TextEncoderFunc)) {
	    last TRY;
	}
	if (defined(&$TextEncoderFunc)) {
	    return $TextEncoderFunc;
	}
	if (!defined($TextEncoderSrc)) {
	    last TRY;
	}
	require $TextEncoderSrc;
	if (defined(&$TextEncoderFunc)) {
	    return $TextEncoderFunc;
	}
    }
    warn qq/Warning: Unable to load text encode for "$TextEncode"\n/;
    $TextEncode = undef;
    $TextEncoderFunc = undef;
    $TextEncoderSrc = undef;
}

##---------------------------------------------------------------------------##
##	extract_ctype() extracts the content-type specification from
##	the beginning of given string.
##
sub extract_ctype {
    if (!defined($_[0]) ||
	  (ref($_[0]) && ($_[0][0] !~ /\S/)) ||
	  ($_[0] !~ /\S/)) {
	return 'message/rfc822'
	    if (defined($_[1]) && ($_[1] eq 'multipart/digest'));
	return 'text/plain';
    }
    if (ref($_[0])) {
	$_[0][0] =~ m|^\s*([\w\-\./]+)|;
	return lc($1);
    }
    $_[0] =~ m|^\s*([\w\-\./]+)|;
    lc($1);
}

##---------------------------------------------------------------------------##
##	apply_base_url(): Convert a relative URL to a full URL with
##	specific base;
##
sub apply_base_url {
    my $b = shift;  # Base URL
    my $u = shift;  # URL to apply base to

    ## If no base, nothing to do
    return $u  if !defined($b) || $b !~ /\S/;

    ## If absolute URL or scroll link; do nothing
    $u =~ s/^\s+//;
    if ($u =~ /^$UrlRxStr/o || $u =~ m/^#/) {
        return $u;
    }

    ## Check if base URL allows relative resolution
    my($host_part, $scheme);
    if ($b =~ s{^((https?|ftp|file|nfs|acap|tftp)://[\w\-:\d.\@\%=~&]+)/?}{}) {
	$host_part = $1;
	$scheme    = lc $2;
    } else {
	warn qq/Warning: Invalid base url, "$b" to apply to "$u"\n/;
	return $u;
    }

    ## If "/---", just use hostname:port of base.
    if ($u =~ /^\//) {
	return $host_part . $u;
    }

    ## Clean up base URL
    SCHEME: {
	if ($scheme eq 'http' || $scheme eq 'https' || $scheme eq 'acap') {
	    $b =~ s/\?.*$//;
	    last SCHEME;
	}
	if ($scheme eq 'ftp') {
	    $b =~ s/;type=.$//;
	    last SCHEME;
	}
	if ($scheme eq 'tftp') {
	    $b =~ s/;mode=\w+$//;
	    last SCHEME;
	}
    }
    $b =~ s/\/$//;    # strip any trailing '/' (we add it back later)

    ## "./---" or "../---": Need to remove and adjust base accordingly.
    my $cnt = 0;
    while ( $u =~ s|^(\.{1,2})/|| ) { ++$cnt  if length($1) == 2; }

    if ($b eq '') {
	# base is just host
	return join('/', $host_part, $u);
    }
    if ($cnt > 0) {
	# trim path
	my @a = split(/\//, $b);
	if ($cnt <= scalar(@a)) {
	    splice(@a, -$cnt);
	    return join('/', $host_part, @a, $u);
	}
	# invalid relative path, tries to go past root
	return join('/', $host_part, $u);

    }
    return join('/', $host_part, $b, $u);
}

##---------------------------------------------------------------------------##

sub extract_charset {
    my $content = shift;  # Content-type string of entity
    my $subtype = shift;  # Text sub-type
    my $body    = shift;  # Reference to entity text
    my $charset = $TextDefCharset;

    if ($content =~ /\bcharset\s*=\s*([^\s;]+)/i) {
	$charset =  lc $1;
	$charset =~ s/['";\s]//g;
    }

    # If HTML, check <meta http-equiv=content-type> tag since it
    # can be different than what is specified in the entity header.
    if (($subtype eq 'html' || $subtype eq 'x-html') &&
	($$body =~ m/(<meta\s+http-equiv\s*=\s*['"]?
		     content-type\b[^>]*>)/xi)) {
	my $meta = $1;
	if ($meta =~ m/\bcharset\s*=\s*['"]?([\w\.\-]+)/i) {
	    $charset = lc $1;
	}
    }
    $charset = $MIMECharsetAliases{$charset}
	if $MIMECharsetAliases{$charset};

    # If us-ascii, but 8-bit chars in body, we change to iso-8859-1
    if ($charset eq 'us-ascii') {
	$charset = 'iso-8859-1'  if $$body =~ /[\x80-\xFF]/;
    }
    $charset;
}

##---------------------------------------------------------------------------##
##	gen_full_part_number creates a full part number of an entity
##	from the given entity header.
##
sub gen_full_part_number {
    my $fields = shift;
    my @number = ( );
    while (defined($fields->{'x-mha-parent-header'})) {
	unshift(@number, ($fields->{'x-mha-part-number'} || '1'));
	$fields = $fields->{'x-mha-parent-header'};
    }
    if (!scalar(@number)) {
	return $fields->{'x-mha-part-number'} || '1';
    }
    join('.', @number);
}

##---------------------------------------------------------------------------##

sub decode_1522_fields {
  my $fields  = shift;
  my $encfunc = load_textencoder();
  my $mode    = defined($encfunc)
                  ? TEXT_ENCODE : ($DecodeHeader ? JUST_DECODE : -1);
  if ($mode == -1) {
    return $fields;
  }
  my ($label, $value, $v);
  while (($label, $value) = each %$fields) {
    foreach $v (@$value) {
      $v = &MAILdecode_1522_str($v, $mode);
    }
  }
  $fields;
}

##---------------------------------------------------------------------------##

sub dump_header {
    my $fh	= shift;
    my $fields	= shift;
    my($key, $a, $value);
    foreach $key (sort keys %$fields) {
	$a = $fields->{$key};
	if (ref($a)) {
	    foreach $value (@$a) {
		print $fh "$key: $value\n";
	    }
	} else {
	    print $fh "$key: $a\n";
	}
    }
}

##---------------------------------------------------------------------------##
1; # for require