package Mail::Outlook::Message;

use warnings;
use strict;

use vars qw($VERSION $AUTOLOAD);
$VERSION = '0.15';

#----------------------------------------------------------------------------

=head1 NAME

Mail::Outlook::Message - extension to handle Microsoft (R) Outlook (R) mail messages.

=head1 SYNOPSIS

See Mail::Outlook, as this is not meant to be used as a standalone module.

=head1 DESCRIPTION

Handles the Message interaction with the Outlook API.

=cut

#----------------------------------------------------------------------------

#############################################################################
#Library Modules                                                            #
#############################################################################

use File::Basename;
use Win32::OLE;
use Win32::OLE::Const 'Microsoft Outlook';

#############################################################################
#Variables
#############################################################################

my @autosubs = qw(To Cc Bcc Subject Body SenderName);
my %autosubs = map {$_ => 1} @autosubs;

#----------------------------------------------------------------------------

#############################################################################
#Interface Functions                                                        #
#############################################################################

=head1 METHODS

=over 4

=item new()

Create a new Outlook mail object. Returns the object on success or undef on
failure. To see the last error use 'Win32::OLE->LastError();'.

Note that when displaying or sending a message, you MUST have completed the
following fields:

  To
  Subject
  Body

While the RFCs may let you send blank messages, it seems a rather pointless
idea to me, and probably not what you intended. If you want to ignore this
restriction, feel free to edit your copy of the source code and comment out
or edit the appropriate line in _make_message().

=cut

sub new {
    my ($self, $outlook, $message) = @_;

    # create an attributes hash
    my $atts = {
        'outlook'   => $outlook,
        'message'   => $message || undef,
        'readonly'  => 1,
    };

    # create the object
    bless $atts, $self;
    return $atts;
}

sub DESTROY {}

=item create(%hash)

Creates a new message. Option hash table can be used.

=cut

sub create {
    my ($self,%hash) = @_;

    # Create a new message object
    $self->{message} = $self->{outlook}->CreateItem(olMailItem)
        or return undef;
    $self->{readonly} = 0;

    # pre-populate the fields
    foreach my $field (@autosubs) { $self->{$field} = $hash{$field} || ''; }

    return $self->{message};
}

=item display()

Creates a pre-populated New Message via Outlook. Returns 1 on success, 0 on failure.

=cut

sub display {
    my $self = shift;

    return 0    unless($self->_make_message(@_));

    # Display the email
    $self->{message}->Display();

    return 1;
}

=item send()

Sends the message. Returns 1 on success, 0 on failure.

=cut

sub send {
    my $self = shift;

    return 0    unless($self->_make_message(@_));

    eval {
        # Send the email
        $self->{message}->Send();
    };

    # check whether user cancelled send or it failed
    return 2    if($@ =~ /Operation aborted/);
    return 0    if($@);

    return 1;
}

=item save()

Excerpt from the MSDN:

"Saves the Outlook  to the current folder or, if this is a new item, to the
Outlook default folder for the item type."

In other words, if the message is a new one, it will be saved to the default
folder (B<Drafts>) in Outlook.

Returns 1 on success, 0 on failure.

=cut

sub save {
    my $self = shift;

    return 0 unless ( $self->_make_message(@_) );

    eval {
        $self->{message}->Save();
    };

    my $err = Win32::OLE::LastError();

    if($@ or $err) {
        warn "error $@\n" if ( defined($@) );
        warn Win32::OLE::LastError() . "\n" if ($err);
        return 0;
    }

    return 1;
}

=item delete_message()

Remove this message.

=cut

sub delete_message {
    my $self = shift;

    $self->{message}->Delete();
    $self = undef;
}

# -------------------------------------
# The Get & Set Methods Interface Subs

=back

=head2 Accessor Methods

=over 4

=item Basic Accessor Methods

The following basic accessor methods are available:

  SenderName
  To
  Cc
  Bcc
  Subject
  Body

All functions can be called to return the current value of the associated
object variable, or be called with a parameter to set a new value for the
object variable if you are creating a message.

=cut

