# ====================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   GT::Mail::Message
#   Author: Scott Beck
#   CVS Info :                          
#   $Id: Message.pm,v 1.14 2004/01/13 01:35:17 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc.  All Rights Reserved.
# ====================================================================
#

package GT::Mail::Message;

use strict;
use vars qw/$ATTRIBS $CRLF/;
use bases 'GT::Base' => '';

$ATTRIBS = {
    root_part => undef,
    debug     => 0
};

$CRLF = "\012";


sub init {
# --------------------------------------------------------------------------
# Init called from GT::Base
    my $self = shift;

    $self->set( @_ );

    if ( !defined( $self->{root_part} ) ) {
        $self->{root_part} = new GT::Mail::Parts;
    }
    $self->{parts} = _get_parts( $self->{root_part} );
}


sub delete_part {
# --------------------------------------------------------------------------
# Deletes the given part from the email
#
    my ( $self, $part ) = @_;

    die "Can't delete top level part" if $part == $self->{root_part};
    $self->_link;


# We must remove it from the flat list of parts
    $self->_delete_part( $part );

# Now we must relink our list
    $self->_link;

    return $part;
}

sub move_part_before {
# --------------------------------------------------------------------------
# Move a part before another part. The first argument is the part to move 
# before, the second is the part to move. No moving the top level part.
#
    my ( $self, $before_part, $part ) = @_;
    die "Can't move part before the top part" if $before_part == $self->{root_part};
    die "Can't move top part" if $part == $self->{root_part};
    if ( !$self->_part_in_message( $before_part ) or !$self->_part_in_message( $part ) ) {
        die "All parts specified must be in the MIME message";
    }

# First remove the part
    $self->_delete_part( $part );

# Now we add
    $self->add_part_before( $before_part, $part );
}

sub move_part_after {
# --------------------------------------------------------------------------
# Move a part after another part. The first argument is the part to move 
# after, the second is the part to move. No moving the top level part.
#
    my ( $self, $after_part, $part ) = @_;
    die "Can't move part after the top part" if $after_part == $self->{root_part};
    die "Can't move top part" if $part == $self->{root_part};
    if ( !$self->_part_in_message( $after_part ) or !$self->_part_in_message( $part ) ) {
        die "All parts specified must be in the MIME message";
    }

# First remove the part
    $self->_delete_part( $part );

# Now we add
    $self->add_part_after( $after_part, $part );
}

sub move_part_end {
# --------------------------------------------------------------------------
# Move a part to the end of a multipart part. The first part is the
# multipart part to move it to the end of. The second argument is the part 
# to move. No moving the top level part.
#
    my ( $self, $parent_part, $part ) = @_;
    die "Can't move top part" if $part == $self->{root_part};
    if ( !$self->_part_in_message( $parent_part ) or !$self->_part_in_message( $part ) ) {
        die "All parts specified must be in the MIME message";
    }

# First remove the part to be moved
    $self->_delete_part( $part );

# Then we add it back in
    $self->add_part_end( $parent_part, $part );
}

sub move_part_beginning {
# --------------------------------------------------------------------------
# Move a part to the beginning of a multipart part. The first part is the
# multipart part to move it to the beginning of. The second argument is the
# part to move. No moving the top level part.
#
    my ( $self, $parent_part, $part ) = @_;
    die "Can't move top part" if $part == $self->{root_part};
    if ( !$self->_part_in_message( $parent_part ) or !$self->_part_in_message( $part ) ) {
        die "All parts specified must be in the MIME message";
    }

# First remove the part to be moved
    $self->_delete_part( $part );

# Then we add it back in
    $self->add_part_beginning( $parent_part, $part );
}

sub replace_part {
# --------------------------------------------------------------------------
# Replace a part with another part
#
    my ( $self, $old_part, $new_part ) = @_;
    $self->_link;
    splice( @{$self->{parts}}, $old_part->{id}, 1, $new_part );
    $self->_link;
}

sub add_part_before {
# --------------------------------------------------------------------------
# Adds a part before the given part. The first argument is the part object
# to add the part before. the second argument is the part to add.
#
    my ( $self, $before_part, $part ) = @_;
    $self->_link;
    die "Can't add part before the top level part" if $before_part == $self->{root_part};
    my $parent_id = $before_part->{parent_id};

    if ( !defined $parent_id or !$self->{parts}[$parent_id]->is_multipart ) {
        die "The part's parent must exist and must be a multipart";
    }
    splice( @{$self->{parts}}, $before_part->{id}, 0, $part );
    my $parent_part = $self->{parts}[$parent_id];
    $parent_part->add_parts_before( $before_part->{id}, $part );
    $self->_link;
}

