view release on metacpan or  search on metacpan

lib/Data/JSEmail.pm  view on Meta::CPAN

    sentAt => asDate($eml->header('Date')),
    messageId => asMessageIds($eml->header('Message-Id')),
    references => asMessageIds($eml->header('References')),
    inReplyTo => asMessageIds($eml->header('In-Reply-To')),
    preview => $preview,
    hasAttachment => $hasAtt ? $JSON::true : $JSON::false,
    headers => $headers,
    bodyStructure => $bodystructure,
    bodyValues => \%values,
    textBody => $textBody,
    htmlBody => $htmlBody,
    attachments => $attachments,
  };

  return $data;
}

sub bodystructure {
  my $values = shift;
  my $id = shift;
  my $eml = shift;
  my $partno = shift;

  my $type = {
    'subtype' => 'plain',
    'type' => 'text'
  };
  if (my $val = $eml->header('Content-Type')) {
    $type = parse_content_type($val);
  }
  my @parts = $eml->subparts();
  if (@parts) {
    my @sub;
    for (my $n = 1; $n <= @parts; $n++) {
      push @sub, bodystructure($values, $id, $parts[$n-1], $partno ? "$partno.$n" : $n);
    }
    return {
      partId => undef,
      blobId => undef,
      type => "$type->{type}/$type->{subtype}",
      size => 0,
      headers => headers($eml),
      name => undef,
      cid => asOneURL($eml->header('Content-Id')),
      charset => $type->{attributes}{charset},
      language => asCommaList($eml->header('Content-Language')),
      location => undef,
      disposition => undef,
      subParts => \@sub,
    };
  }
  else {
    my $disposition = {};
    if (my $val = $eml->header('Content-Disposition')) {
      my $orig = $val;
      $val =~ s{^(.*filename=\s*)([^\s"][^;]+)}{$1"$2"};
      $disposition = parse_content_disposition($val);
    }
    $partno ||= '1';
    my $body = $eml->body();
    my $raw_size = length($body); # size in octets of decoded content
    if ($type->{type} eq 'text') {
      # Decode charset to Perl character string
      my $decoded = eval { $eml->body_str() };
      if (defined $decoded) {
        $body = $decoded;
      } else {
        # Fallback: try UTF-8 decode
        $body = eval { Encode::decode('UTF-8', $body) } // $body;
      }
      # RFC 8621: line endings in bodyValues MUST be \n not \r\n
      my $text_body = $body;
      $text_body =~ s/\r\n/\n/g;
      $values->{$partno} = {
        value => $text_body,
        isEncodingProblem => (defined $decoded ? $JSON::false : $JSON::true),
        isTruncated => $JSON::false,
      };
    }
    my $charset = $type->{attributes}{charset};
    if ($type->{type} eq 'text' and not $charset) {
      $charset = 'us-ascii';
    }
    return {
      partId => "$partno",
      blobId => "m-$id-$partno",
      type => "$type->{type}/$type->{subtype}",
      size => $raw_size,
      headers => headers($eml),
      name => $disposition->{attributes}{filename} // $type->{attributes}{name},
      cid => asOneURL($eml->header('Content-Id')),
      charset => $charset,
      language => asCommaList($eml->header('Content-Language')),
      location => asText($eml->header('Content-Location')),
      disposition => $disposition->{type},
    };
  }
}

sub asDate {
  my $val = shift;
  return undef unless defined $val;
  $val =~ s/\(.*//;  # strip comments
  $val =~ s/^\s+//;  # strip leading whitespace
  $val =~ s/\s+$//;  # strip trailing whitespace
  # Add :00 seconds if missing (e.g. "23:32 -0330" → "23:32:00 -0330")
  $val =~ s/(\s\d{2}:\d{2})\s+([-+]\d{4})/$1:00 $2/;
  my $dt = eval { DateTime::Format::Mail->parse_datetime($val) };
  return undef unless $dt;
  my $tz = $dt->time_zone;
  if ($tz->isa('DateTime::TimeZone::Floating')) {
    $dt->set_time_zone('UTC');
  }
  return DateTime::Format::ISO8601::Format->new->format_datetime($dt);
}

sub asMessageIds {
  my $val = shift;
  return undef unless $val;
  my @list = $val =~ m{<([^\>]+)>}gs;
  return undef unless @list;
  return \@list;
}

sub asCommaList {
  my $val = shift;
  return undef unless defined $val;
  $val =~ s/^\s+//;
  $val =~ s/\s+$//;
  my @list = split /\s*,\s*/, $val;
  return \@list;
}

sub asURLs {
  my $val = shift;
  return undef unless defined $val;
  $val =~ s/^\s+//;
  $val =~ s/\s+$//;
  return undef unless length($val);

  # Extract URLs from angle brackets
  my @list;
  while ($val =~ m/<([^>]+)>/gs) {
    push @list, $1;
  }
  return \@list if @list;

  # No angle brackets — treat whole value as a URL if it looks like one
  return undef unless $val =~ m{^[a-zA-Z][a-zA-Z0-9+.-]*:};
  $val =~ s/ .*//; # strip after first whitespace
  return [$val];
}

sub asOneURL {
  my $val = shift;
  my $list = asURLs($val) || [];
  return $list->[-1];
}

sub asText {
  my $val = shift;
  return undef unless defined $val;
  # Decode MIME-Header encoded words, then NFC normalize
  my $decoded = eval { decode('MIME-Header', $val) };
  $decoded = $val unless defined $decoded;
  # If still raw bytes (not flagged as UTF-8), try UTF-8 decode
  if (!Encode::is_utf8($decoded) && $decoded =~ /[\x80-\xff]/) {
    $decoded = eval { Encode::decode('UTF-8', $decoded) } // $decoded;
  }
  my $res = NFC($decoded);
  $res =~ s/^\s*//;
  $res =~ s/\s*$//;
  return $res;
}

sub asAddresses {
  my $emails = shift;

  my $res = asGroupAddresses($emails);
  return undef unless $res;

  my $arr = [ grep { defined $_->{email} } @$res ];
  return $arr;
}

sub asGroupedAddresses {
  # RFC 8621: returns EmailAddressGroup[] — [{name, addresses}]
  my $emails = shift;
  return undef unless defined $emails;
  my $addrs = eval { Email::MIME::Header::AddressList->from_mime_string($emails) };
  return undef unless $addrs;
  my @addrs = $addrs->groups();
  my @res;
  while (@addrs) {
    my $group = shift @addrs;
    my $list = shift @addrs;
    my @addresses;
    foreach my $addr (@$list) {
      my $name = $addr->phrase();
      my $email = $addr->address();
      $email =~ s/\@(.*)/"@" . lc($1)/e if $email;
      push @addresses, {
        name => asText($name),
        email => $email,
      };
    }
    push @res, {
      name => defined $group ? asText($group) : undef,
      addresses => \@addresses,
    };
  }
  return \@res;
}

sub asGroupAddresses {
  # Internal format with sentinel entries (backward compat)
  my $emails = shift;

  return undef unless defined $emails;
  my $addrs = eval { Email::MIME::Header::AddressList->from_mime_string($emails) };
  return undef unless $addrs;
  my @addrs = $addrs->groups();
  my @res;
  while (@addrs) {
    my $group = shift @addrs;
    my $list = shift @addrs;
    if (defined $group) {
      push @res, {
        name => asText($group),
        email => undef,