File Coverage

blib/lib/WWW/Mailman.pm

Criterion	Covered	Total	%
statement	83	156	53.2
branch	31	62	50.0
condition	8	28	28.5
subroutine	16	27	59.2
pod	10	10	100.0
total	148	283	52.3

package WWW::Mailman;
$WWW::Mailman::VERSION = '1.061';
use warnings;
use strict;

use Carp;
use URI;
use WWW::Mechanize;
use HTTP::Cookies;

my @attributes = qw(
    secure server prefix program list
    email password moderator_password admin_password
);

my %default = ( program => 'mailman' );

my $action_re = qr/^(?:admin(?:db)?|edithtml|listinfo|options|private)$/;

#
# ACCESSORS / MUTATORS
#

# generic accessors
for my $attr (@attributes) {
    no strict 'refs';
    *{$attr} = sub {
        my $self = shift;
        return defined $self->{$attr} ? $self->{$attr} : $default{$attr} || ''
            if !@_;
        return $self->{$attr} = shift;
    };
}

# specialized accessors
sub uri {
    my ( $self, $uri ) = @_;
    if ($uri) {
        $uri = URI->new($uri);

        # @segments = @prefix, $program, $action, $list, @suffix
        my $program = $self->program;
        my ( undef, @segments ) = $uri->path_segments;
        my @prefix;

        # the program name is found in the url
        if( grep $_ eq $program, @segments ) {
            push @prefix, shift @segments
                while @segments && $segments[0] ne $program;
            shift @segments;    # drop the program name
            croak "Invalid URL $uri: no action"
                if !shift @segments;
        }

        # try to autodetect the program name
        elsif( grep $_ =~ $action_re, @segments ) {
            push @prefix, shift @segments
                while @segments && $segments[0] !~ $action_re;
            $self->program( pop @prefix );    # get the program name
            shift @segments;    # drop the action name
        }

        # declare FAIL
        else {
            croak "Invalid URL $uri: no program segment found ($program)";
        }

        # just keep the bits we need
        $self->server( $uri->host );
        $self->secure( $uri->scheme eq 'https' );
        $self->userinfo( $uri->userinfo );
        $self->prefix( join '/', @prefix );
        $self->list( shift @segments );
    }

    # create a generic listinfo URL
    else {
        $uri = $self->_uri_for('listinfo');
    }
    return $uri;
}

sub archive_mbox_uri {
    my $self = shift;
    return $self->__uri_for( private => ( $self->list . '.mbox' ) x 2 );
}

sub userinfo {
    my $self = shift;
    return defined $self->{userinfo} ? $self->{userinfo} : '' if !@_;
    $self->{userinfo} = my $userinfo = shift;

    # update the credentials stored in the robot
    if ( $self->robot ) {
        if ($userinfo) {
            $self->robot->credentials( split /:/, $userinfo, 2 );
        }
        else {
            $self->robot->clear_credentials();
        }
    }

    return $userinfo;
}

sub robot {
    my $self = shift;
    return defined $self->{robot} ? $self->{robot} : '' if !@_;
    $self->{robot} = shift;
    $self->userinfo( $self->userinfo );    # update credentials
    return $self->{robot};
}

push @attributes, qw( uri userinfo robot );

#
# CONSTRUCTOR
#

sub new {
    my ( $class, %args ) = @_;

    # create the object
    my $self = bless {}, $class;

    # get the rest of attributes
    $self->$_( delete $args{$_} )
        for grep { exists $args{$_} } @attributes;

    # bring in the robot if needed
    if ( !$self->robot ) {
        my %mech_options = (
            agent => "WWW::Mailman/$WWW::Mailman::VERSION",
            stack_depth => 2,    # make it a Bear of Very Little Brain
            quiet       => 1,
            autocheck   => 0,    # Fancy my making a mistake like that
        );
        $mech_options{cookie_jar} = HTTP::Cookies->new(
            file => delete $args{cookie_file},
            ignore_discard => 1,    # Promise me you'll never forget me
            autosave       => 1,
        ) if exists $args{cookie_file};
        $self->robot( WWW::Mechanize->new(%mech_options) );
    }

    # some unknown parameters remain
    croak "Unknown constructor parameters: @{ [ keys %args ] }"
        if keys %args;

    return $self;
}

#
# PRIVATE METHODS
#
sub __uri_for {
    my ( $self, @parts ) = @_;
    my $uri = URI->new();
    $uri->scheme( $self->secure ? 'https' : 'http' );
    $uri->userinfo( $self->userinfo )
        if $self->userinfo;
    $uri->host( $self->server );
    $uri->path( join '/', $self->prefix || (), $self->program, @parts );
    return $uri;
}

sub _uri_for {
    my ( $self, $action, @options ) = @_;
    return $self->__uri_for( $action, $self->list, @options )
}

sub _login_form {
    my ($self) = @_;
    my $mech = $self->robot;

    # shortcut
    return if !$mech->forms;

    my $form;

    # login is required if the form asks for:
    # - a login/password
    if ( $form = $mech->form_with_fields('password') ) {
        $form->value( email    => $self->email );
        $form->value( password => $self->password );
    }

    # - an admin (or moderator) password
    elsif ( $form = $mech->form_with_fields('adminpw') ) {
        $form->value( adminpw => $self->admin_password
                || $self->moderator_password );
    }

    # otherwise, no authentication required

    return $form;
}

