#!/usr/bin/perl
#
# dmmh [ old-prefix ]
#
# De-Mangle MIME Headers (dmmh), more precisely headers that have been
# mangled according to RFC 2047 et al - i.e. the
# =?ISO-8859-1?Q?Qu=6ft=65d-Unr=65=61d=61bl=65_t=65xt?= stuff. Stdin is
# expected to be an RFC822-type message (or preferably the headers only,
# eg. called via a .procmailrc 'hf' recipe) - stdout is unchanged,
# except that any mangled headers have a prefix (default $PREFIX below,
# can be overridden by cmdline arg - a null arg means throw away the
# mangled header) prepended to their field name, and are followed by a
# de-mangled version of the header.
# QP/B64 decoding funcs shamelessly stolen from the MIME module by
# Gisle Aas (somewhat modified for header encoding etc).
#
# Per Hedeland <per@erix.ericsson.se> 99-03-08

$PREFIX="Old-";

$prefix = $#ARGV >= 0 ? $ARGV[0] : $PREFIX;

while (<STDIN>) {	# headers
    last if /^$/;
    if (/^\S/) {
	&do_hdr if $hdr;
	$hdr = $_;
	next;
    }
    $hdr .= $_;
}
&do_hdr if $hdr;
print if /^$/;		# separator (if any)
while (<STDIN>) {	# body (if any)
    print;
}

sub do_hdr {
    $new = "";
    $rest = $hdr;
    while (($pre, $enc, $code, $post) =
	    ($rest =~ /^(.*?)=\?[^?]+\?([qb])\?([^?]+)\?=(.*)$/is)) {
	$new .= $pre if $pre =~ /\S/;
	$new .= $enc =~ /q/i ? &decode_qp($code) : &decode_b64($code);
	$rest = $post;
    }
    if ($new) {
	$new .= $rest;
	print $prefix . $hdr if $prefix;
	# Unfold excessive(?) folding... (but don't re-fold - too hard:-)
	$max = 75;
	while (($pre, $middle, $post) =
	       ($new =~ /^(.*[\S])\s*\n\s+(.*)((\n|.)*)$/)) {
	    if (length($pre) + length($middle) > $max) {
		print $pre . "\n\t";
		$max = 67;
		$new = $middle . $post;
	    } else {
		$new = $pre . " " . $middle . $post;
	    }
	}
	print $new;
    } else {
	print $hdr;
    }
}

sub decode_qp {
    my $res = shift;

    $res =~ s/_/=20/g;		# code hex 20 may be encoded as '_'
    $res =~ s/=([\da-fA-F]{2})/pack("C", hex($1))/ge;
    $res;
}

sub decode_b64 {
    local($^W) = 0; # unpack("u",...) gives bogus warning in 5.001m

    my $str = shift;
    my $res = "";
   
    $str =~ tr|A-Za-z0-9+/||cd;             # remove non-base64 chars (padding)
    $str =~ tr|A-Za-z0-9+/| -_|;            # convert to uuencoded format
    while ($str =~ /(.{1,60})/gs) {
        my $len = chr(32 + length($1)*3/4); # compute length byte
        $res .= unpack("u", $len . $1 );    # uudecode
    }
    $res;
}