root/t/20list-headers.t

#!/usr/bin/perl -w

use strict;

BEGIN { chdir 't' if -d 't' }
use lib '../lib';

use Test::More tests => 35;
use File::Path;

use Lancelot::DB;
use Lancelot::Message;

sub copy_msg {
    return Lancelot::Message->new($_[0]->as_string);
}

BEGIN { use_ok('Lancelot::Module::list_headers'); }

my $listname = 'pl-testlist@example.com';

rmtree("$ENV{HOME}/.pl/$listname", 0);

my $db = new Lancelot::DB $listname, { create => 1 };
$db->set_config('list.name', 'Pl-testlist');
$db->set_config('mail.delimiter', '+');

# Check RFC2919 (List-ID)

my $msg = Lancelot::Message->new('From: hugo@example.com
To: susi@example.net
Subject: Test
Foo: bar
Baz: quux

This is a test.
');

$db->set_config('mail.listid', '<pl-testlist.example.com>');
my $tmsg = copy_msg($msg);
my $result = Lancelot::Module::list_headers::execute($db, $tmsg);
is($tmsg->header('List-ID'), '<pl-testlist.example.com>', 'explicit list ID');

$db->delete_configs('mail.listid');
$tmsg = copy_msg($msg);
$result = Lancelot::Module::list_headers::execute($db, $tmsg);
is($tmsg->header('List-ID'), '<pl-testlist.list-id.example.com>',
   'default list ID');

# Check RFC2369 (List headers)

$db->delete_configs('mail.listheaders');
$tmsg = copy_msg($msg);
$result = Lancelot::Module::list_headers::execute($db, $tmsg);
my @hdrs = qw/help owner subscribe unsubscribe/;
foreach my $h (@hdrs) {
    ok(! defined $tmsg->header('List-'.ucfirst($h)),
       "List-\u$h should be undefined");
}

$db->set_config('mail.listheaders', 1);
$tmsg = copy_msg($msg);
$result = Lancelot::Module::list_headers::execute($db, $tmsg);
@hdrs = qw/help owner subscribe unsubscribe/;
foreach my $h (@hdrs) {
    is($tmsg->header('List-'.ucfirst($h)),
       "<mailto:pl-testlist+$h\@example.com>",
       "List-\u$h value");
}

$db->delete_configs('mail.delimiter');
$tmsg = copy_msg($msg);
$result = Lancelot::Module::list_headers::execute($db, $tmsg);
@hdrs = qw/help owner subscribe unsubscribe/;
foreach my $h (@hdrs) {
    is($tmsg->header('List-'.ucfirst($h)),
       "<mailto:pl-testlist-$h\@example.com>",
       "List-\u$h value (default mail.delimiter)");
}

# mail.removeheaders

$db->set_config('mail.removeheaders', 'foo');
$db->delete_configs('mail.listheaders');
$tmsg = copy_msg($msg);
my $hcount = $tmsg->header_names();
$result = Lancelot::Module::list_headers::execute($db, $tmsg);
ok(! defined $tmsg->header('Foo'),
   "removeheaders 1: foo should be removed");
is(scalar($tmsg->header_names()), $hcount,
   "removeheaders 1: all other headers still there");

$db->set_config('mail.removeheaders', 'foo baz');
$tmsg = copy_msg($msg);
$result = Lancelot::Module::list_headers::execute($db, $tmsg);
ok(! defined $tmsg->header('Foo'),
   "removeheaders 2: foo should be removed");
ok(! defined $tmsg->header('Baz'),
   "removeheaders 2: baz should be removed");
is(scalar($tmsg->header_names()), $hcount-1,
   "removeheaders 1: all other headers still there");

$db->delete_configs('mail.listheaders');
$db->set_config('mail.removeheaders', '');
$tmsg = copy_msg($msg);
$result = Lancelot::Module::list_headers::execute($db, $tmsg);
# $hcount+1 because List-ID will always be generated
is(scalar($tmsg->header_names()), $hcount+1,
   "removeheaders 3: all headers still there");

$db->delete_configs('mail.removeheaders');

# mail.addheaders

$db->set_config('mail.addheaders', 'abc');
$db->set_config('mail.header.abc', 'xyzzy');
$tmsg = copy_msg($msg);
$result = Lancelot::Module::list_headers::execute($db, $tmsg);
is(scalar($tmsg->header_names()), $hcount+2,
   "addheaders 1: one more header");
is($tmsg->header('Abc'), 'xyzzy', 'new abc header value');

# Add one header, second header to be added does not exist
$db->set_config('mail.addheaders', 'abc xyz');
$db->set_config('mail.header.abc', 'xyzzy');
$tmsg = copy_msg($msg);
$result = Lancelot::Module::list_headers::execute($db, $tmsg);
is(scalar($tmsg->header_names()), $hcount+2,
   "addheaders 1: one more header");
is($tmsg->header('Abc'), 'xyzzy', 'new abc header value');
ok(!defined $tmsg->header('Xyz'), 'new (nonexistent) xyz header value');

# Add two new headers
$db->set_config('mail.addheaders', 'abc def');
$db->set_config('mail.header.def', 'zyxxy');
$tmsg = copy_msg($msg);
$result = Lancelot::Module::list_headers::execute($db, $tmsg);
is(scalar($tmsg->header_names()), $hcount+3,
   "addheaders 1: two more headers");
is($tmsg->header('Abc'), 'xyzzy', 'new abc header value');
is($tmsg->header('Def'), 'zyxxy', 'new def header value');

$db->delete_configs(qw/mail.addheaders mail.header.abc mail.header.def/);

# subject header munging

$db->set_config('mail.subjecttag', '[List] ');
$tmsg = copy_msg($msg);
$result = Lancelot::Module::list_headers::execute($db, $tmsg);
is($tmsg->header('Subject'), '[List] Test', 'with subject tag');

$tmsg = copy_msg($msg);
$tmsg->header_set('Subject', 'Re: Re: [List] Test');
$result = Lancelot::Module::list_headers::execute($db, $tmsg);
is($tmsg->header('Subject'), 'Re: Re: [List] Test', 'with prefixes');

$tmsg = copy_msg($msg);
$tmsg->header_set('Subject', 'RE: [List] AW: [List] Test');
$result = Lancelot::Module::list_headers::execute($db, $tmsg);
is($tmsg->header('Subject'), 'RE: [List] AW: [List] Test', 'with prefixes 2');

$db->delete_configs('mail.subjecttag');

# reply-to munging

$db->set_config('mail.replyto', 'pl-testlist@example.com');
$db->set_config('mail.forcereplyto', 0);
$tmsg = copy_msg($msg);
$result = Lancelot::Module::list_headers::execute($db, $tmsg);
is($tmsg->header('Reply-To'), 'pl-testlist@example.com',
   'optional list reply-to');

$tmsg = copy_msg($msg);
$tmsg->header_set('Reply-To', 'hugo@example.com');
$result = Lancelot::Module::list_headers::execute($db, $tmsg);
is($tmsg->header('Reply-To'), 'hugo@example.com', 'message reply-to');

$db->set_config('mail.forcereplyto', 1);
$result = Lancelot::Module::list_headers::execute($db, $tmsg);
is($tmsg->header('Reply-To'), 'pl-testlist@example.com',
   'forced list reply-to');

$db->delete_configs('mail.replyto');