File Coverage

blib/lib/Mail/Identity.pm

Criterion	Covered	Total	%
statement	24	85	28.2
branch	1	72	1.3
condition	3	7	42.8
subroutine	7	17	41.1
pod	9	11	81.8
total	44	192	22.9

# This code is part of Perl distribution User-Identity version 4.00.
# The POD got stripped from this file by OODoc version 3.05.
# For contributors see file ChangeLog.

# This software is copyright (c) 2003-2025 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::Identity;{
our $VERSION = '4.00';
}

use parent 'User::Identity::Item';

use strict;
use warnings;

use Log::Report     'user-identity';

use User::Identity  ();
use Scalar::Util    qw/weaken/;

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

sub type() { 'email' }


sub init($)
{	my ($self, $args) = @_;
	$args->{name} ||= '-x-';

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

	exists $args->{$_} && ($self->{'MI_'.$_} = delete $args->{$_})
		for qw/address charset comment domain language location organization pgp_key phrase signature username/;

	$self->{UII_name} = $self->phrase || $self->address
		if $self->{UII_name} eq '-x-';

	$self;
}

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

sub from($)
{	my ($class, $other) = (shift, shift);
	return $other if $other->isa(__PACKAGE__);

	$other->isa('Mail::Address')
		and return $class->parse($other->format);  # Mail::Address is far to lazy

	$other->isa('User::Identity')
		or return undef;

	my $emails = $other->collection('emails') or next;
	my @roles  = $emails->roles or return ();
	$roles[0];      # first Mail::Identity
}

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

sub comment($)
{	my $self = shift;
	return $self->{MI_comment} = shift if @_;
	return $self->{MI_comment} if defined $self->{MI_comment};

	my $user = $self->user     or return undef;
	my $full = $user->fullName or return undef;
	$self->phrase eq $full ? undef : $full;
}


sub charset()
{	my $self = shift;
	return $self->{MI_charset} if defined $self->{MI_charset};

	my $user = $self->user;
	defined $user ? $user->charset : undef;
}


sub language()
{	my $self = shift;
	return $self->{MI_language} if defined $self->{MI_language};

	my $user = $self->user;
	defined $user ? $user->language : undef;
}


sub domain()
{	my $self = shift;
	return $self->{MI_domain} if defined $self->{MI_domain};

	my $address = $self->{MI_address} or return 'localhost';
	$address =~ s/.*?\@// ? $address : undef;
}


sub address()
{	my $self = shift;
	return $self->{MI_address} if defined $self->{MI_address};

	if(my $username = $self->username)
	{	if(my $domain = $self->domain)
		{	if($username =~ /[^a-zA-Z0-9!#\$%&'*+\-\/=?^_`{|}~.]/)
			{	# When the local part does contain a different character
				# than an atext or dot, make it quoted-string
				$username =~ s/"/\\"/g;
				$username = qq{"$username"};
			}
			return "$username\@$domain";
		}
	}

	my $name = $self->name;
	return $name if index($name, '@') >= 0;

	my $user = $self->user;
	defined $user ? $user->nickname : $name;
}


sub location()
{	my $self      = shift;
	my $location  = $self->{MI_location};

	if(! defined $location)
	{	my $user  = $self->user or return;
		my @locs  = $user->collection('locations');
		$location =  @locs ? $locs[0] : undef;
	}
	elsif(! ref $location)
	{	my $user  = $self->user or return;
		$location = $user->find(location => $location);
	}

	$location;
}


sub organization()
{	my $self = shift;
	return $self->{MI_organization} if defined $self->{MI_organization};

	my $location = $self->location or return;
	$location->organization;
}

#pgp_key

sub phrase()
{	my $self = shift;
	return $self->{MI_phrase} if defined $self->{MI_phrase};

	my $user = $self->user;
	defined $user ? $user->fullName : undef;
}

#signature

sub username()
{	my $self = shift;
	return $self->{MI_username} if defined $self->{MI_username};

	if(my $address = $self->{MI_address})
	{	$address =~ s/\@.*$//;   # strip domain part if present
		return $address;
	}

	my $user = $self->user;
	defined $user ? $user->nickname : undef;
}

1;