File Coverage

blib/lib/Mail/SimpleList.pm

Criterion	Covered	Total	%
statement	152	152	100.0
branch	27	28	96.4
condition	15	19	78.9
subroutine	26	26	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 Email::MIME;

use vars '$VERSION';
$VERSION = '0.94';

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->create(
            attributes => {
                encoding     => '7bit',
                disposition  => 'attachment',
                content_type => 'text/plain',
            },
            body => $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__