File Coverage

blib/lib/Mail/Message/Field/Addresses.pm

Criterion	Covered	Total	%
statement	117	126	92.8
branch	47	64	73.4
condition	12	22	54.5
subroutine	19	21	90.4
pod	11	12	91.6
total	206	245	84.0

# This code is part of Perl distribution Mail-Message version 4.04.
# The POD got stripped from this file by OODoc version 3.06.
# For contributors see file ChangeLog.

# This software is copyright (c) 2001-2026 by Mark Overmeer.

# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
# SPDX-License-Identifier: Artistic-1.0-Perl OR GPL-1.0-or-later


package Mail::Message::Field::Addresses;{
our $VERSION = '4.04';
}

use parent 'Mail::Message::Field::Structured';

use strict;
use warnings;

use Log::Report   'mail-message', import => [ qw/__x error info warning/ ];

use Mail::Message::Field::AddrGroup ();
use Mail::Message::Field::Address   ();

use List::Util      qw/first/;
use Scalar::Util    qw/blessed/;

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

# what is permitted for each field.

my $address_list = +{ groups => 1, multi => 1 };
my $mailbox_list = +{ multi => 1 };
my $mailbox      = +{ };

my %accepted     = (  # defaults to $address_list
	from   => $mailbox_list,
	sender => $mailbox,
);

sub init($)
{	my ($self, $args) = @_;

	$self->{MMFF_groups}   = [];

	my $def = lc $args->{name} =~ s/^resent\-//r;
	$self->{MMFF_defaults} = $accepted{$def} || $address_list;

	my ($body, @body);
	if($body = $args->{body})
	{	@body = ref $body eq 'ARRAY' ? @$body : ($body);
		@body or return ();
	}

	if(@body > 1 || ref $body[0])
	{	$self->addAddress($_) for @body;
		delete $args->{body};
	}

	$self->SUPER::init($args);
}

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

sub addAddress(@)
{	my $self  = shift;
	my $email = blessed $_[0] ? shift : undef;
	my %args  = @_;
	my $group = delete $args{group} // '';

	$email  //= Mail::Message::Field::Address->new(%args);

	my $set = $self->group($group) // $self->addGroup(name => $group);
	$set->addAddress($email);
	$email;
}


sub addGroup(@)
{	my $self  = shift;
	my $group = @_ == 1 ? shift : Mail::Message::Field::AddrGroup->new(@_);
	push @{$self->{MMFF_groups}}, $group;
	$group;
}


sub group($)
{	my ($self, $name) = @_;
	$name //= '';
	first { lc($_->name) eq lc($name) } $self->groups;
}


sub groups() { @{ $_[0]->{MMFF_groups}} }


sub groupNames() { map $_->name, $_[0]->groups }


sub addresses() { map $_->addresses, $_[0]->groups }


sub addAttribute($;@)
{	my $self = shift;
	error __x"no attributes for address fields.";
}

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

sub parse($)
{	my ($self, $string) = @_;
	my ($group, $email) = ('', undef);
	$string =~ s/\s+/ /gs;

  ADDRESS:
	while(1)
	{	(my $comment, $string) = $self->consumeComment($string);
		my $start_length = length $string;

		if($string =~ s/^\s*\;//s ) { $group = ''; next ADDRESS }  # end group
		if($string =~ s/^\s*\,//s ) { next ADDRESS}               # end address

		(my $email, $string) = $self->consumeAddress($string);
		if(defined $email)
		{	# Pattern starts with e-mail address
			($comment, $string) = $self->consumeComment($string);
			$email->comment($comment) if defined $comment;
		}
		else
		{	# Pattern not plain address
			my $real_phrase = $string =~ m/^\s*\"/;
			my @words;

			# In rfc2822 obs-phrase, we can have more than one word with
			# comments inbetween.
		WORD:
			while(1)
			{	(my $word, $string) = $self->consumePhrase($string);
				defined $word or last;

				push @words, $word if length $word;
				($comment, $string) = $self->consumeComment($string);

				if($string =~ s/^\s*\://s )
				{	$group = $word;
					# even empty groups must appear
					$self->addGroup(name => $group) unless $self->group($group);
					next ADDRESS;
				}
			}
			my $phrase = @words ? join ' ', @words : undef;

			my $angle;
			if($string =~ s/^\s*\<([^>]*)\>//s) { $angle = $1 }
			elsif($real_phrase)
			{	warning __x"ignoring addressless phrase '{phrase}'.", phrase => $1
					if $string =~ s/^\s*\"(.*?)\r?\n//;
				next ADDRESS;
			}
			elsif(defined $phrase)
			{	($angle = $phrase) =~ s/\s+/./g;
				undef $phrase;
			}

			($comment, $string) = $self->consumeComment($string);

			# remove obsoleted route info.
			defined $angle or return 1;
			$angle =~ s/^\@.*?\://;

			($email, $angle) = $self->consumeAddress($angle, phrase => $phrase, comment => $comment);
		}

		$self->addAddress($email, group => $group) if defined $email;
		return 1 if $string =~ m/^\s*$/s;

		# Do not get stuck on illegal characters
		last if $start_length == length $string;
	}

	warning __x"illegal part in address field {name}: {part}.", name => $self->Name, part => $string;
	0;
}

sub produceBody()
{	my $self   = shift;
	my @groups = sort { $a->name cmp $b->name } $self->groups;

	@groups     or return '';
	@groups > 1 or return $groups[0]->string;

	my $plain = $groups[0]->name eq '' && $groups[0]->addresses ? (shift @groups)->string.',' : '';
	join ' ', $plain, (map $_->string, @groups);
}


sub consumeAddress($@)
{	my ($self, $string, @options) = @_;

	my ($local, $shorter, $loccomment);
	if($string =~ s/^\s*"((?:\\.|[^"])*)"\s*\@/@/)
	{	# local part is quoted-string rfc2822
		($local, $shorter) = ($1, $string);
		$local =~ s/\\"/"/g;
	}
	else
	{	($local, $shorter, $loccomment) = $self->consumeDotAtom($string);
		$local =~ s/\s//g if defined $local;
	}

	defined $local && $shorter =~ s/^\s*\@//
		or return (undef, $string);

	(my $domain, $shorter, my $domcomment) = $self->consumeDomain($shorter);
	defined $domain
		or return (undef, $string);

	# loccomment and domcomment ignored
	my $email = Mail::Message::Field::Address->new(username => $local, domain => $domain, @options);
	($email, $shorter);
}


sub consumeDomain($)
{	my ($self, $string) = @_;

	return ($self->stripCFWS($1), $string)
		if $string =~ s/\s*(\[(?:[^[]\\]*|\\.)*\])//;

	my ($atom, $rest, $comment) = $self->consumeDotAtom($string);
	$atom =~ s/\s//g if defined $atom;
	($atom, $rest, $comment);
}

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

1;