#-*-perl-*-
# mime2html
#
# A Mostly MIME compliant mail -> html filter written by Ben Johnson
# with minor assistance from Paul Walker.
#
# This works pretty darned well, it seems, after some fixes
#

# ARGS
#   inputfile - absolute filename of a rfc822/rfc1521 valid message
#   outputfile - desired name of the filtered document.
# ENVIRONMENT
#   $hthome - root directory of the input tree
#   $theproject - subdirectory
#   $themessfolder - subdir of project into which we place mime

sub mime2html {
    undef $boundary;
    local($inputsrc,$outputfile) = @_;
    open(OUT,"> $outputfile");
    open(MIMEIN,"< $inputsrc");
print OUT <<EOM;
<html>
<title>$pagetitle</title>
<body bgcolor="#ffffff">
EOM

    #An associative list of contenttype to the procedure that deals with it.
    # PW would like to disclaim any responsibility for the following
    # variable name!
    %igrok = (
	      "application/octet-stream","application_octet_stream",
	      "application/postscript","application_postscript",
	      "image/gif","image_gif",
	      "image/jpeg","image_jpeg",
	      "message/rfc822","message_rfc822",
	      "multipart/digest","multipart_digest",
	      "multipart/header-set","multipart_header_set",
	      "multipart/mixed","multipart_mixed",
	      "multipart/parallel","multipart_mixed",
	      "text/enriched","text_enriched",
	      "text/html","text_x_html",
	      "text/plain","text_plain",
	      "text/richtext","text_plain",
	      "text/x-html", "text_x_html", 
	      "video/mpeg","video_mpeg",
	      "video/qt","video_quicktime",
	      "video/quicktime","video_quicktime",
	      );
    # Filename extensions for recognized types
    @jpg = ("jpeg","JPEG","jpg","JPG");
    @gif = ("gif","GIF");
    @postscript = ("ps","PS");
    @mpeg = ("mpeg","MPEG","mpg","MPG");
    @quicktime = ("mov","MOV","MOOV","moov");

    # actually do the message
    $messagetail = &basic_rfc822;

    # print the nice trailer
    print OUT "<hr>\n";
    print OUT "<!-- END OF BODY -->\n";
    print OUT "<address> $messagetail </address>" if ($messagetail);
    print OUT "<hr>\n";
    print OUT "<dl>\n";	
    print OUT "<dd>Created for the <a href=\"$htserverhome\">$organization Projects Page</a>. \n";
    print OUT "<dd>Created by <a href=\"http://jean-luc.ncsa.uiuc.edu/Codes/CoCoBoard/\">The CoCoBoard</a>. \n";
    print OUT "<dd><a href=\"removal.html\">Click here for information on removing this post</a>\n" if ($allowremove);
    print OUT "</body></html>\n";
    close OUT;
    close MIMEIN;

    # setup the file contents so that the original poster can remove
    # the message with this ID.
    open (REMOVAL,"> $hthome/$theproject/$themessfolder/removal.html");
    print REMOVAL "\<title\>Removal Information\</title\>\n\<h1\>Removal Information\</h1\>\n";

    print REMOVAL <<ENDREMOVE;
To Remove this post, the original poster must send mail to
<a href=\"mailto:$originator\">$originator</a>
with the text indicated below.  We reccomend you either
copy this mail into your mailer, or send this document to
$originator with the File/Send Mail, if you are running mosaic
on the same machine as which you originated the Mail.
\<P\>
This is the information which needs to be distributed.
\<hr\>
\<pre\>
command removepost

$theproject $themessfolder

\</pre\>
\<hr\>
\<address\>Removal Information / $originator\</address\>

ENDREMOVE
#"
    close(REMOVAL);
    system ("chmod 644 $outfile.removal.html");
    # Done
}

# the most basic routine for dealing with a message.
# ENV
#   OUT and MIMEIN are valid file descriptors.
sub basic_rfc822 {
    &get_headers;

    # print top of message and create message tail as a return value.
    local($messagetail);
    if ( $Header{'from'} ) {
	# Keep Joan happy :-)
 	print OUT "<b>From:</b> " ;
 	if ($usexface && $Header{'x-face'}) {
 
 	    open(XFACE, "|$uncompface | $ikon2xbm > $hthome/$theproject/$themessfolder/face$MainHeader{'email'}.xbm");
# 	    open(XFACE, "|$uncompface | $ikon2xbm | convert - $hthome/$theproject/$themessfolder/face$MainHeader{'email'}.gif");
 	    print XFACE "$Header{'x-face'}";
 	    close XFACE;
 	    print OUT "<img src=\"face$MainHeader{'email'}.xbm\">  ";
 	}
 	print OUT &pretty_line($Header{'from'}), "<br>\n";
	$messagetail = "$Header{'from'}";
    }
    if ( $Header{'date'} ) {
	print OUT "<b>Date:</b> " , &pretty_line($Header{'date'}), "<br>\n";
    }
    if ( $Header{'to'} ) {
	print OUT "<b>To:</b> " , &pretty_line($Header{'to'}), "<br>\n";
    }
    if ( $Header{'cc'} ) {
	print OUT "<b>Cc:</b> ", &pretty_line($Header{'cc'}),"<br>\n";
    }

    if ( $Header{'subject'} ) {
	print OUT "<b>Subject:</b> ",&pretty_line($Header{'subject'}),"<br>\n";
    } else {
	$Header{'subject'} = "No Title";
    }

    if ($messagetail) {
	$messagetail = "$Header{'subject'} / $messagetail";
    } else {
	$messagetail = "$Header{'subject'} ";
    }

    print OUT "<hr>\n";   

    if ( $Header{'mime-version'} ) {
	if ( $Header{'mime-version'} ne "1.0" ) {
	    &mime_warning("I don't understand mime version \#$Header{'mime-version'}#");
	}
	&do_body;
    } else {
	&get_body;
	&text_plain;
    }
    return $messagetail;
}

