File Coverage

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

Criterion	Covered	Total	%
statement	112	115	97.3
branch	54	60	90.0
condition	16	21	76.1
subroutine	19	19	100.0
pod	10	11	90.9
total	211	226	93.3

# 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::Attribute;{
our $VERSION = '4.04';
}

use parent 'Mail::Reporter';

use strict;
use warnings;

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

use Encode    ();

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

use overload
	'""' => sub { $_[0]->value },
	cmp  => sub {
		my ($self, $other) = @_;
		UNIVERSAL::isa($other, 'Mail::Message::Field')
		  ? (lc($_[0])->name cmp lc($_[1]->name) || $_[0]->value cmp $_[1]->value)
		  : $_[0]->value cmp $_[1];
	},
	fallback => 1;


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

sub new($$@)
{	my ($class, $attr) = (shift, shift);
	my $value = @_ % 2 == 1 ? shift : undef;
	$class->SUPER::new(attr => $attr, value => $value, @_);
}

sub init($$)
{	my ($self, $args)  = @_;
	$self->SUPER::init($args);

	my ($attr, $value, $cont) = @$args{ qw/attr value use_continuations/ };

	my $name  = ($attr =~ m/^(.*?)(?:\*\d+)?\*?\s*\=\s*/ ? $1 : $attr);
	warning __x"illegal character in parameter name '{name}'.", name => $name
		if $name !~ m/^[!#-'*+\-.0-9A-Z^-~]+$/;

	$self->{MMFF_name}     = $name;
	$self->{MMFF_usecont}  = $cont // 1;
	$self->{MMFF_charset}  = $args->{charset}  if defined $args->{charset};
	$self->{MMFF_language} = $args->{language} if defined $args->{language};

	$self->value(defined $value ? "$value" : '');  # enforce stringification
	$self->addComponent($attr) if $attr ne $name;

	$self;
}

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

sub name() { $_[0]->{MMFF_name} }


sub value(;$)
{	my $self = shift;
	if(@_)
	{	delete $self->{MMFF_cont};
		return $self->{MMFF_value} = shift;
	}
	exists $self->{MMFF_value} ? $self->{MMFF_value} : $self->decode;
}


sub addComponent($)
{	my ($self, $component) = @_;
	defined $component or return;
	delete $self->{MMFF_value};

	my ($name, $value) = split /\=/, $component, 2;
	if( substr($name, -1) eq '*' && $value =~ m/^([^']*)\'([^']*)\'/ )
	{	$self->{MMFF_charset}  = length $1 ? $1 : undef;
		$self->{MMFF_language} = length $2 ? $2 : undef;
	}

	if( $name =~ m/\*([0-9]+)\*?$/ )
	     { $self->{MMFF_cont}[$1] = $component }
	else { $self->{MMFF_cont}     = [ $component ] }

	$component;
}


sub charset() { $_[0]->{MMFF_charset} }


sub language() { $_[0]->{MMFF_language} }


sub string()
{	my $self = shift;
	my $cont = $self->{MMFF_cont} || $self->encode;
	wantarray? @$cont : (join '; ', '', @$cont);
}

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

sub encode()
{	my $self  = shift;
	my $value = $self->{MMFF_value};

	my @lines;
	my ($pre, $encoded);

	my $charset  = $self->{MMFF_charset}  || '';
	my $lang     = $self->{MMFF_language} || '';
	my $name     = $self->{MMFF_name};
	my $cont     = $self->{MMFF_usecont};

	if($charset || $lang)
	{	$pre     = "$name*0*=$charset'$lang'";
		$value   = Encode::encode($charset, $value, 0);
		$encoded = 1;
	}
	elsif(grep m/[^\x20-\x7E]/, $value)
	{	$pre     = "$name*0*=''";
		$encoded = 1;
	}
	else
	{	$pre     = "$name*0=";
		$value   =~ s/"/\\"/g;
		$encoded = 0;
	}

	if($encoded)
	{	# Use encoding
		my @c    = split //, $value;
		while(@c)
		{	my $c = shift @c;
			$c = '%'. sprintf "%02X", ord $c
				unless $c =~ m/[a-zA-Z0-9]/;

			if($cont && length($pre) + length($c)> 76)
			{	push @lines, $pre;
				$pre = $name . '*' . @lines . '*=' . $c;
			}
			else { $pre .= $c }
		}
		push @lines, $pre;
	}
	elsif($cont)
	{	# Simple string, but with continuations
		while(1)
		{	push @lines, $pre.'"'. substr($value, 0, 75-length($pre), '') .'"';
			length $value or last;
			$pre = $name . '*' . @lines . '=';
		}

	}
	else
	{	# Single string only
		push @lines, $pre . $value;
	}

	$lines[0] =~ s/\*0// if @lines==1;
	$self->{MMFF_cont} = \@lines;
}


sub decode()
{	my $self  = shift;
	my $value = '';

	foreach my $cont (  @{$self->{MMFF_cont}} )
	{	unless(defined $cont)
		{	$value .= "[continuation missing]";
			next;
		}

		(my $name, local $_) = split /\=/, $cont, 2;

		if(substr($name, -1) eq '*')
		{	s/^[^']*\'[^']*\'//;
			s/\%([a-fA-F0-9]{2})/chr hex $1/ge;
		}
		elsif( s/^\"(.*)\"$/$1/ ) { s/\\\"/"/g }
		elsif( s/^\'(.*)\'$/$1/ ) { s/\\\'/'/g }

		$value .= $_;
	}

	my $charset = $self->{MMFF_charset};
	$value = Encode::decode($charset, $value, 0) if $charset;

	$self->{MMFF_value} = $value;
}

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

sub mergeComponent($)
{	my ($self, $comp) = @_;
	my $cont  = $self->{MMFF_cont}
		or error __x"too late to merge: value already changed.";

	$self->addComponent($_) for @{$comp->{MMFF_cont}};
	$self;
}

1;