view release on metacpan or  search on metacpan

lib/Email/Outlook/Message.pm  view on Meta::CPAN

$VERSION = "0.921";

use Email::Simple;
use Email::MIME::Creator;
use Email::Outlook::Message::AddressInfo;
use Email::Outlook::Message::Attachment;
use Carp;
use base 'Email::Outlook::Message::Base';

our $skipheaders = {
  map { uc($_) => 1 }
  "MIME-Version",
  "Content-Type",
  "Content-Transfer-Encoding",
  "X-Mailer",
  "X-Msgconvert",
  "X-MS-Tnef-Correlator",
  "X-MS-Has-Attach"
};

our $MAP_SUBITEM_FILE = {
  '1000' => "BODY_PLAIN",      # Body
  '1009' => "BODY_RTF",        # Compressed-RTF version of body
  '1013' => "BODY_HTML",       # HTML Version of body
  '0037' => "SUBJECT",         # Subject
  '0047' => "SUBMISSION_ID",   # Seems to contain the date
  '007D' => "HEAD",            # Full headers
  '0C1A' => "FROM",            # From: Name
  '0C1E' => "FROM_ADDR_TYPE",  # From: Address type
  '0C1F' => "FROM_ADDR",       # From: Address
  '0E04' => "TO",              # To: Names
  '0E03' => "CC",              # Cc: Names
  '1035' => "MESSAGEID",       # Message-Id
  '1039' => "REFERENCES",      # References: Header
  '1042' => "INREPLYTO",       # In reply to Message-Id
  '3007' => 'DATE2ND',         # Creation Time
  '0039' => 'DATE1ST',         # Outlook sent date
  '3FDE' => 'CODEPAGE',        # Code page for text or html body
};

# Map codepage numbers to charset names.  Codepages not listed here just get
# 'CP' prepended, so 1252 -> 'CP1252'.
our $MAP_CODEPAGE = {
  20127 => 'US-ASCII',
  20866 => 'KOI8-R',
  28591 => 'ISO-8859-1',
  65001 => 'UTF-8',
};

#
# Main body of module
#

sub new {
  my $class = shift;
  my $file = shift or croak "File name is required parameter";
  my $verbose = shift;

  my $self = $class->_empty_new;

  $self->{EMBEDDED} = 0;

  my $msg = OLE::Storage_Lite->new($file);
  my $pps = $msg->getPpsTree(1);
  $pps or croak "Parsing $file as OLE file failed";
  $self->_set_verbosity($verbose);
  # TODO: Use separate object as parser?
  $self->_process_pps($pps);

  return $self;
}

sub _empty_new {
  my $class = shift;

  return bless {
    ADDRESSES => [], ATTACHMENTS => [], FROM_ADDR_TYPE => "",
    VERBOSE => 0, EMBEDDED => 1
  }, $class;
}

sub to_email_mime {
  my $self = shift;

  my $bodymime;
  my $mime;

  my @parts;

  if ($self->{BODY_PLAIN}) { push(@parts, $self->_create_mime_plain_body()); }
  if ($self->{BODY_HTML}) { push(@parts, $self->_create_mime_html_body()); }
  if ($self->{BODY_RTF}) { push(@parts, $self->_create_mime_rtf_body()); }

  if ((scalar @parts) > 1) {
    for (@parts) { $self->_clean_part_header($_) };

    $bodymime = Email::MIME->create(
      attributes => {
        content_type => "multipart/alternative",
        encoding => "8bit",
      },
      parts => \@parts
    );
  } elsif ((@parts) == 1) {
    $bodymime = $parts[0];
  } else {
    $bodymime = $self->_create_mime_plain_body();
  }

  if (@{$self->{ATTACHMENTS}}>0) {
    $self->_clean_part_header($bodymime);
    my $mult = Email::MIME->create(
      attributes => {
        content_type => "multipart/mixed",
        encoding => "8bit",
      },
      parts => [$bodymime],
    );
    foreach my $att (@{$self->{ATTACHMENTS}}) {
      $self->_SaveAttachment($mult, $att);
    }
    $mime = $mult;
  } else {
    $mime = $bodymime;
  }

  #$mime->header_set('Date', undef);
  $self->_SetHeaderFields($mime);
  $self->_copy_header_data($mime);

  return $mime;
}