sub _load_uri {
    my ( $self, $uri ) = @_;
    my $mech = $self->robot;
    $mech->get($uri);

    # authentication required?
    if ( my $form = $self->_login_form ) {
        $mech->request( $form->click );
        croak "Couldn't login on $uri" if $self->_login_form;
    }

    # get the version if we don't have it yet
    $self->{version} = $1
        if !exists $self->{version}
            && $mech->content =~ /version (\d+\.\d+\.\d+\w*)

    # we're on!
}

#
# INTERNAL UTILITY FUNCTIONS
#
sub _form_data {
    return {
        map {
            $_->type eq 'submit' || $_->readonly
                ? ()    # ignore buttons and read-only inputs
                : ( $_->name => $_->value )
            } $_[0]->inputs
    };
}

#
# ACTIONS
#

# The option form has 5 submit buttons, listed here with their inputs:
#
# * change-of-address:
#   - new-address
#   - confirm-address
#   - fullname
#   - changeaddr-globally
# * unsub:
#   - unsubconfirm
# * othersubs
# * emailpw
# * changepw:
#   - newpw
#   - confpw
#   - pw-globally
# * options-submit:
#   - disablemail
#   - deliver-globally
#   - digest
#   - mime
#   - mime-globally
#   - dontreceive
#   - ackposts
#   - remind
#   - remind-globally
#   - conceal
#   - rcvtopic
#   - nodupes
#   - nodupes-globally

# most routines will be identical, so generate them:
{
    my %options = (
        address  => 'change-of-address',
        unsub    => 'unsub',
        changepw => 'changepw',
        options  => 'options-submit',
    );
    while ( my ( $method, $button ) = each %options ) {
        no strict 'refs';
        *$method = sub {
            my ( $self, $options ) = @_;

            # select the options form
            my $mech = $self->robot;
            $self->_load_uri(
                $self->_uri_for( 'options', $self->email || '' ) );
            $mech->form_with_fields('fullname');

            # change of options
            if ($options) {
                $mech->set_fields(%$options);
                $mech->click($button);
                $mech->form_with_fields('fullname');
            }

            return _form_data( $mech->current_form );
        };
    }
}

# emailpw doesn't need any parameter
sub emailpw {
    my ($self) = @_;

    # no auto-authenticate
    my $mech = $self->robot;
    $mech->get( my $uri = $self->_uri_for( 'options', $self->email ) );

    if ( $mech->form_with_fields('emailpw') ) {
        $mech->click('emailpw');
    }
    elsif ( $mech->form_with_fields('login-remind') ) {
        $mech->click('login-remind');
    }
    else {
        croak "Unable to find a password email form on $uri";
    }
}

# othersubs needs some parsing to be useful
sub othersubs {
    my ($self) = @_;
    my $mech = $self->robot;
    $self->_load_uri( $self->_uri_for( 'options', $self->email ) );
    $mech->form_with_fields('fullname');
    $mech->click('othersubs');

    my $uri = $mech->uri;
    return
        map { URI->new_abs( $_, $uri ) }
        $mech->content =~ m{[^<]+}g;
}

sub roster {
    my ($self) = @_;
    my $mech = $self->robot;
    $self->_load_uri( $self->_uri_for('roster') );

    # try to detect authentication issues [private_roster]
    if ( $mech->content !~ // ) {

        # authenticate through listinfo
        $mech->get( $self->_uri_for('listinfo') );
        my $form = $mech->form_with_fields('roster-pw');

        # in case the roster is reserved to admins,
        # we'll try the admin passwords first
        my $password = $self->admin_password || $self->moderator_password;
        $mech->set_fields( 'roster-email' => $self->email ) if !$password;
        $mech->set_fields( 'roster-pw' => $password || $self->password );
        $mech->click('SubscriberRoster');
    }

    # subscriber list may be empty, e.g. for privacy reasons
    return

        # TODO: distinguishes types of subscribers
        map { s/ at /@/; $_ }    # [obscure_addresses]
        $mech->content =~ m{]*>([^<]*)}g;
}

# most admin routines will be identical...
sub admin {
    my ( $self, $section, $options ) = @_;
    my $mech = $self->robot;
    $self->_load_uri( $self->_uri_for( admin => $section ) );

    # get the main form
    $mech->form_number(1);

    # change of options
    if ($options) {
        $mech->current_form->accept_charset('iso-8859-1');
        $mech->set_fields(%$options);
        $mech->click();
        $mech->form_number(1);
    }

    return _form_data( $mech->current_form );
}

# so, use a bit of currying
for my $section (
    qw(
    general passwords language nondigest digest
    bounce archive gateway autoreply contentfilter topics
    )
    )
{
    no strict 'refs';
    *{"admin_$section"} = sub { shift->admin( "$section", @_ ) }
}

sub version {
    my ($self) = @_;
    return $self->{version} if exists $self->{version};

    # get it as part of a page download
    $self->_load_uri( $self->_uri_for('listinfo') );
    return $self->{version};
}

1;

__END__