package Email::MIME::XMTP;

use vars qw[$VERSION];
$VERSION = '0.32';

use Email::MIME;

# adds XMTP to Email::MIME namespace (pollution?)
package Email::MIME;

use strict;

use Email::MIME::Encodings;
use XML::Parser; #not used yet...

my %namespaces = (
	'rdf'  => "http://www.w3.org/1999/02/22-rdf-syntax-ns#",
	'xmtp' => "http://www.openhealth.org/xmtp#"
	);

=head1 NAME

Email::MIME::XMTP - Extends Email::MIME objects to read and write XMTP

=head1 SYNOPSIS

    use Email::MIME;
    use Email::MIME::XMTP;
    my $mail = Email::MIME->new($text);

    # Email::XMTP extra methods
    my $xmlstring = $mail->as_XML;

    my $mailer = Email::Simple->new;
    my $mail = $mailer->parseXML( xml => $xmlstring );


=head1 DESCRIPTION

C<Email::MIME::XMTP> extends Email::MIME to read and write XMTP.

Read more about XMTP at http://www.openhealth.org/xmtp/

=head1 METHODS

Methods are the same as the one of Email::MIME. With the addition of
two extra ones for reading (parsing) and writing XMTP format. Plus one
to set the elements/headers XML namespaces and prefixes.

=head2 parseXML

Parse an XML SOURCE containing an XMTP formatted message and return a mail object.

The parseXML method takes any of the following parameters:

               filename
               xml
               ioref

One must be spacefied - it is an error if none is passed.

This uses the familiar hash syntax, so an example might be:

	use Email::XMTP;
	my $mailer = new Email::XMTP;

	my $mail = $mailer->parseXML( filename => 'example-mail-xmtp.xml');

The parameters represent a filename, a string containing XML and
an open filehandle ref respectively.

=cut

# TODO
sub parseXML {
	my ( $self, %params ) = @_;

	return
		unless(	exists $params{'xml'} or
			exists $params{'filename'} or
			exists $params{'ioref'} 
			);

	#my $parser = XML::Parser->new( %params );
	#$parser->parse;
	};

sub _init_namespaces {	
	my ($self) = @_;

	$self->{'_XML_namespaces'} = {};

	map {
		$self->{'_XML_namespaces'}->{ $_ } = $namespaces{ $_ };
		} keys %namespaces;
	};

=head2 set_namespace( PREFIX, URI )

Set the XML Namespace PREFIX to URI

=cut

sub set_namespace {	
	my ($self, $prefix, $uri) = @_;

	$self->_init_namespaces()
		unless( exists $self->{'_XML_namespaces'} );

	return
		if(	$prefix eq 'rdf' or
			$prefix eq 'xmtp' );

	$self->{'_XML_namespaces'}->{ $prefix } = $uri;
	};

=head2 as_XML( [@FILTER_HEADERS] )

Returns an XML XMTP representation of a message. Optionally the FILTER_HEADERS array
can be used to restrict the MIME headers to return. In case any special XML
namespace is set, in addition to XMTP; the headers must be listed with their
fully qualified XML QNAME e.g. myprefix:My-Header.

=cut

