view release on metacpan or  search on metacpan

t/Elive.pm  view on Meta::CPAN

package t::Elive;
use warnings; use strict;

=head1 NAME

t::Elive

=head1 DESCRIPTION

Testing support package for Elive

=cut

=head2 auth

locate test authorization from the environment

=cut

use URI;

sub test_connection {
    my $class = shift;
    my %opt = @_;

    my $suffix = $opt{suffix} || '';
    my %result;

    my $user = $ENV{'ELIVE_TEST_USER'.$suffix};
    my $pass = $ENV{'ELIVE_TEST_PASS'.$suffix};
    my $url  = $ENV{'ELIVE_TEST_URL'.$suffix};

    if (!$opt{only} || $opt{only} eq 'real') {

	if ($url) {
	    my $uri_obj = URI->new($url, 'http');
	    my $userinfo = $uri_obj->userinfo; # credentials supplied in URI

	    if ($userinfo) {
		my ($uri_user, $uri_pass) = split(':', $userinfo, 2);
		$user ||= URI::Escape::uri_unescape($uri_user);
		$pass ||= URI::Escape::uri_unescape($uri_pass)
		    if $uri_pass;
	    }

	    if ($user && $pass && $url !~ m{^mock:}i) {

		if ($url =~ m{/v[1-9\.]+(/(webservice\.event)?)?$}) {
		    $result{reason} = '$ELIVE_TEST_URL path is SAS specific ([/instance]/vN[/webservice.event])';
		}
		else {

		    $result{auth} = [$url, $user, $pass];

		    unless ($opt{noload}) {
			#
			# don't give our test a helping hand, We're
			# testing self load of this module by Elive
			#
			eval {require Elive::Connection::SDK}; die $@ if $@;
		    }
		    $result{class} = 'Elive::Connection::SDK';
		}
	    }
	}
	else {
	    $result{reason} = 'skipping live tests (set $ELIVE_TEST_URL'.$suffix.' to enable)';
	}
    }

    if (!$result{auth} && (!$opt{only} || $opt{only} eq 'mock')) {

	if ($opt{only} && $opt{only} eq 'mock') {
	    delete $result{reason};
	}

	unless ($user && $pass && $url && $url =~ m{^mock:}i) {

	    $user = 'test_user'.$suffix;
	    $pass = 'test_pass'.$suffix;
	    $url  = 'mock://elive_test_connection'.$suffix;
	}

	$result{auth} = [$url, $user, $pass];
	eval {require t::Elive::MockConnection}; die $@ if $@;
	$result{class} = 't::Elive::MockConnection';
    }

    if ($result{auth}) {

	foreach (@{ $result{auth} }) {
	    #
	    # untaint
	    #
	    m{(.*)};
	    $_ = $1;
	}