File Coverage

blib/lib/Test/WWW/Mechanize/MultiMech.pm

Criterion	Covered	Total	%
statement	18	116	15.5
branch	0	40	0.0
condition			n/a
subroutine	6	17	35.2
pod	7	7	100.0
total	31	180	17.2

package Test::WWW::Mechanize::MultiMech;

use 5.006;
use strict;
use warnings FATAL => 'all';

our $VERSION = '1.006001'; # VERSION

use Test::WWW::Mechanize;
use Test::Builder qw//;
use Carp qw/croak/;

sub _diag {
    Test::Builder->new->diag(@_);
}

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

    ref $args{users} eq 'ARRAY'
        or croak 'You must give ``users\'\' to new->new(); '
                . 'and it needs to be an arrayref';

    my @args_users = @{ delete $args{users} };
    my ( %users, @users_order );
    for ( grep !($_%2), 0 .. $#args_users ) {
        my $user_args = $args_users[ $_+1 ];

        push @users_order, $args_users[ $_ ];

        my $mech = Test::WWW::Mechanize->new( %args );
        $users{ $args_users[$_] } = {
            login   => (
                defined $user_args->{login}
                ? $user_args->{login} : $args_users[ $_ ]
            ),
            pass    => $user_args->{pass},
            mech    => $mech,
        };
    }

    my $self = bless {}, $class;
    $self->{USERS}       = \%users;
    $self->{USERS_ORDER} = \@users_order;
    $self->{MECH_ARGS}   = \%args;
    return $self;
}

sub _mech {
    my $self = shift;
    my ( $any_user ) = grep !$self->{IGNORED_USERS}{$_},
        @{$self->{USERS_ORDER}};

    $any_user
        or croak q{Didn't find any available users when getting any}
            . q{ user's mech object.};

    return $self->{USERS}{ $any_user }{mech};
}

sub login {
    my ( $self, %args ) = @_;

    my $page = delete $args{login_page};
    eval {
        $page = $self->_mech->uri
            unless defined $page;
    };
    if ( $@ ) {
        croak 'You did not give ->login() a page and mech did not yet'
        . ' access any pages. Cannot proceed further';
    }

    my $users = $self->{USERS};
    for my $alias (
        grep !$self->{IGNORED_USERS}{$_}, @{$self->{USERS_ORDER}}
    ) {
        my $mech = $users->{ $alias }{mech};

        $mech->get_ok(
            $page,
            "[$alias] get_ok($page)",
        );

        my $user_args = { %args };
        if ( $user_args->{fields} ) {
            $user_args->{fields} = {%{ $user_args->{fields} }};
        }

        for ( values %{ $user_args->{fields} || {} } ) {
            next unless ref eq 'SCALAR';
            if ( $$_ eq 'LOGIN'   ) { $_ = $users->{ $alias }{login}; }
            elsif ( $$_ eq 'PASS' ) { $_ = $users->{ $alias }{pass};  }
        }

        $mech->submit_form_ok(
            $user_args,
            "[$alias] Submitting login form",
        );
    }
}

sub AUTOLOAD {
    my ( $self, @args ) = @_;

    local $Test::Builder::Level = $Test::Builder::Level + 1;

    our $AUTOLOAD;
    my $method = (split /::/, $AUTOLOAD)[-1];
    return if $method eq 'DESTROY';

    if ( $self->_mech->can($method) ) {
        return $self->_call_mech_method_on_each_user( $method, \@args );
    }
    elsif ( grep $_ eq $method, @{ $self->{USERS_ORDER} } ) {
        my $alias = $method;
        _diag "[$alias]-only call";
        return $self->{USERS}{ $alias }{mech};
    }
    elsif ( $method eq 'any' ) {
        _diag "[any] call";
        return $self->_mech;
    }

    croak qq|Can't locate object method "$method" via package |
        . __PACKAGE__;
}

sub _call_mech_method_on_each_user {
    my ( $self, $method, $args ) = @_;

    local $Test::Builder::Level = $Test::Builder::Level + 1;

    my %returns;
    for my $alias (
        grep !$self->{IGNORED_USERS}{$_}, @{$self->{USERS_ORDER}}
    ) {
        _diag("\n[$alias] Calling ->$method()\n");
        $returns{ $alias }
        = $self->{USERS}{ $alias }{mech}->$method( @$args );
    }

    $returns{any} = (values %returns)[0];
    return \%returns;
}

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

    return unless exists $self->{USERS}{ $alias };

    @{ $self->{USERS_ORDER} }
    = grep $_ ne $alias, @{ $self->{USERS_ORDER}  };

    my $args = delete $self->{USERS}{ $alias };

    croak 'You must have at least one user and you '
        . 'just removed the last one'
        unless @{ $self->{USERS_ORDER}  };

    return ( $alias, $args );
}

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

    my $mech = Test::WWW::Mechanize->new( %{ $self->{MECH_ARGS} } );

    $self->{USERS}{ $alias } = {
        %{ $args || {} },
        mech => $mech,
    };

    @{ $self->{USERS_ORDER} } = (
        ( grep $_ ne $alias, @{ $self->{USERS_ORDER} } ),
        $alias,
    );

    return;
}

sub all_users {
    my $self = shift;
    my $is_include_ignored = shift;
    return $is_include_ignored
        ? @{ $self->{USERS_ORDER} }
        : grep !$self->{IGNORED_USERS}{ $_ }, @{ $self->{USERS_ORDER} };
}

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

    return unless exists $self->{USERS}{ $alias };

    $self->{IGNORED_USERS}{ $alias } = 1;
    if ( keys %{$self->{IGNORED_USERS}} eq @{ $self->{USERS_ORDER} } ){
        croak q{You ignored all your users. Can't function without at least
            one active user};
    }
}

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

    delete $self->{IGNORED_USERS}{ $alias };
}

q|
Why programmers like UNIX: unzip, strip, touch, finger, grep, mount, fsck,
    more, yes, fsck, fsck, fsck, umount, sleep
|;
__END__