#  Called from some of the contenttypes, it will guarantee the file is
#  external, with a unique filename and a valid extension
# ARGS
#   the array of args should contain a list of valid filename extensions
#   so the server can correctly infer contenttype
# ENV
#   Message body in @lines
# RETURN
#   The relative filename the body was placed in.
sub make_external {
    local(@ext);
    undef @ext;
    @ext = @_;
    local($done);

    # get the body part
    $return = &get_body;

    # pick a filename
    if ( $parameter{'name'} ) {
	# The best way is if it's specified with real MIME
	$name = $parameter{'name'};
	$name =~ s/[ \"\*\t]//g; #"
    } elsif ( $Header{'x-zm-content-name'} ) {
	# Zmail has it's own special header
	$name = $Header{'x-zm-content-name'};
    } else {
	# unnamed!
	$name = "mimepart";
    }
    # but now check for a decent file extension, so the server
    # can match it's contenttype.
    $done = 0;
#    print "NAME is $name\n";
    foreach $ext (@ext) {
	if ( $name =~ m/$ext$/ ) {
	    $done = 1;
	    last;
	}
    }
    # we've either found it to have a valid extension,
    # OR we now add an extension
    if ( (! $done ) && @ext ) {
	$name .= ".$ext[0]";
    }
    # make sure the name is unique
    # files will be prepended with "X_name" so we increment "X" until
    # it's unique
    local($pre) = 0;
    while (-e "$hthome/$theproject/$themessfolder/$name") {
	if ($name =~ m/^\d+\_(.*)/) {
	    $name = $1;
	}
	$name = "${pre}_$name";
	$pre++;
    }
    # the part may not need decoding, so we'll put it in the file ourselves
    if ( ! &decode_body("$hthome/$theproject/$themessfolder/$name") ) {
	open(TMP,">$hthome/$theproject/$themessfolder/$name");
	print TMP @lines;
	close TMP;
    }

    # now make an icon for this external body
    &makeicon;
    return ($name);
}

# to begin with, everything is in @lines.  If it needed decoding,
# it will need to be put back in @lines.
sub make_internal {
    &get_body;
    if ( &decode_body("$hthome/$theproject/$themessfolder/mimepart.a$$") ) {
	open(REREAD, "< $hthome/$theproject/$themessfolder/mimepart.a$$");
	@lines = <REREAD>;
	close(REREAD);
    }
}


#  these regexps could really screw things up if used
# on things other than Headers.
sub pretty_line {
    ($_) = @_;
    s/&/&gt\;/g;
    s/</&lt\;/g;
    s/>/&gt\;/g;
    # Added by paul for date and joan
    #s/(.*199[0-9])(.*)/\1/;
    s/Masso/Mass\&oacute\;/g;
    # Turn emails into mailtos!
    s%\b(\S+@\S+)\b%<a href=\"mailto:\1\">\1</a>%g;
    # This screws up Paul <pwalker@foo> type addresses, so fix:
    s/\&<a/<a/g;
    s/>lt/>\&lt/g;
    s%</a>\;%\;</a>%g;
    s/mailto:lt\;/mailto:/g;
    s/&gt\"/\"/g;

    return($_);
}

# returns a nice html code for an attachment. 
sub pretty_name {
    local($name,$default) = @_;
    $prettyname = "";
    local($break) ;
    #$break = "<br>";  #If everyone understood <img align=left> ...
    $break = ", ";  

    if ( $Header{'content-description'} ) {
	$prettyname = "<b>Description:</b> $Header{'content-description'}$break";
    } elsif ( $name =~ m/^(\d+_)?mimepart/ ) {
	$prettyname = "<b>Description:</b> $default";
	return "$prettyname";
    }
    $name =~ s/^\d+_//;
    $prettyname .= "<b>Filename: </b>$name";
    return "$prettyname";
}

sub mime_warning {
    ($_) = @_;
#    print "WARNING!!!!\n$_\n";
}

# this function reads in a set of message headers. 
# It expects MIMEIN to be at a point where valid headers exist
# When finished all headers will be in %Header, and MIMEIN will
# point to the first significant line of the message body.
# Any parameters of the content-type are in %parameter
sub get_headers {
    #clean out old headers
    undef %Header;
    undef %parameter;
    undef @parameters ;
    undef @lines;
    undef $rest;
    $rest = 0;
    $contenttype = "";
    $name = $ext = $header = $rest = $var =  $val = "";
    while (<MIMEIN> ) {
	chop; 
	last if  m/^$/ ; # Headers are done when a blank line is encountered
	# headers can be split across multiple lines if the line doesn't begin
	# with "header:".  Build up the values of "header" here.
	if ( m/^(\S*):\s*/ ) {	# We may or may not want this patch
	    $tmp = $1;
	    $tmp2 = $';
	    if ($header && "$rest"  !~ m/^\s*$/) {
		$Header{"\L$header\E"} = $rest;
#		print "$header -> $rest\n";
	    }
	    $header = $tmp;
	    $rest = $tmp2;		#'
	} else {
	    $rest .= $_ ;
	}
    }
    # don't forget to assign the last header!
    $Header{"\L$header\E"} = $rest;

    # If this is a mime contenttype, now make an associative array of the
    # values.
    if ( $Header{'content-type'}) {
	print "CT: $Header{'content-type'}\n";
	$contenttype = $Header{'content-type'}; 
        # pull out only the content, not the parameters
	$contenttype =~ s/^([^\; ]*)\;?(.*)/\L$1\E/; 
	(@parameters) = split(';',$2);
	foreach $i (@parameters) {		
#	    print "PARM: $i\n";
	    $i =~ s/^\s*(.*)\s*$/$1/;  #strip whitespace
	    $i =~ m/([^=]*)=(.*)/;     # search out var and val
	    $var = "\L$1\E";           # be sure to lowercase
	    $val = $2;
	    $val =~ s/^"//;	# chop optional quotes around tspecials "
	    $val =~ s/"$//;     #"
#	    print "$var -> $val\n";
	    $parameter{$var} = "$val"; 
	    #BENJ is this still necessary? 
	    # PW ... probably, else how do we get $boundary?
	    eval "\$$var = \"$val\"" if ($var =~ m/boundary/);
	}		
    }
    if ( $Header{'content-type'} =~ m/^multipart/ ) {
#	print "MULTI\n";
	if ( ! $parameter{'boundary'} ) {
	    &mime_warning("this multipart mixed doesn't have a boundary");
	}
	# since multiparts can be nested, build a stack
	if ($boundary) {
	    push(boundary,$boundary);
	}
	$boundary = $parameter{'boundary'};
    }
}

# EV
#   MIMEIN should point to a valid message body
# RETURN
#   MIMEIN will point to the next valid body part, or possibly EOF
sub get_body {
    $scanned = 0;
    while(<MIMEIN>) {
	if ( $boundary ) {
	    if ( m/--$boundary/ ) {
		if ( m/--$boundary--/ ) {
		    # this clause matches if this is the last boundary
		    # of a multipart.  Thus, pop the boundary stack
		    # BENJ something's wrong if I need to do all this
		    # $boundary = pop(boundary) # should be suffficient
		    $tmp = pop(boundary);
		    if ( $tmp == undef ) {
			$boundary="";
		    } else {
			$boundary = $tmp;
		    }
		}
		last;	
	    } 
	}
	push(lines,$_);
	$scanned++;
    }
    #print "get_body scanned $scanned \n";
}

# this function will undo any transfer encodings
# it may or may not put the contents in a file,so anything that calls it will
# need to check the return value and do the appropriate thing.
# ARGS
#  name - preferred name of the external file
# RETURN
#  1 if it put it into a file, 
#  0 else.
# (wouldn't want to put it back in @lines - it may not be suitable data
#  woudln't want to put it in a file - make_internal would just have to read
#  it again)
sub decode_body {
    local($name) = @_;
    if ( $encoding = $Header{'content-transfer-encoding'} )  {
	open(DECODEOUT, ">$name");
	print DECODEOUT @lines;
	close(DECODEOUT);
	if ( "\L$encoding\E" eq "base64" ) {
	    system("$mmencode -u $name > $name.$$");
	    # clobber the encoded file
	    rename("$name.$$","$name");
	}  elsif ($encoding eq "quoted-printable" ) {
	    system("$qp < $name > $name.$$");
	    # clobber the encoded file
	    rename("$name.$$","$name");
	}
	return 1;
    } 
    return 0;
}

# Determine what contenttype to do, and do it
sub do_body {
    if ( ! $igrok{"$contenttype"} ) {
	&type_unknown;
	return;
    }    
    #print "do_body: $contenttype\n";
    eval "&$igrok{$contenttype}"; 
}			  

1;