#
# Below are functions that walk the PPS tree. This is simply a tree walk.
# It's not really recursive (except when an attachment contains a .msg
# file), since the tree is shallow (max. 1 subdirectory deep).
#

lib/Email/Outlook/Message.pm  view on Meta::CPAN

#   Dirs containing Attachments
#     Items with properties of the attachment (including its data)
#     Dir that is itself a .msg file (if the attachment is an email).
#

sub _property_map {
  return $MAP_SUBITEM_FILE;
}

#
# Process a subdirectory. This is either an address or an attachment.
#
sub _process_subdirectory {
  my ($self, $pps) = @_;

  $self->_extract_ole_date($pps);

  my $name = $self->_get_pps_name($pps);

  if ($name =~ '__recip_version1 0_ ') { # Address of one recipient
    $self->_process_address($pps);
  } elsif ($name =~ '__attach_version1 0_ ') { # Attachment
    $self->_process_attachment($pps);
  } else {
    $self->_warn_about_unknown_directory($pps);
  }
  return;
}

#
# Process a subdirectory that contains an email address.
#
sub _process_address {
  my ($self, $pps) = @_;

  my $addr_info = Email::Outlook::Message::AddressInfo->new($pps,
    $self->{VERBOSE});

  push @{$self->{ADDRESSES}}, $addr_info;
  return;
}

#
# Process a subdirectory that contains an attachment.
#
sub _process_attachment {
  my ($self, $pps) = @_;

  my $attachment = Email::Outlook::Message::Attachment->new($pps,
    $self->{VERBOSE});
  push @{$self->{ATTACHMENTS}}, $attachment;
  return;
}

#
# Header length of the property stream depends on whether the Message
# object is embedded or not.
#
sub _property_stream_header_length {
  my $self = shift;
  return ($self->{EMBEDDED} ?  24 : 32)
}

#
# Helper functions
#

#
# Extract time stamp of this OLE item (this is in GMT)
#
sub _extract_ole_date {
  my ($self, $pps) = @_;
  unless (defined ($self->{OLEDATE})) {
    # Make Date
    my $datearr;
    $datearr = $pps->{Time2nd};
    $datearr = $pps->{Time1st} unless $datearr and $datearr->[0];
    $self->{OLEDATE} = $self->_format_date($datearr) if $datearr and $datearr->[0];
  }
  return;
}

# If we didn't get the date from the original header data, we may be able
# to get it from the SUBMISSION_ID:
# It seems to have the format of a semicolon-separated list of key=value
# pairs. The key l has a value with the format:
# <SERVER>-<DATETIME>Z-<NUMBER>, where DATETIME is the date and time (gmt)
# in the format YYMMDDHHMMSS.
sub _submission_id_date {
  my $self = shift;

  my $submission_id = $self->{SUBMISSION_ID} or return;
  $submission_id =~ m/ l=.*- (\d\d) (\d\d) (\d\d) (\d\d) (\d\d) (\d\d) Z-.* /x
    or return;
  my $year = $1;
  $year += 100 if $year < 20;
  return $self->_format_date([$6,$5,$4,$3,$2-1,$year]);
}

sub _SaveAttachment {
  my ($self, $mime, $att) = @_;

  my $m = $att->to_email_mime;
  $self->_clean_part_header($m);
  $mime->parts_add([$m]);
  return;
}

# Set header fields
sub _AddHeaderField {
  my ($self, $mime, $fieldname, $value) = @_;

  #my $oldvalue = $mime->header($fieldname);
  #return if $oldvalue;
  $mime->header_set($fieldname, $value) if $value;
  return;
}

sub _Address {
  my ($self, $tag) = @_;