sub AUTOLOAD {
    no strict;
    my $name = $AUTOLOAD;
    $name =~ s/^.*:://;
    die "Unknown sub $AUTOLOAD\n"   unless($autosubs{$name});

    *$name = sub {
        my ($self,$value) = @_;

        if($self->{readonly}) {     # existing message
            local $^W = 0;
            return $self->{message}->$name();
        }

        @_==2 ? $self->{$name} = $value : $self->{$name};
    };
    goto &$name;
}

=item From()

Returns the current settings for the read only From field. Note that this is
not an email address when used in connection with a new message. Returns a
list containing the Name and Address of the user.

=cut

sub From {
    my $self = shift;

    if($self->{readonly}) { # existing message
        my $name;
        eval {$name = $self->{message}->SenderName()};
        return $name;   # note this will be undef if we have been declined access

    } else {                # new message
        my $user = $self->{message}->UserProperties;
        return  $user->{'Session'}->{'CurrentUser'}->{'Name'},
                $user->{'Session'}->{'CurrentUser'}->{'Address'};
    }
}

=item Sent()

Returns the date/time the current message was sent. Note that this will
return undef if the message has not been sent!

=cut

sub Sent {
    my $self = shift;

    return  unless($self->{readonly});  # existing messages only!

    my $dt;
    eval {$dt = $self->{message}->SentOn()->Date() . ' ' . $self->{message}->SentOn()->Time()};
    return $dt;   # note this will be undef if we have been declined access
}

=item Received()

Returns the date/time the current message was received. Note that this will
return undef if the message has not been sent!

=cut

sub Received {
    my $self = shift;

    return  unless($self->{readonly});  # existing messages only!

    my $dt;
    eval {$dt = $self->{message}->ReceivedTime()->Date() . ' ' . $self->{message}->ReceivedTime()->Time()};
    return $dt;   # note this will be undef if we have been declined access
}

=item XHeader($xheader,$value)

Adds a header in the style of 'X-Header' to the headers of the message.
Returns undef if header cannot be added.

NOTE: Currently unimplemented, due to unreliable treatment by Exchange server.

=cut

sub XHeader {
    return undef;

#   my ($self,$xheader,$value) = @_;
#   return undef    unless($xheader =~ /^X-(.*)/);

#   my $header = $1;

    # "That GUID (funky number between the curly braces) is the correct one
    # for generating X-Headers." - Thomas J. Zamberlan on a Yahoo tech group

#   my $user = $self->{msg}->UserProperties;
#   my $intXHeader = $self->{outlook}->GetIDsFromNames(
#           $self->{namespace},
#           "{00020386-0000-0000-C000-000000000046}",
#           $xheader, 1);

#   $self->{outlook}->HrSetOneProp(
#           $self->{namespace},
#           $intXHeader,
#           $value,
#           1);
#   $self->{XHeaders}->{$xheader} = $value;
}

=item Attach(@attachments)

Add attachments when creating a message. Returns the attachments of the message
if no arguments are passed to the method.

=cut

sub Attach {
    my $self = shift;

    if($self->{readonly}) {     # existing message
        local $^W = 0;
        if($self->_ole_exists('Attachments')) {
            $self->{attachment} = $self->{message}->Attachments;
            return $self->{attachment};
        }
        return undef;
    }

    if(@_) {
        push @{$self->{Attach}}, {file => $_, name => basename($_), attached => 0}  for(@_);
    }


    return map {$_->{file}} @{$self->{Attach}};
}

# -------------------------------------
# Internal Subs

sub _ole_exists {
    my ($self,$name) = @_;
    local $^W = 0;
    my $stat = eval { my $value = $self->{message}->{$name} };
    ($stat || $@) ? 0 : 1;
}