sub add_part_after {
# --------------------------------------------------------------------------
# Adds a part after the given part. The first argument is the part object
# to add the part after. the second argument is the part to add.
#
    my ( $self, $after_part, $part ) = @_;
    $self->_link;
    die "Can't add part after the top level part" if $after_part == $self->{root_part};
    my $parent_id = $after_part->{parent_id};
    
    if ( !defined $parent_id or !$self->{parts}[$parent_id]->is_multipart ) {
        die "The part's parent must exist and must be a multipart";
    }
    splice( @{$self->{parts}}, $after_part->{id} + 1, 0, $part );
    my $parent_part = $self->{parts}[$parent_id];
    $parent_part->add_parts_after( $after_part->{id}, $part );
    $self->_link;
}

sub add_part_beginning {
# --------------------------------------------------------------------------
# Adds a part at the beginning of the given multipart part. The first
# argument is the part object to add the part before. the second argument is
# the part to add.
#
    my ( $self, $parent_part, $part ) = @_;
    $self->_link;
    my $parent_id = $parent_part->{id};
    
    if ( !$self->{parts}[$parent_id]->is_multipart ) {
        die "The parent part must be a multipart";
    }
    splice( @{$self->{parts}}, $parent_id + 1, 0, $part );
    $parent_part->add_part_before( $part->{parts}[0]{id}, $part );
    $self->_link;
}

sub add_part_end {
# --------------------------------------------------------------------------
# Adds a part at the end of the given multipart part. The first argument is
# the part object to add the part at the end of. the second argument is the
# part to add. The first argument must be a multipart part or a fatal error
# occurs.
#
    my ( $self, $parent_part, $part ) = @_;
    $self->_link;
    my $parent_id = $parent_part->{id};
    
    if ( !$self->{parts}[$parent_id]->is_multipart ) {
        die "The parent part must be a multipart";
    }
    splice( @{$self->{parts}}, $parent_id + @parts, 0, $part );
    $parent_part->parts( $part );
    $self->_link;
}

sub move_part_to_position {
# --------------------------------------------------------------------------
# Move a part to a position within another multipart part. The first
# argument is the part to move within, the second argument is the part to
# move and the final argument is the position within those parts to move it
# in.
#
    my ( $self, $parent_part, $part, $pos ) = @_;
    die "Can't move top part" if $part == $self->{root_part};
    if ( !$self->_part_in_message( $parent_part ) or !$self->_part_in_message( $part ) ) {
        die "All parts specified must be in the MIME message";
    }
    $self->_link;
    my $parent_id = $parent_part->{id};
    
    if ( !$self->{parts}[$parent_id]->is_multipart ) {
        die "The parent part must be a multipart";
    }
    splice( @{$self->{parts}}, $parent_id + $pos, $part );
    $self->_link;
}

sub get_part_by_id {
# --------------------------------------------------------------------------
# Method to retrieve a part object by it's id
#
    my ( $self, $id ) = @_;

    return $self->{parts}[$id];
}

sub new_part {
# --------------------------------------------------------------------------
# Method to easily create a part object. All the header fields can be passed
# in as a hash. If the key "body_data" the value will be set as the parts
# body rather than a header field.
#
    my ( $self, @opts ) = @_;
    my $part = new GT::Mail::Parts;
    while ( my ( $key, $val ) = ( shift( @opts ), shift( @opts ) ) ) {
        if ( $key eq 'body_data' ) {
            $part->body_data( $val );
        }
        elsif ( $key eq 'body_handle' ) {
            $part->body_handle( $val );
        }
        elsif ( $key eq 'body_path' ) {
            $part->body_path( $val );
        }
        else {
            $part->set( $key => $val );
        }
    }
    return $part;
}

sub all_parts {
# --------------------------------------------------------------------------
# my @parts = $obj->all_parts;
# ----------------------------
#   Returns a list of all the part object for the current parsed email.
#   If the email is not multipart this will be just the header part.
#
    return @{shift()->{parts}}
}

sub size {
# --------------------------------------------------------------------------
# Returns the total size of an email. Call this method after the email has 
# been parsed.
#
    my $self = shift;
    (@{$self->{parts}} > 0) or return;
    my $size = 0;
    foreach (@{$self->{parts}}) {
        $size += $_->size;
    }
    return $size;
}

