#!/bin/perl
#
# Copyright (C) 2010 Roaring Penguin Software Inc.
# Copyright (C) 2021-2022 Dianne Skoll
# This file may be distributed under the terms of the GNU General
# Public License, Version 2,

use strict;
use warnings;
use Getopt::Long;
use Pod::Usage;
use MIME::Parser;
use MIME::Words qw( decode_mimewords );
use File::Temp qw( tempdir );

=head1 NAME

mailmunge-util -- Utility script for message structure debugging

=head1 SYNOPSIS

    # Print a "pretty" version of an input message
    mailmunge-util --prettyprint < input.msg

    # Print the message structure
    mailmunge-util --structure < input.msg

    # Parse and re-MIME the message
    mailmunge-util --dump < input.msg

=head1 DESCRIPTION

This script provides some debug tools for looking at MIME messages.

=head1 OPTIONS

=over 4

=item B<--prettyprint>

Parses a mail message from standard input and reformats it in a "pretty" format
on standard output.  All text/* parts are printed directly, and non-text parts
are described without printing their content.

=item B<--structure>

Parses a mail message from standard input, and outputs a description of the
MIME tree to standard output.

=item B<--dump>

Parses a mail message from standard input, and dumps the parsed message back
out again to standard output.

=item B<--data-dump>

Parses a mail message from standard input, and dumps the parsed message back
out again to standard output using Data::Dumper

=item B<--help>

This help

=item B<--man>

Full manpage

=back

=head1 LICENSE AND COPYRIGHT

Copyright (C) 2010 Roaring Penguin Software Inc.
Copyright (C) 2021-2022 Dianne Skoll

This program may be distributed under the terms of the GNU General
Public License, Version 2, or (at your option) any later version.

=cut

my ($prettyprint, $structure, $dump) = undef;
my %actions;
my $result = GetOptions(
	'prettyprint' => sub { $actions{prettyprint} = 1; },
	'structure'   => sub { $actions{structure} = 1; },
	'dump'        => sub { $actions{dump} = 1; },
	'data-dump'   => sub { $actions{datadump} = 1; },
	'help'        => sub { pod2usage(-exitval => 0, -verbose => 1) },
	'man'         => sub { pod2usage(-exitval => 0, -verbose => 2) },
);

if( keys(%actions) > 1 ) {
	pod2usage( -message => 'Only one of --prettyprint, --structure, --data-dump or --dump may be specified' );
}
if( keys(%actions) < 1 ) {
	pod2usage( -message => 'One of --prettyprint, --structure, --data-dump or --dump must be specified' );
}

my $tmpdir = tempdir( CLEANUP => 1 );

my $parser = MIME::Parser->new();
my $filer  = MIME::Parser::FileInto->new( $tmpdir );
$filer->ignore_filename(1);
$parser->filer( $filer);
$parser->extract_nested_messages(1);
$parser->extract_uuencode(1);
$parser->output_to_core(0);
$parser->tmp_to_core(0);

my $entity = $parser->parse(\*STDIN);
if (!$entity) {
	die qq{Could not parse MIME: $!\n};
}

if( $actions{'datadump'}) {
	use Data::Dumper;
	print Dumper($entity);
} elsif( $actions{'dump'} ) {
	$entity->print(\*STDOUT);
} elsif( $actions{'structure'} ) {
	print_entity_structure( $entity, 0 );
} elsif( $actions{'prettyprint'} ) {
	print $entity->stringify_header,
		"\n",
		pretty_print_mail( $entity, 8192 );
}

exit(0);

sub print_entity_structure
{
	my ($in, $level) = @_;
	my ($type) = $in->mime_type;
	my @parts = $in->parts;
	$type =~ tr/A-Z/a-z/;
	my ($disposition) = $in->head->mime_attr("Content-Disposition");
	my ($body)        = $in->bodyhandle;

	my $fname = $in->head->recommended_filename();
	if($fname) {
		$fname = decode_mimewords($fname);
	} else {
		$fname = '';
	}

	my ($extension) = "";
	$extension = $1 if($fname =~ /(\.[^.]*)$/);
	$disposition = "inline" unless defined($disposition);

	print "    " x $level;
	if(!defined($body)) {
		print "non-leaf: type=$type; fname=$fname; disp=$disposition\n";
		map { print_entity_structure($_, $level + 1) } @parts;
	} else {
		print "leaf: type=$type; fname=$fname; disp=$disposition\n";
	}
}

sub pretty_print_mail
{
	my ($e, $size, $chunk, $depth) = @_;

	$chunk = "" unless defined($chunk);
	$depth = 0  unless defined($depth);

	my (@parts) = $e->parts;
	my ($type)  = $e->mime_type;
	my $fname   = $entity->head->recommended_filename();
	if($fname) {
		$fname = decode_mimewords($fname);
	} else {
		$fname = '';
	}
	$fname = "; filename=$fname" if($fname ne "");
	my ($spaces) = "  " x $depth;
	$chunk .= "\n$spaces" . "[Part: ${type}${fname}]\n\n";
	if($#parts >= 0) {
		my ($part);
		foreach $part (@parts) {
			$chunk = pretty_print_mail($part, $size, $chunk, $depth + 1);
			last if(length($chunk) >= $size);
		}
	} else {
		return $chunk unless ($type =~ m+^text/+);
		my ($body) = $e->bodyhandle;
		return $chunk unless (defined($body));
		my ($path) = $body->path;
		return $chunk unless (defined($path));
		return $chunk unless (open(IN, "<$path"));
		while (<IN>) {
			$chunk .= $_;
			last if(length($chunk) >= $size);
		}
		close(IN);
	}
	return $chunk;
}