File Coverage

blib/lib/Email/MIME/Header/AddressList.pm

Criterion	Covered	Total	%
statement	104	122	85.2
branch	19	32	59.3
condition	11	18	61.1
subroutine	16	18	88.8
pod	13	13	100.0
total	163	203	80.3

# Copyright (c) 2016-2017 by Pali

package Email::MIME::Header::AddressList;
$Email::MIME::Header::AddressList::VERSION = '1.952';
# ABSTRACT: MIME support for list of Email::Address::XS objects

use strict;
use warnings;

use Carp ();
use Email::Address::XS;
use Email::MIME::Encode;

#pod =encoding utf8
#pod
#pod =head1 SYNOPSIS
#pod
#pod   my $address1 = Email::Address::XS->new('Name1' => '[e-mail]');
#pod   my $address2 = Email::Address::XS->new("Name2 \N{U+263A}" => '[e-mail]');
#pod   my $mime_address = Email::Address::XS->new('=?UTF-8?B?TmFtZTIg4pi6?=' => '[e-mail]');
#pod
#pod   my $list1 = Email::MIME::Header::AddressList->new($address1, $address2);
#pod
#pod   $list1->append_groups('undisclosed-recipients' => []);
#pod
#pod   $list1->first_address();
#pod   # returns $address1
#pod
#pod   $list1->groups();
#pod   # returns (undef, [ $address1, $address2 ], 'undisclosed-recipients', [])
#pod
#pod   $list1->as_string();
#pod   # returns 'Name1 , "Name2 ☺" , undisclosed-recipients:;'
#pod
#pod   $list1->as_mime_string();
#pod   # returns 'Name1 , =?UTF-8?B?TmFtZTIg4pi6?= , undisclosed-recipients:;'
#pod
#pod   my $list2 = Email::MIME::Header::AddressList->new_groups(Group => [ $address1, $address2 ]);
#pod
#pod   $list2->append_addresses($address2);
#pod
#pod   $list2->addresses();
#pod   # returns ($address2, $address1, $address2)
#pod
#pod   $list2->groups();
#pod   # returns (undef, [ $address2 ], 'Group', [ $address1, $address2 ])
#pod
#pod   my $list3 = Email::MIME::Header::AddressList->new_mime_groups('=?UTF-8?B?4pi6?=' => [ $mime_address ]);
#pod   $list3->as_string();
#pod   # returns '☺: "Name2 ☺" ;'
#pod
#pod   my $list4 = Email::MIME::Header::AddressList->from_string('Name1 , "Name2 ☺" , undisclosed-recipients:;');
#pod   my $list5 = Email::MIME::Header::AddressList->from_string('Name1 ', '"Name2 ☺" ', 'undisclosed-recipients:;');
#pod
#pod   my $list6 = Email::MIME::Header::AddressList->from_mime_string('Name1 , =?UTF-8?B?TmFtZTIg4pi6?= , undisclosed-recipients:;');
#pod   my $list7 = Email::MIME::Header::AddressList->from_mime_string('Name1 ', '=?UTF-8?B?TmFtZTIg4pi6?= ', 'undisclosed-recipients:;');
#pod
#pod =head1 DESCRIPTION
#pod
#pod This module implements object representation for the list of the
#pod L objects. It provides methods for
#pod L MIME encoding and decoding
#pod suitable for L address-list
#pod structure.
#pod
#pod =head2 EXPORT
#pod
#pod None
#pod
#pod =head2 Class Methods
#pod
#pod =over 4
#pod
#pod =item new_empty
#pod
#pod Construct new empty C object.
#pod
#pod =cut

sub new_empty {
  my ($class) = @_;
  return bless { addresses => [], groups => [] }, $class;
}

#pod =item new
#pod
#pod Construct new C object from list of
#pod L objects.
#pod
#pod =cut

sub new {
  my ($class, @addresses) = @_;
  my $self = $class->new_empty();
  $self->append_addresses(@addresses);
  return $self;
}

#pod =item new_groups
#pod
#pod Construct new C object from named groups of
#pod L objects.
#pod
#pod =cut

sub new_groups {
  my ($class, @groups) = @_;
  my $self = $class->new_empty();
  $self->append_groups(@groups);
  return $self;
}

#pod =item new_mime_groups
#pod
#pod Like L|/new_groups> but in this method group names and objects properties are
#pod expected to be already MIME encoded, thus ASCII strings.
#pod
#pod =cut

sub new_mime_groups {
  my ($class, @groups) = @_;
  if (scalar @groups % 2) {
    Carp::carp 'Odd number of elements in argument list';
    return;
  }
  foreach (0 .. scalar @groups / 2 - 1) {
    $groups[2 * $_] = Email::MIME::Encode::mime_decode($groups[2 * $_])
      if defined $groups[2 * $_] and $groups[2 * $_] =~ /=\?/;
    $groups[2 * $_ + 1] = [ @{$groups[2 * $_ + 1]} ];
    foreach (@{$groups[2 * $_ + 1]}) {
      next unless Email::Address::XS->is_obj($_);
      my $decode_phrase = (defined $_->phrase and $_->phrase =~ /=\?/);
      my $decode_comment = (defined $_->comment and $_->comment =~ /=\?/);
      next unless $decode_phrase or $decode_comment;
      $_ = ref($_)->new(copy => $_);
      $_->phrase(Email::MIME::Encode::mime_decode($_->phrase))
        if $decode_phrase;
      $_->comment(Email::MIME::Encode::mime_decode($_->comment))
        if $decode_comment;
    }
  }
  return $class->new_groups(@groups);
}