sub as_string {
# --------------------------------------------------------------------------
# Returns the entire email as a sting.
#
    my ( $self ) = @_;
    $GT::Mail::Encoder::CRLF = $CRLF;

    my $out;
    $$out = ' ' x 50*1024;
    $self->debug ("\n\t--------------> Creating email") if $self->{_debug};

# Need the head to contiue
    $self->{root_part} or die "No root part!";
    $self->{root_part}->set( 'MIME-Version' => '1.0' ) unless $self->{root_part}->get( 'MIME-Version' );

    my $bound = $self->{root_part}->multipart_boundary;

# If the message has parts

    if ( @{$self->{root_part}->{parts}} > 0 ) {
        $self->debug( "Creating multipart email." ) if $self->{_debug};
        $self->_build_multipart_head( $out );
    }

# Else we are single part and have either a body IO handle or the body is in memory
    else {
        $self->debug( "Creating singlepart email." ) if $self->{_debug};
        $self->_build_singlepart_head( $out );
    }

# If we have parts go through all of them and add them.
    if ( @{$self->{root_part}->{parts}} > 0 ) {
        my $num_parts = $#{$self->{root_part}->{parts}};
        for my $num ( 0 .. $num_parts ) {
            next unless $self->{root_part}->{parts}->[$num];
            $self->debug( "Creating part ($num)." ) if $self->{_debug};
            $self->_build_parts( $out, $self->{root_part}->{parts}->[$num] );
            if ( $num_parts == $num ) {
                $self->debug( "Boundary\n\t--$bound--" ) if $self->{_debug};
                $$out .= $CRLF . '--' . $bound . '--' . $CRLF;
            }
            else {
                $self->debug( "Boundary\n\t--$bound" ) if $self->{_debug};
                $$out .= $CRLF . '--' . $bound . $CRLF;
            }
        }
    }

# Add the epilogue if we are multipart
    if ( @{$self->{root_part}->{parts}} > 0 ) {
        my $epilogue = join( '', @{$self->{root_part}->epilogue || []} ) || '';
        $epilogue =~ s/\015?\012//g;
        $self->debug( "Setting epilogue to ($epilogue)" ) if $self->{_debug};
        $$out .= $epilogue . $CRLF . $CRLF if $epilogue;
    }
    $self->debug( "\n\t<-------------- Email created." ) if $self->{_debug};
    return $$out;
}

sub _build_multipart_head {
# --------------------------------------------------------------------------
# Private method to build a multipart header.
#
    my ( $self, $out ) = @_;
    my $bound = $self->{root_part}->multipart_boundary;
    my $encoding = $self->{root_part}->suggest_encoding;
    $self->debug( "Setting encoding to ($encoding)." ) if ( $self->{debug} );
    $self->{root_part}->set( 'Content-Transfer-Encoding' => $encoding );
    $bound or $bound = "---------=_" . scalar (time) . "-$$-" . int(rand(time)/2);

# Set the content boundary unless it has already been set
    my $c = $self->{root_part}->get( 'Content-Type' );
    if ( $c !~ /\Q$bound/i ) {
        if ( $c and lc( $c ) !~ /boundary=/ ) {
            $c =~ /multipart/ or $c = 'multipart/mixed';
            $self->debug( qq|Setting content type to ($c; boundary="$bound")| ) if $self->{debug};
            $self->{root_part}->set( 'Content-Type' => $c . qq|; boundary="$bound"| );
        }
        else {
            $self->debug( "Setting multipart boundary to ($bound)." ) if $self->{_debug};
            $self->{root_part}->set( 'Content-Type' =>  qq!multipart/mixed; boundary="$bound"! ) 
        }
    }

    my $preamble = join( '', @{$self->{root_part}->preamble || []} ) || "This is a multi-part message in MIME format.";
    $preamble =~ s/\015?\012//g;
    $self->debug( "Setting preamble to ($preamble)." ) if ( $self->{_debug} );
    ( my $head = $self->{root_part}->header_as_string ) =~ s/\015?\012/$CRLF/g;
    $self->debug( "Boundary\n\t--$bound" ) if $self->{_debug};
    $$out .= $head . $CRLF . $preamble . $CRLF  . $CRLF . '--' . $bound . $CRLF;
    return 1;
}