sub _make_message {
    my ($self,%hash) = @_;

    # pre-populate the fields, if hash
    foreach my $field (@autosubs) {
        $self->{$field} = $hash{$field} if($hash{$field});
    }

    # we need the basic message fields
    return 0    unless($self->{To} && $self->{Subject} && $self->{Body});

    # Build the message
    $self->{message}->{To}      = $self->{To};
    $self->{message}->{Cc}      = $self->{Cc}   if($self->{Cc});
    $self->{message}->{Bcc}     = $self->{Bcc}  if($self->{Bcc});
    $self->{message}->{Subject} = $self->{Subject};
    $self->{message}->{Body}    = $self->{Body};

    if ($self->{Attach}) {
        $self->{attachment} = $self->{message}->Attachments;
        for my $attach (@{$self->{Attach}}) {
            next    if($attach->{attached});
            $self->{attachment}->Add($attach->{file},olByValue,10000,$attach->{name});
            $attach->{attached} = 1;
        }
    }

    return 1;
}

1;

__END__

#----------------------------------------------------------------------------

=back

=head1 CAVEATS

Due to some recent security patches within Outlook, Microsoft have disabled
the automatic access to the Outlook OLE. As some spam and trojan scripts, as
well as the usual executables, have been using the application for malicious
uses, Microsoft have stepped in an attempt to block this. If these security
patches have been applied, when the module accesses Outlook via the OLE, you
will probably see one of the following messages, or something like them.

=over 4

=item Security Message 1

When the module attempts to retrieve the From address, a warning message box
may appear. The text will be along the lines of:


  A program is trying to access e-mail addresses you have
  stored in Outlook. Do you want to allow this?

  If this is unexpected, it may be a virus and you should
  choose "No".

  [ ] Allow access for [ --------- V]

  [Yes]  [No]  [Help]


The message informs you that an unknown application is accessing Outlook and
asks whether you wish to allow this. Click 'Yes' to allow the script to access
the Outlook Address Book. Or you can set a time period, during which the script
can access the Outlook OLE.

=item Security Message 2

On sending the message, you may also activate another warning message box.
The text will be along the lines of:


  A program is trying to automatically send e-mail on
  your behalf.
  Do you want to allow this?

  If this is unexpected, it may be a virus and you should
  choose "No".

  [Yes]  [No]  [Help]


Click 'Yes' to allow the script to automatically send the message via Outlook.

=back

=head1 FURTHER READING

If you intend to supply a patch for a bug or new feature, please visit the
following URL (and associated pages) to ensure you are using the correct
objects and methods.

http://msdn.microsoft.com/library/default.asp?url=/library/en-us/off2000/html/olobjApplication.asp

This article contains some interesting background into creating mail
messages via Outlook, although it is VB-centric.

http://www.exchangeadmin.com/Articles/Index.cfm?ArticleID=4657

=head1 FUTURE ENHANCEMENTS

A couple of items that I'd like to get working.

* X-Header support
* Send without the popups (Outlook Redemption looks possible)

=head1 NOTES

This module is intended to be used on Win32 platforms only, with Microsoft (R)
Outlook (R) installed.

  Microsoft and Outlook are registered trademarks and the copyright 1995-2003
  of Microsoft Corporation.

=head1 SEE ALSO

  Win32::OLE
  Win32::OLE::Const

=head1 DSLIP

  b - Beta testing
  d - Developer
  p - Perl-only
  O - Object oriented
  p - Standard-Perl: user may choose between GPL and Artistic

=head1 BUGS, PATCHES & FIXES

There are no known bugs at the time of this release. However, if you spot a
bug or are experiencing difficulties that are not explained within the POD
documentation, please submit a bug to the RT system (see link below). However,
it would help greatly if you are able to pinpoint problems or even supply a
patch.

Fixes are dependant upon their severity and my availablity. Should a fix not
be forthcoming, please feel free to (politely) remind me by sending an email
to barbie@cpan.org .

RT: L<http://rt.cpan.org/Public/Dist/Display.html?Name=Mail-Outlook>

=head1 AUTHOR

  Barbie, <barbie@cpan.org>
  for Miss Barbell Productions, <http://www.missbarbell.co.uk>

=head1 COPYRIGHT AND LICENSE

  Copyright © 2003-2007 Barbie for Miss Barbell Productions.

  This library is free software; you can redistribute it and/or modify it under
  the same terms as Perl itself, using the Artistic License.

The full text of the licenses can be found in the Artistic file included with
this distribution, or in perlartistic file as part of Perl installation, in
the 5.8.1 release or later.

=cut