#pod =item from_string
#pod
#pod Construct new C object from input string arguments.
#pod Calls L.
#pod
#pod =cut

sub from_string {
  my ($class, @strings) = @_;
  return $class->new_groups(map { Email::Address::XS::parse_email_groups($_) } @strings);
}

#pod =item from_mime_string
#pod
#pod Like L|/from_string> but input string arguments are expected to
#pod be already MIME encoded.
#pod
#pod =cut

sub from_mime_string {
  my ($class, @strings) = @_;
  return $class->new_mime_groups(map { Email::Address::XS::parse_email_groups($_) } @strings);
}

#pod =back
#pod
#pod =head2 Object Methods
#pod
#pod =over 4
#pod
#pod =item as_string
#pod
#pod Returns string representation of C object.
#pod Calls L.
#pod
#pod =cut

sub as_string {
  my ($self) = @_;
  return Email::Address::XS::format_email_groups($self->groups());
}

#pod =item as_mime_string
#pod
#pod Like L|/as_string> but output string will be properly and
#pod unambiguously MIME encoded. MIME encoding is done before calling
#pod L.
#pod
#pod =cut

sub as_mime_string {
  my ($self, $arg) = @_;
  my $charset = $arg->{charset};
  my $header_name_length = $arg->{header_name_length};

  my @groups = $self->groups();
  foreach (0 .. scalar @groups / 2 - 1) {
    $groups[2 * $_] = Email::MIME::Encode::mime_encode($groups[2 * $_], $charset)
      if Email::MIME::Encode::_needs_mime_encode_addr($groups[2 * $_]);
    $groups[2 * $_ + 1] = [ @{$groups[2 * $_ + 1]} ];
    foreach (@{$groups[2 * $_ + 1]}) {
      my $encode_phrase = Email::MIME::Encode::_needs_mime_encode_addr($_->phrase);
      my $encode_comment = Email::MIME::Encode::_needs_mime_encode_addr($_->comment);
      next unless $encode_phrase or $encode_comment;
      $_ = ref($_)->new(copy => $_);
      $_->phrase(Email::MIME::Encode::mime_encode($_->phrase, $charset))
        if $encode_phrase;
      $_->comment(Email::MIME::Encode::mime_encode($_->comment, $charset))
        if $encode_comment;
    }
  }
  return Email::Address::XS::format_email_groups(@groups);
}

#pod =item first_address
#pod
#pod Returns first L object.
#pod
#pod =cut

sub first_address {
  my ($self) = @_;
  return $self->{addresses}->[0] if @{$self->{addresses}};
  my $groups = $self->{groups};
  foreach (0 .. @{$groups} / 2 - 1) {
    next unless @{$groups->[2 * $_ + 1]};
    return $groups->[2 * $_ + 1]->[0];
  }
  return undef;
}

#pod =item addresses
#pod
#pod Returns list of all L objects.
#pod
#pod =cut

sub addresses {
  my ($self) = @_;
  my $t = 1;
  my @addresses = @{$self->{addresses}};
  push @addresses, map { @{$_} } grep { $t ^= 1 } @{$self->{groups}};
  return @addresses;
}

#pod =item groups
#pod
#pod Like L|/addresses> but returns objects with named groups.
#pod
#pod =cut

sub groups {
  my ($self) = @_;
  my @groups = @{$self->{groups}};
  $groups[2 * $_ + 1] = [ @{$groups[2 * $_ + 1]} ]
    foreach 0 .. scalar @groups / 2 - 1;
  unshift @groups, undef, [ @{$self->{addresses}} ]
    if @{$self->{addresses}};
  return @groups;
}

#pod =item append_addresses
#pod
#pod Append L objects.
#pod
#pod =cut

sub append_addresses {
  my ($self, @addresses) = @_;
  my @valid_addresses = grep { Email::Address::XS->is_obj($_) } @addresses;
  Carp::carp 'Argument is not an Email::Address::XS object' if scalar @valid_addresses != scalar @addresses;
  push @{$self->{addresses}}, @valid_addresses;
}

#pod =item append_groups
#pod
#pod Like L|/append_addresses> but arguments are pairs of name of
#pod group and array reference of L objects.
#pod
#pod =cut

sub append_groups {
  my ($self, @groups) = @_;
  if (scalar @groups % 2) {
    Carp::carp 'Odd number of elements in argument list';
    return;
  }
  my $carp_invalid = 1;
  my @valid_groups;
  foreach (0 .. scalar @groups / 2 - 1) {
    push @valid_groups, $groups[2 * $_];
    my $addresses = $groups[2 * $_ + 1];
    my @valid_addresses = grep { Email::Address::XS->is_obj($_) } @{$addresses};
    if ($carp_invalid and scalar @valid_addresses != scalar @{$addresses}) {
      Carp::carp 'Array element is not an Email::Address::XS object';
      $carp_invalid = 0;
    }
    push @valid_groups, \@valid_addresses;
  }
  push @{$self->{groups}}, @valid_groups;
}

#pod =back
#pod
#pod =head1 SEE ALSO
#pod
#pod L,
#pod L,
#pod L,
#pod L
#pod
#pod =head1 AUTHOR
#pod
#pod Pali [e-mail]
#pod
#pod =cut

1;

__END__