sub as_XML {	
	my ( $self, @filter_headers ) = @_;

	$self->_init_namespaces()
		unless( exists $self->{'_XML_namespaces'} );

	my $xml  = "<?xml version='1.0' ?>\n";

	my @parts =  $self->parts; #take one part for the moment

	# be sure the first part is the message itself - then its multi-parts eventually
	unshift @parts, $self
		unless($#parts==0);

	# NOTE: we do primite nesting - and do not recurse over parts - is that what MIME spec says? nested multipart??!?
	my $i = 1;
	foreach my $part ( @parts ) {
		# well we should recurse to nested parts here too...

		my $about =  $part->header( "Message-Id" );
		if($about) {
			$about =~ m/<([^>]+)>/;
			$about = "mid:" . $1;
			};

		unless($i==1) {
			# fix XMTP bug - proper RDF striped nesting
			$xml    .= "\n".("   " x $i)."<xmtp:Body-Multipart>"
				if( $self->content_type =~ m/^\s*multipart/ );
			};

		$xml    .= "\n".("   " x $i)."<xmtp:Message";
		map {
			$xml    .= "\n".("   " x $i)."xmlns:". $_ ."='".$self->{'_XML_namespaces'}->{ $_ }."'";
			} sort keys %{ $self->{'_XML_namespaces'} };
		$xml    .= "\n".("   " x $i)."rdf:about='$about'"
			if($about);
		$xml    .= ">";

		$xml    .= $part->_headers_as_XML( $i, @filter_headers );

		if(	($part->body) &&
			(	( $#filter_headers < 0 ) ||
				( grep /^xmtp:Body$/, @filter_headers ) ) ) {
			# Binary data should be base64 encoded
			my $body = (	$part->content_type =~ m/text/ or
					$part->content_type =~ m/^\s*multipart/ ) ? $part->body : 
						Email::MIME::Encodings::encode( base64 => $part->body );
			$xml    .= "\n".("      " x $i)."<xmtp:Body>". $part->xml_escape( $body ) ."</xmtp:Body>";
			};

		unless($i==1) {
			$xml .= "\n".("   " x $i)."</xmtp:Message>";

			# fix XMTP bug - proper RDF striped nesting
			$xml    .= "\n".("   " x $i)."</xmtp:Body-Multipart>"
				if( $self->content_type =~ m/^\s*multipart/ );
			};
		
		$i++;
		};

	$xml .= "\n</xmtp:Message>";

	#print STDERR $xml;

	return $xml;
	};

sub _headers_as_XML {
	my ( $self, $i, @filter_headers ) = @_;

	my @order = @{$self->{order}};
	my %head = %{$self->{head}};
	my $stuff = "";

	# a valid XML tag
	my $NameStrt = "[A-Za-z_:]|[^\\x00-\\x7F]";
	my $NameChar = "[A-Za-z0-9_:.-]|[^\\x00-\\x7F]";
	my $Name = "(?:$NameStrt)(?:$NameChar)*";

	while (keys %head) {
		my $thing = shift @order;
		next unless exists $head{$thing}; # We have already dealt with it

		$stuff .= $self->_header_as_XML($thing, $head{$thing}, $i)
			if(	( $thing =~ m/^$Name$/o ) && #skip non-XML tag alike headers
				(	( $#filter_headers < 0 ) ||
					( grep /^$thing$/, @filter_headers ) ) );

		delete $head{$thing};
		};
	return $stuff;
	};

sub _header_as_XML {
	my ($self, $field, $data, $i) = @_;
	my @stuff = @$data;
	# Ignore "empty" headers
	return '' unless @stuff = grep { defined $_ } @stuff;

	my $xml;
	foreach ( @stuff ) {
		my $ff = $_;
		my @parts = split(/\s*;\s/, $ff );
		# check if we really have a a MIME headers parameter/s list
		foreach (@parts) {
			my $p = $_; #copy
			$p =~ s/^\s*//;
			$p =~ s/\s*$//;
			if( my @ss = split(/\s*=\s*/, $p ) ) {
				# check each parameter
				my $stop=0;
				foreach my $sp ( @ss ) {
					$sp =~ s/^\s*//;
					$sp =~ s/\s*$//;
					if(	( not ( $sp =~ m/^["']/ and # not a literal - correct?
							$sp =~ m/["']$/  ) ) and
						$sp =~ m/\s+/ ) { #wrong then
						$stop=1;
						last;
						};
					};
				if($stop) {
					(@parts) = shift @parts;
					last;
					};
			} elsif( $p =~ m/\s+/ ) { # wrong then
				(@parts) = shift @parts;
				last;
				};
			};
		my $prefix;
		$field =~ s/^([^:]+)://;
		if($1) {
			if( exists $self->{'_XML_namespaces'}->{ $1 } ) {
				$prefix = $1;
			} else {
				next; # skip unknown fields
				};
		} else {
			$prefix = 'xmtp';
			};
	
		if($#parts == 0 ) {
			$ff = "\n".("      " x $i)."<$prefix:$field>". $self->xml_escape( $ff ) . "</$prefix:$field>";
		} else {
			# rdf:parseType="Resource"
			$ff = "\n".("      " x $i)."<$prefix:$field rdf:parseType='Resource'>";
			foreach my $part ( @parts ) {
				my $subfield;
				my $subvalue;
				my @subparts = split(/\s*=\s*/, $part );
				if( $#subparts == 0 ) {
					$subfield = "rdf:value"; # right - but we can have at most ONE rdf:value is that true for MIME headers parameters??
					$subvalue = $subparts[0];
				} else {
					$subfield = $prefix.':' . shift @subparts;
					$subvalue = shift @subparts;
					# trim value
					$subvalue =~ s/^\s*["']//gm;
					$subvalue =~ s/["']\s*$//gm;
					};

				$ff .= "\n".("         " x $i)."<$subfield>". $self->xml_escape( $subvalue ) . "</$subfield>";
				};
			$ff .= "\n".("      " x $i)."</$prefix:$field>";
			};

		$xml .= $ff;
		};

	return $xml;
	};

sub xml_escape {
	my $self = shift;
	my $text  = shift;

        $text =~ s/\&/\&amp;/g;
        $text =~ s/</\&lt;/g;
        foreach (@_) {
                croak "xml_escape: '$_' isn't a single character" if length($_) > 1;

                if ($_ eq '>') {
                        $text =~ s/>/\&gt;/g;
                } elsif ($_ eq '"') {
                        $text =~ s/\"/\&quot;/g;
                } elsif ($_ eq "'") {
                        $text =~ s/\'/\&apos;/g;
                } else {
                        my $rep = '&#' . sprintf('x%X', ord($_)) . ';';
                        if (/\W/) {
                                my $ptrn = "\\$_";
                                $text =~ s/$ptrn/$rep/g;
                        } else {
                                $text =~ s/$_/$rep/g;
                                };
                        };
                };
        return $text;
        };

1;

__END__

=head1 COPYRIGHT AND LICENSE

Copyright (c) 2005 All rights reserved Asemantics S.r.l

(see LICENSE file coming with this distribution)

=head1 AUTHOR

Alberto Reggiori <alberto(at)asemantics.com>

=head1 Email::MIME COPYRIGHT AND LICENSE

Copyright 2004 by Casey West

Copyright 2003 by Simon Cozens

=head1 SEE ALSO

XMTP http://www.openhealth.org/xmtp/

Perl Email Project, http://pep.kwiki.org .

=cut
