File Coverage

blib/lib/Mail/SimpleList.pm

Criterion	Covered	Total	%
statement	153	153	100.0
branch	27	28	96.4
condition	15	19	78.9
subroutine	25	25	100.0
pod	13	18	72.2
total	233	243	95.8

package Mail::SimpleList;

use strict;
my $pod = do { local $/;  };

use base 'Mail::Action';
use Carp 'croak';

use Mail::Mailer;
use Email::Address;

use vars '$VERSION';
$VERSION = '0.93';

use Mail::SimpleList::Aliases;

sub storage_class
{
	'Mail::SimpleList::Aliases'
}

sub parse_alias
{
	my ($self, $address)  = @_;
	my ($add)             = Email::Address->parse( $address );
	my $user              = $add->user();
	my $expansion_pattern = $self->expansion_pattern();

	return ( $user =~ $expansion_pattern ) ? $1 : '';
}

sub expansion_pattern
{
	return qr/\+([^+]+)$/;
}

sub command_help
{
	my $self   = shift;
	$self->SUPER::command_help( $pod, 'USING LISTS', 'DIRECTIVES' );
}

sub command_new
{
	my $self      = shift;
	my $from      = $self->address_field( 'From' );
	my $addresses = $self->storage();
	my $alias     = $addresses->create( $from );
	my $users     = $self->process_body( $alias );
	my $id        = $self->generate_alias( $alias->name() );
	my $post      = $self->post_address( $id );

	$self->add_to_alias( $alias, $post, @$users );
	$addresses->save( $alias, $id );

	$self->reply({ To => $from, Subject => "Created list $id" },
		"Mailing list created.  Post to $post." );

	return $alias;
}

sub command_clone
{
	my $self       = shift;

	my $from       = $self->address_field( 'From' );
	my $request    = $self->request();
	(my $subject   = $request->header( 'Subject' )) =~ s/^\*clone\*\s+//;
	my ($alias_id) = $self->parse_alias( $subject );
	my $addresses  = $self->storage();
	my $parent     = $addresses->fetch( $alias_id );
	my $alias      = $addresses->create( $from );
	my $users      = $self->process_body( $alias );
	my $wanted_id  = $alias->name() || $alias_id;
	my $id         = $self->generate_alias( $wanted_id );
	my $post       = $self->post_address( $id );

	$self->add_to_alias( $alias, $post, @{ $parent->members() }, @$users );

	$addresses->save( $alias, $id );

	$self->reply({ To => $from, Subject => "Cloned alias $alias_id => $id" },
		"Mailing list created.  Post to $post." );

	return $alias;
}

sub address_field
{
	my ($self, $field) = @_;

	my @values         = $self->request->header( $field   );
	return wantarray ? @values : $values[0]->address();
}

sub generate_alias
{
	my ($self, $id) = @_;
	my $addresses   = $self->storage();

	$id      ||= sprintf '%x', reverse scalar time;

	while ($addresses->exists( $id ))
	{
		$id    = sprintf '%x', ( reverse ( time() + rand($$) ));
	}

	return $id;
}

sub post_address
{
	my ($self, $id)   = @_;
	my ($address)     = $self->address_field( 'To' );

	# if this is a *new* request, there's no To field anymore
	$address        ||= $self->request->recipient();
	my $host          = $address->host();
	(my $base         = $address->user()) =~ s/\+([^+]+)$//;

	return "$base+$id\@$host";
}

sub reply
{
	my ($self, $headers) = splice( @_, 0, 2 );
	$headers->{'X-MSL-Seen'}    = '1';
	$self->SUPER::reply( $headers, @_ );
}

sub command_unsubscribe
{
	my $self         = shift;
	my ($alias, $id) = $self->fetch_address();
	my $from         = $self->request->header( 'From' )->address();

	$self->reply({ To => $from, Subject => "Remove from $alias" },
		 ($alias->remove_address( $from ) and
		  $self->storage->save( $alias, $id )) ?
			"Unsubscribed $from successfully." :
			"Unsubscribe unsuccessful for $from.  Check the address."
	);
}

sub process
{
	my $self    = shift;

	return if $self->request->header('X-MSL-Seen');
	my $command = $self->find_command();
	return $self->$command() if $command;

	my $alias   = $self->fetch_address();
	return $self->deliver( $alias ) if $alias;
	$self->reject();
}

sub deliver
{
	my ($self, $alias) = @_;

	my $name       = $alias->name();
	my $request    = $self->request();
	my $recipient  = $request->recipient();
	my $sent_to    = $recipient->address();
	my $host       = $recipient->host();
	my $message    = $request->copy_headers();
	$message->{To} = $sent_to;

	unless ($self->can_deliver( $alias, $message ))
	{
		my $body       = delete $message->{Body};
		$message->{To} = delete $message->{From};
		$self->reply( $message, $body );
		return;
	}

	my $desc    = $alias->description() || '';

	if ( $alias->auto_add() )
	{
		my @to_friends = map { $_->address() } $request->header( 'To' );
		my @cc_friends = map { $_->address() } $request->header( 'Cc' );

		$self->add_to_alias( $alias, @to_friends, @cc_friends );
		$self->storage->save( $alias, $name );
	}

	$message->{Bcc}        = $alias->members();
	$message->{'List-Id'}  = ( $desc ? qq|"$desc" | : '') .
		"<$name.list-id.$host>";
	$message->{'Reply-To'} = $sent_to;
	delete $message->{'Delivered-to'};

	my $body    = $self->add_signature( "\n-- \nTo unsubscribe:" .
		qq| reply to this sender alone with "*UNSUBSCRIBE*" in the subject.\n|
	);

	$self->reply( $message, $body );
}

sub add_signature
{
	my ($self, $sig)  = @_;
	my $request       = $self->request();
	my @parts         = $request->message->parts();

	if (@parts == 1)
	{
		$request->message->body_set( $request->message->body() . $sig );
	}
	else
	{
		my $sig_part  = Email::MIME->new( '' );

		$sig_part->content_type_set( 'text/plain' );
		$sig_part->encoding_set( '7bit' );
		$sig_part->disposition_set( 'attachment' );
		$sig_part->body_set( $sig );

		push @parts, $sig_part;
		$request->message->parts_set( \@parts );
	}

	return $request->message->body_raw();
}

sub reject
{
	my $reason = $_[1] || "Invalid alias\n";
	$! = 100;
	die $reason;
}

sub notify
{
	my ($self, $alias, $id) = splice( @_, 0, 3 );

	my $owner = $alias->owner();
	my $desc  = $alias->description();

	for my $address ( @_ )
	{
		$self->reply({
			From       => $owner,
			To         => $address,
			'Reply-To' => $id,
			Subject    => "Added to alias $id",
		}, "You have been subscribed to alias $id by $owner.\n\n", $desc );
	}
}

sub can_deliver
{
	my ($self, $alias, $message) = @_;
	if ( $alias->closed() and not
		grep { $_ eq $message->{From} } @{ $alias->members() })
	{
		$message->{To}      = $message->{From};
		$message->{Subject} = 'Alias closed';
		$message->{Body}    = 'This alias is closed to non-members.';
		return;
	}
	return 1 unless my $expires = $alias->expires();
	if ($expires < time())
	{
		$message->{To}      = $message->{From};
		$message->{Subject} = 'Alias expired';
		$message->{Body}    = 'This alias has expired.';
		return;
	}
	return 1;
}

sub add_to_alias
{
	my ($self, $alias, $id, @addresses) = @_;
	my @added = $alias->add( @addresses ) or return;
	$self->notify( $alias, $id, @added );
}

1;
__DATA__