sub _build_singlepart_head {
# --------------------------------------------------------------------------
# Private method to build a single part header.
#
    my ( $self, $out ) = @_;
    my $encoding = $self->{root_part}->suggest_encoding;
    $self->debug( "Setting encoding to ($encoding)." ) if $self->{_debug};
    $self->{root_part}->set( 'Content-Transfer-Encoding' => $encoding );
    ( my $head = $self->{root_part}->header_as_string ) =~ s/\015?\012/$CRLF/g;
    $$out .= $head . $CRLF;
    $self->debug( "Encoding body with ($encoding)." ) if $self->{_debug};
    GT::Mail::Encoder->gt_encode (
        debug    => $self->{_debug},
        encoding => $encoding,
        in       => $self->{root_part}->body_as_string,
        out      => $out
    ) or return;

# Must seek to the beginning for additional calles
    return 1;
}

sub _build_parts {
# --------------------------------------------------------------------------
# Private method that builds the parts for the email.
#
    my ($self, $out, $part) = @_;

# Need the head to contiue
    $self->{root_part} or die "No root part!";

    my ( $body, $encoding, $bound );
    $bound = $part->multipart_boundary;


# Find the encoding for the part and set it.
    $encoding = $part->suggest_encoding;
    $self->debug( "Setting encoding to ($encoding)." ) if $self->{_debug};
    $part->set( 'Content-Transfer-Encoding' => $encoding );

# If the message has parts and has a multipart boundary
    if ( @{$part->{parts}} > 0 and $bound ) {
        $self->debug( "Part is multpart." ) if $self->{_debug};

# Set the multipart boundary
        $self->debug( "Setting boundary to ($bound)." ) if $self->{_debug};

# Set the content boundary unless it has already been set
        my $c = $part->get( 'Content-Type' );
        if ( $c ) {
            $self->debug( qq|Setting content type to ($c; boundary="$bound")| ) if $self->{_debug};
            $part->set( 'Content-Type' => $c . qq|; boundary="$bound"| );
        }
        else {
            $self->debug( "Setting multipart boundary to ($bound)." ) if $self->{_debug};
            $part->set( 'Content-Type' =>  qq!multipart/mixed; boundary="$bound"! );
        }
        
        my $preamble = join( '' => @{ $part->preamble || [] } ) || "This is a multi-part message in MIME format.";
        $preamble =~ s/\015?\012//g;
        $self->debug( "Setting preamble to ($preamble)." ) if $self->{_debug};
        ( my $head = $part->header_as_string ) =~ s/\015?\012/$CRLF/g;
        $self->debug( "Boundary\n\t--$bound" ) if $self->{_debug};
        $$out .= $head . $CRLF . $preamble  . $CRLF . '--' . $bound . $CRLF;
    }
    else {
        $self->debug( "Part is single part." ) if $self->{_debug};
        ( my $head = $part->header_as_string ) =~ s/\015?\012/$CRLF/g;
        $$out .= $head . $CRLF;

# Set the body only if we have one. We would not have one on the head an multipart
        $self->debug( "Encoding body with ($encoding)." ) if $self->{_debug};
        GT::Mail::Encoder->gt_encode(
            encoding => $encoding,
            debug    => $self->{_debug},
            in       => $part->body_as_string,
            out      => $out
        ) or return;

    }

# Add the rest of the parts
    if ( @{$part->{parts}} > 0 ) {
        $self->debug( "Part has parts." ) if $self->{_debug};
        my $num_parts = $#{$part->{parts}};
        for my $num ( 0 .. $num_parts ) {
            next unless $part->{parts}->[$num];
            $self->debug( "Creating part ($num)." ) if $self->{_debug};
            $self->_build_parts( $out, $part->{parts}->[$num] ) or return;
            if ( $bound ) {
                if ( $num_parts == $num ) {
                    $self->debug( "Boundary\n\t--$bound--" ) if $self->{_debug};
                    $$out .= $CRLF . '--' . $bound . '--' . $CRLF;
                }
                else {
                    $self->debug( "Boundary\n\t--$bound" ) if $self->{_debug};
                    $$out .= $CRLF . '--' . $bound . $CRLF;
                }
            }
        }
    }

# Maybe done!
    return 1;
}

