The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use warnings;
use strict;
use Test::More;

use WWW::Mailman;

# generate all possible combinations
my @tests =
    [   'https://lists.sourceforge.net/lists/listinfo/backuppc-users/' => {
            secure   => 1,
            userinfo => '',
            server   => 'lists.sourceforge.net',
            prefix   => '',
            program  => 'lists',
            list     => 'backuppc-users',
            uri =>
                'https://lists.sourceforge.net/lists/listinfo/backuppc-users',
        }
    ],
    map {
    my $u1 = my $u2
        = ( $_->{secure} ? 'https' : 'http' ) . '://'
        . $_->{userinfo}
        . ( $_->{userinfo} ? '@' : '' )
        . $_->{server}
        . ( $_->{prefix} ? '/' : '' )
        . $_->{prefix}
        . '/mailman';
    $u1 .= '/admin/' . $_->{list};
    $u2 .= '/listinfo/' . $_->{list};
    [ $u1 => { %$_, uri => $u2 } ]
    }
    map { ( { %$_, secure   => '' }, { %$_, secure   => 1 } ) }
    map { ( { %$_, prefix   => '' }, { %$_, prefix   => 'prefix' } ) }
    map { ( { %$_, userinfo => '' }, { %$_, userinfo => 'user:s3kr3t' } ) }
    map { ( { %$_, root     => '' }, { %$_, root     => 'lists' } ) }
    { server => 'lists.example.com', list => 'example' };

my @fails = (
    [   'http://lists.example.com/' =>
            q{^Invalid URL !uri: no program segment found \(mailman\) }
    ],
    [   'http://lists.example.com/mailman/' =>
            q{^Invalid URL !uri: no action }
    ],
);

my @attr = qw( secure server userinfo prefix program list );

plan tests => ( @attr + 1 ) * @tests + 2 * @fails;

for my $test (@tests) {
    my ( $uri, $expected ) = @$test;
    my $m;

    # create from the parts and check the URI
    $m = WWW::Mailman->new();
    $m->$_( $expected->{$_} ) for grep { $expected->{$_} } @attr;
    is( $m->uri, $expected->{uri}, $expected->{uri} );

    # create from the URI and check the parts
    $m = WWW::Mailman->new();
    $m->uri($uri);
    for my $attr (@attr) {
        is( $m->$attr, $expected->{$attr}, "$attr for $uri" );
    }
}

for my $fail (@fails) {
    my ( $uri, $regexp ) = @$fail;
    $regexp =~ s/!uri/\Q$uri\E/;
    ok( !eval { WWW::Mailman->new( uri => $uri ); }, "new() fails for $uri" );
    like( $@, qr/$regexp/, 'Expected error message' );
}