sub _delete_part {
# --------------------------------------------------------------------------
# Internal method to delete a part
    my ( $self, $part ) = @_;

# We must remove it from it's parent
    my $parent = $self->{parts}[$part->{parent_id}];
    for ( 0 .. $#{$parent->{parts}} ) {
        if ( $parent->{parts}[$_]{id} == $part->{id} ) {
            splice( @{$parent->{parts}}, $_, 1 );
            last;
        }
    }

# We must remove it from the flat list of parts
    return splice( @{$self->{parts}}, $part->{id}, 1 );
}

sub _part_in_message {
# --------------------------------------------------------------------------
# Internal method to find out weather a part is in the current message
    my ( $self, $part ) = @_;
    for ( @{$self->{parts}} ) {
        return 1 if $_ == $part;
    }
    return;
}

sub _link {
# --------------------------------------------------------------------------
# Creats part ids and links the children to the parrents. Called
# When parts arer modified
#
    my ( $self ) = @_;

# Creates ids to keep track of parts with.
    for ( 0 .. $#{$self->{parts}} ) {
        $self->{parts}[$_]{id} = $_;
    }
    _link_ids( $self->{root_part} );
}

sub _links_ids {
# --------------------------------------------------------------------------
# Internal function to link all children to their parents with the parent id.
# RECURSIVE
#
    my ( $part, $parent_id ) = @_;
    for ( @{$part->{parts}} ) {
        _link_ids( $_, $part->{id} );
    }
    $part->{parent_id} = $parent_id;
}

sub _get_parts {
# --------------------------------------------------------------------------
# Recursive function to get a flat list of all the parts in a part structure
#
    my ( $part, $parts ) = @_;
    $parts ||= [];

    for ( @{$part->{parts}} ) {
        push @$parts, @{_get_parts( $_, $parts )};
    }
    return $parts;
}

1;

__END__

=head1 NAME

GT::Mail::Message - Encapsolates an email message.

=head1 SYNOPSIS

    use GT::Mail::Message;
 
    # Get a GT::Mail::Message object from the parser
    use GT::Mail::Parse;

    my $parser = new GT::Mail::Parse( in_file => "myemail.eml" );
    my $message = $parser->parse;

    # Get the top level part
    my $root_part = $message->root_part;

    # Replace the first part with a new part
    $message->replace_part( $root_part, $message->new_part(
        to => 'scott@gossamer-threads.com',
        from => 'alex@gossamer-threads.com',
        'content-type' => 'text/plain',
        body_data => 'Hi Scott, how are you?!'
    );

    # Add a part at the end
    my $end_part = $message->new_part(
        'content-type' => 'image/gif',
        body_path      => 'myimage.jpg'
    );
    $message->add_part_end( $root_part, $end_part );

    # Move the first part in the top part to after the end part
    $message->move_part_after( $root_part->parts->[0], $end_part );

    # Print the mime message
    print $message->to_string;

=head1 DESCRIPTION

GT::Mail::Message encapsolates a mime message which consists of 
L<GT::Mail::Parts> object. This module provides methods to change,
move, remove, and access these parts.

=head2 Creating a new GT::Mail::Message object

Usually you will get a GT::Mail::Message object by call the parse method
in L<GT::Mail::Parse>.

    my $message = $parser->parse;

You may also call new on this class specifying the top level part and or
a debug level.

    my $message = new GT::Mail::Message(
        root_part => $part,
        debug    => 1
    );

=head2 Creating a new Part

You can create a part by calling new on L<GT::Mail::Parts> directly

    my $part = new GT::Mail::Parts;
    $part->set( 'content-type' => 'image/gif' );
    $part->body_path( 'myimage.gif' );

or you can call a method in this module to get a new part

    my $part = $message->new_part(
        'content-type' => 'image/gif',
        body_path      => 'myimage.gif'
    );

This method is a wraper on a combination of new() and some other
supporting methods in L<GT::Mail::Parts> such as body_path(). Anything
that is not B<body_path>, B<body_data>, or B<body_handle> is treated
as header values.

=head2 Manipulating Parts

A MIME message is just a format for storing a tree structure. We provide
tree-like methods to manipulate parts. All the method for manipulating
parts take the part object(s) as arguments. We do this so you do not need
to know how the tree is tracked internally.

=head2 Accessing Parts


More to come!

=head1 COPYRIGHT

Copyright (c) 2004 Gossamer Threads Inc.  All Rights Reserved.
http://www.gossamer-threads.com/

=head1 VERSION

Revision: $Id: Message.pm,v 1.14 2004/01/13 01:35:17 jagerman Exp $

        

