File Coverage

blib/lib/TestLink/API.pm

Criterion	Covered	Total	%
statement	22	24	91.6
branch			n/a
condition			n/a
subroutine	8	8	100.0
pod			n/a
total	30	32	93.7

# ABSTRACT: Provides an interface to TestLink's XMLRPC api via HTTP
# PODNAME: TestLink::API

package TestLink::API;
$TestLink::API::VERSION = '0.011';

use 5.010;
use strict;
use warnings;
use Carp;
use Scalar::Util qw{reftype looks_like_number}; #boo, some functions return hashes and arrays depending on # of results (1 or many)
use Data::Validate::URI 'is_uri';

use Clone 'clone';

use XMLRPC::Lite;


sub new {
    my ($class,$apiurl,$apikey) = @_;
    confess("Constructor must be called statically, not by an instance") if ref($class);
    $apiurl ||= $ENV{'TESTLINK_SERVER_ADDR'};
    $apikey ||= $ENV{'TESTLINK_API_KEY'};

    confess("No API key provided.") if !$apiurl;
    confess("No API URL provided.") if !$apikey;
    confess("API URL provided not valid.") unless is_uri($apiurl);

    my $self = {
        apiurl           => $apiurl,
        apikey           => $apikey,
        testtree         => [],
        flattree         => [],
        invalidate_cache => 1 #since we don't have a cache right now... #TODO this should be granular down to project rather than global
    };

    bless $self, $class;
    return $self;
}


#EZ get/set of obj vars
sub AUTOLOAD {
    my %public_elements = map {$_,1} qw{apiurl apikey}; #Public element access
    our $AUTOLOAD;

    if ($AUTOLOAD =~ /::(\w+)$/ and exists $public_elements{$1} ) {
        my $field = $1;
        {
            no strict 'refs';
            *{$AUTOLOAD} = sub {
                confess("Object parameters must be called by an instance") unless ref($_[0]);
                return $_[0]->{$field} unless defined $_[1];
                $_[0]->{$field} = $_[1];
                return $_[0];
            };
        }
        goto &{$AUTOLOAD};
    }
    confess("$AUTOLOAD not accessible property") unless $AUTOLOAD =~ /DESTROY$/;
}


sub createTestPlan {
    my ($self,$name,$project,$notes,$active,$public) = @_;
    confess("Object parameters must be called by an instance") unless ref($self);

    confess("Desired Test Plan Name is a required argument (0th).") if !$name;
    confess("Parent Project Name is a required argument (1st).") if !$project;

    $notes  ||= 'res ipsa loquiter';
    $active ||= 1;
    $public ||= 1;

    my $input = {
        devKey          => $self->apikey,
        testplanname    => $name,
        testprojectname => $project,
        notes           => $notes,
        active          => $active,
        public         => $public
    };

    my $rpc = XMLRPC::Lite->proxy($self->apiurl);
    my $result = $rpc->call('tl.createTestPlan',$input);
    warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'};
    return $result->result->[0]->{'id'} if $result->result->[0]->{'id'};
    return 0;
}


sub createBuild {
    my ($self,$plan_id,$name,$notes) = @_;
    confess("Object parameters must be called by an instance") unless ref($self);
    confess("Plan ID must be integer") unless looks_like_number($plan_id);
    confess("Build name is a required argument (1st)") if !$name;
    $notes  ||= 'res ipsa loquiter';

    my $input = {
        devKey     => $self->apikey,
        testplanid => $plan_id,
        buildname  => $name,
        buildnotes => $notes
    };

    my $rpc = XMLRPC::Lite->proxy($self->apiurl);
    my $result = $rpc->call('tl.createBuild',$input);
    warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'};
    return $result->result->[0]->{'id'} if $result->result->[0]->{'id'};
    return 0;
}


sub createTestSuite {
    my ($self,$project_id,$name,$details,$parent_id,$order) = @_;
    confess("Object parameters must be called by an instance") unless ref($self);
    confess("Parent Project ID (arg 0) must be an integer") unless looks_like_number($project_id);
    confess("Name (arg 1) cannot be undefined") unless $name;

    $details ||= 'res ipsa loquiter';
    $order ||= -1;

    my $input = {
        devKey        => $self->apikey,
        testprojectid => $project_id,
        testsuitename => $name,
        details       => $details,
        parentid      => $parent_id,
        order         => $order
    };

    my $rpc = XMLRPC::Lite->proxy($self->apiurl);
    my $result = $rpc->call('tl.createTestSuite',$input);
    warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'};
    $self->{'invalidate_cache'} = 1 if $result->result->[0]->{'id'};
    return $result->result->[0]->{'id'} if $result->result->[0]->{'id'};
    return 0;
}


#XXX probably should not use
sub createTestProject {
    my ($self,$name,$case_prefix,$notes,$options,$active,$public) = @_;
    confess("Object parameters must be called by an instance") unless ref($self);
    $notes   //= 'res ipsa loquiter';
    $options //= {};
    $public  //= 1;
    $active  //= 1;

    my $input = {
        devKey          => $self->apikey,
        testprojectname => $name,
        testcaseprefix  => $case_prefix,
        notes           => $notes,
        options         => $options,
        active          => $active,
        public          => $public
    };

    my $rpc = XMLRPC::Lite->proxy($self->apiurl);
    my $result = $rpc->call('tl.createTestProject',$input);
    #XXX i'm being very safe (haha), there's probably a better check
    warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'};
    $self->{'invalidate_cache'} = 1 if $result->result->[0]->{'id'};
    return $result->result->[0]->{'id'} if $result->result->[0]->{'id'};
    return 0;

}


sub createTestCase {
    my ($self,$test_name,$test_suite_id,$test_project_id,$author_name,$summary,$steps,$preconditions,$execution,$order) = @_;
    confess("Object parameters must be called by an instance") unless ref($self);

    my $input = {
        devKey        => $self->apikey,
        testcasename  => $test_name,
        testsuiteid   => $test_suite_id,
        testprojectid => $test_project_id,
        authorlogin   => $author_name,
        summary       => $summary,
        steps         => $steps,
        preconditions => $preconditions,
        execution     => $execution,
        order         => $order
    };

    my $rpc = XMLRPC::Lite->proxy($self->apiurl);
    my $result = $rpc->call('tl.createTestCase',$input);
    #XXX i'm being very safe (haha), there's probably a better check
    warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'};
    return $result->result->[0] if $result->result->[0]->{'id'};
    return 0;

}


sub reportTCResult {
    my ($self,$case_id,$plan_id,$build_id,$status,$platform,$notes,$bugid) = @_;
    confess("Object parameters must be called by an instance") unless ref($self);

    my $input = {
        devKey     => $self->apikey,
        testcaseid => $case_id,
        testplanid => $plan_id,
        buildid    => $build_id,
        status     => $status,
        notes      => $notes,
        bugid      => $bugid
    };

    if (defined($platform) && !ref $platform) {
        if (looks_like_number($platform)) {
            $input->{'platformid'} = $platform;
        } else {
            $input->{'platformname'} = $platform;
        }
    }

    my $rpc = XMLRPC::Lite->proxy($self->apiurl);
    my $result = $rpc->call('tl.reportTCResult',$input);
    warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'};
    return $result->result->[0] unless $result->result->[0]->{'code'};
    return 0;
}


#XXX this should be able to be done in batch
sub addTestCaseToTestPlan {
    my ($self,$plan_id,$case_id,$project_id,$version,$platform,$order,$urgency) = @_;
    confess("Object parameters must be called by an instance") unless ref($self);

    my $input = {
        devKey             => $self->apikey,
        testplanid         => $plan_id,
        testcaseexternalid => $case_id,
        testprojectid      => $project_id,
        version            => $version,
        platformid         => $platform,
        executionorder     => $order,
        urgency            => $urgency
    };

    my $rpc = XMLRPC::Lite->proxy($self->apiurl);
    my $result = $rpc->call('tl.addTestCaseToTestPlan',$input);
    warn $result->result->{'message'} if $result->result->{'code'};
    return 1 unless $result->result->{'code'};
    return 0;
}


sub uploadExecutionAttachment {
   my ($self,$execution_id,$filename,$filetype,$content,$title,$description) = @_;
    confess("Object parameters must be called by an instance") unless ref($self);

    my $input = {
        devKey      => $self->apikey,
        executionid => $execution_id,
        title       => $title,
        description => $description,
        filename    => $filename,
        filetype    => $filetype,
        content     => $content
    };

    my $rpc = XMLRPC::Lite->proxy($self->apiurl);
    my $result = $rpc->call('tl.uploadExecutionAttachment',$input);
    warn $result->result->{'message'} if $result->result->{'code'};
    return 1 unless $result->result->{'code'};
    return 0;
}


sub uploadTestCaseAttachment {
   my ($self,$case_id,$filename,$filetype,$content,$title,$description) = @_;
    confess("Object parameters must be called by an instance") unless ref($self);

    my $input = {
        devKey      => $self->apikey,
        testcaseid  => $case_id,
        title       => $title,
        description => $description,
        filename    => $filename,
        filetype    => $filetype,
        content     => $content
    };

    my $rpc = XMLRPC::Lite->proxy($self->apiurl);
    my $result = $rpc->call('tl.uploadTestCaseAttachment',$input);
    warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'};
    return 1 unless $result->result->[0]->{'code'};
    return 0;
}



sub getProjects {
    my $self = shift;
    confess("Object parameters must be called by an instance") unless ref($self);

    my $input = {
        devKey     => $self->apikey
    };

    my $rpc = XMLRPC::Lite->proxy($self->apiurl);
    my $result = $rpc->call('tl.getProjects',$input);
    warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'};

    #Save state for future use, if needed
    if (!scalar(@{$self->{'testtree'}})) {
        $self->{'testtree'} = $result->result unless $result->result->[0]->{'code'};
    }

   if (!exists($result->result->[0]->{'code'})) {
        #Note that it's a project for future reference by recursive tree search
        for my $pj (@{$result->result}) {
            $pj->{'type'} = 'project';
        }
        return $result->result;
    }

    return 0;
}


sub getProjectByName {
    my ($self,$project) = @_;
    confess("Object parameters must be called by an instance") unless ref($self);
    confess "No project provided." unless $project;

    #See if we already have the project list...
    my $projects = $self->{'testtree'};
    $projects = $self->getProjects() unless scalar(@$projects);

    #Search project list for project
    for my $candidate (@$projects) {
        return $candidate if ($candidate->{'name'} eq $project);
    }

    return 0;
}


sub getProjectByID {
    my ($self,$project) = @_;
    confess("Object parameters must be called by an instance") unless ref($self);
    confess "No project provided." unless $project;

    #See if we already have the project list...
    my $projects = $self->{'testtree'};
    $projects = $self->getProjects() unless scalar(@$projects);

    #Search project list for project
    for my $candidate (@$projects) {
        return $candidate if ($candidate->{'id'} eq $project);
    }

    return 0;
}



sub getTLDTestSuitesForProject {
    my ($self,$project,$get_tests) = @_;
    confess("Object parameters must be called by an instance") unless ref($self);
    confess "No project ID provided." unless $project;

    my $input = {
        devKey        => $self->apikey,
        testprojectid => $project
    };

    my $rpc = XMLRPC::Lite->proxy($self->apiurl);
    my $result = $rpc->call('tl.getFirstLevelTestSuitesForTestProject',$input);

    #Error condition, return right away
    warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'};
    return [] if $result->result->[0]->{'code'};

    #Handle bizarre output
    if ($result->result && !(reftype($result->result) eq 'HASH' || reftype($result->result) eq 'ARRAY')) {
        return [];
    }
    return [] if !$result->result;

    #Handle mixed return type for this function -- this POS will return arrayrefs, and 2 types of hashrefs.
    my $res = [];
    $res = $result->result if reftype($result->result) eq 'ARRAY';
    @$res = values(%{$result->result}) if reftype($result->result) eq 'HASH' && !defined($result->result->{'id'});
    $res = [$result->result] if reftype($result->result) eq 'HASH' && defined($result->result->{'id'});
    return [] if (!scalar(keys(%{$res->[0]}))); #Catch bizarre edge case of blank hash being only thing there

    if ($get_tests) {
        for (my $i=0; $i < scalar(@{$result->result}); $i++) {
            $result->result->[$i]->{'tests'} = $self->getTestCasesForTestSuite($result->result->[$i]->{'id'},0,1);
        }
    }

    return $result->result;
}


sub getTestSuitesForTestSuite {
    my ($self,$tsid,$get_tests) = @_;
    confess("Object parameters must be called by an instance") unless ref($self);
    confess "No TestSuite ID provided." unless $tsid;

    my $input = {
        devKey        => $self->apikey,
        testsuiteid => $tsid
    };

    my $rpc = XMLRPC::Lite->proxy($self->apiurl);
    my $result = $rpc->call('tl.getTestSuitesForTestSuite',$input);

    #Handle bizarre output
    if ($result->result && !(reftype($result->result) eq 'HASH' || reftype($result->result) eq 'ARRAY')) {
        return [];
    }
    return [] if !$result->result;

    #Handle mixed return type for this function -- this POS will return arrayrefs, and 2 types of hashrefs.
    my $res = [];
    $res = $result->result if reftype($result->result) eq 'ARRAY';
    @$res = values(%{$result->result}) if reftype($result->result) eq 'HASH' && !defined($result->result->{'id'});
    $res = [$result->result] if reftype($result->result) eq 'HASH' && defined($result->result->{'id'});

    if ($get_tests) {
        foreach my $row (@$res) {
            $row->{'tests'} = $self->getTestCasesForTestSuite($row->{'id'},0,1);
        }
    }

    #Error condition, return false and don't bother searching arrays
    warn $res->{'message'} if $res->[0]->{'code'};
    return [] if $res->[0]->{'code'};
    return $res;
}



sub getTestSuitesByName {
    my ($self,$project_id,$testsuite_name,$do_regex) = @_;
    confess("Object parameters must be called by an instance") unless ref($self);
    return 0 if (!$project_id || !$testsuite_name); #GIGO

    #use caching methods here to speed up subsequent calls
    $self->_cacheProjectTree($project_id,1,1,0) if $self->{'invalidate_cache'};

    #my $tld = $self->getTLDTestSuitesForProject($project_id);
    my $candidates = [];

    #Walk the whole tree.  No other way to be sure.
    foreach my $ts (@{$self->{'flattree'}}) {
        if ($do_regex) {
            push(@$candidates,$ts) if $ts->{'name'} =~ $testsuite_name;
        } else {
            push(@$candidates,$ts) if $ts->{'name'} eq $testsuite_name;
        }
    }
    return $candidates;

}


sub getTestSuiteByID {
    my ($self,$testsuite_id) = @_;
    confess("Object parameters must be called by an instance") unless ref($self);

    my $input = {
        devKey      => $self->apikey,
        testsuiteid => $testsuite_id
    };

    my $rpc = XMLRPC::Lite->proxy($self->apiurl);
    my $result = $rpc->call('tl.getTestSuiteByID',$input);
    warn $result->result->{'message'} if $result->result->{'code'};
    return $result->result unless $result->result->{'code'};
    return 0;
}


sub getTestCasesForTestSuite {
    my ($self,$testsuite_id,$deep,$details) = @_;
    confess("Object parameters must be called by an instance") unless ref($self);

    $details = 'full' if $details;

    my $input = {
        devKey      => $self->apikey,
        testsuiteid => $testsuite_id,
        deep        => $deep,
        details     => $details
    };

    my $rpc = XMLRPC::Lite->proxy($self->apiurl);
    my $result = $rpc->call('tl.getTestCasesForTestSuite',$input);
    return [] if !$result->result;

    return [] if !scalar(keys(%{$result->result->[0]})); # No tests

    warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'};
    return $result->result unless $result->result->[0]->{'code'};
    return [];
}


sub getTestCaseByExternalId {
    my ($self,$case_id,$version) = @_;
    confess("Object parameters must be called by an instance") unless ref($self);

    my $input = {
        devKey             => $self->apikey,
        testcaseexternalid => $case_id,
        version            => $version
    };

    my $rpc = XMLRPC::Lite->proxy($self->apiurl);
    my $result = $rpc->call('tl.getTestCase',$input);
    warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'};
    return $result->result->[0] unless $result->result->[0]->{'code'};
    return 0;
}


sub getTestCaseById {
    my ($self,$case_id,$version) = @_;
    confess("Object parameters must be called by an instance") unless ref($self);

    my $input = {
        devKey     => $self->apikey,
        testcaseid => $case_id,
        version    => $version
    };

    my $rpc = XMLRPC::Lite->proxy($self->apiurl);
    my $result = $rpc->call('tl.getTestCase',$input);
    warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'};
    return $result->result->[0] unless $result->result->[0]->{'code'};
    return 0;
}


sub getTestCaseByName {
    my ($self, $casename, $suitename, $projectname, $testcasepathname) = @_;
    confess("Object parameters must be called by an instance") unless ref($self);

    my $input = {
        devKey           => $self->apikey,
        testcasename     => $casename,
        testsuitename    => $suitename,
        testprojectname  => $projectname,
        testcasepathname => $testcasepathname
    };

    my $rpc = XMLRPC::Lite->proxy($self->apiurl);
    my $result = $rpc->call('tl.getTestCaseIDByName',$input);
    warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'};
    return $result->result->[0] unless $result->result->[0]->{'code'};
    return 0;
}


sub getTestCaseAttachments {
    my ($self, $case_ext_id) = @_;
    confess("Object parameters must be called by an instance") unless ref($self);

    my $input = {
        devKey     => $self->apikey,
        testcaseexternalid => $case_ext_id,
    };

    my $rpc = XMLRPC::Lite->proxy($self->apiurl);
    my $result = $rpc->call('tl.getTestCaseAttachments',$input);
    return 0 if (!$result->result);
    warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'};
    return $result->result->[0] unless $result->result->[0]->{'code'};
    return 0;
}


sub getTestPlansForProject {
    my ($self,$project_id) = @_;
    confess("Object parameters must be called by an instance") unless ref($self);

    my $input = {
        devKey        => $self->apikey,
        testprojectid => $project_id
    };

    my $rpc = XMLRPC::Lite->proxy($self->apiurl);
    my $result = $rpc->call('tl.getProjectTestPlans',$input);
    warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'};
    return $result->result unless $result->result->[0]->{'code'};
    return 0;
}


# I find it highly bizarre that the only 'by name' method exists for test plans, and it's the only test plan getter.
sub getTestPlanByName {
    my ($self,$plan_name,$project_name) = @_;
    confess("Object parameters must be called by an instance") unless ref($self);

    my $input = {
        devKey          => $self->apikey,
        testplanname    => $plan_name,
        testprojectname => $project_name
    };

    my $rpc = XMLRPC::Lite->proxy($self->apiurl);
    my $result = $rpc->call('tl.getTestPlanByName',$input);
    warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'};
    return $result->result->[0] unless $result->result->[0]->{'code'};
    return 0;
}


sub getBuildsForTestPlan {
    my ($self,$plan_id) = @_;
    confess("Object parameters must be called by an instance") unless ref($self);

    my $input = {
        devKey          => $self->apikey,
        testplanid      => $plan_id
    };

    my $rpc = XMLRPC::Lite->proxy($self->apiurl);
    my $result = $rpc->call('tl.getBuildsForTestPlan',$input);
    warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'};
    return $result->result unless $result->result->[0]->{'code'};
    return 0;
}


sub getTestCasesForTestPlan {
   my ($self,$plan_id) = @_;
   confess("Object parameters must be called by an instance") unless ref($self);

    my $input = {
        devKey          => $self->apikey,
        testplanid      => $plan_id
    };

    my $rpc = XMLRPC::Lite->proxy($self->apiurl);
    my $result = $rpc->call('tl.getTestCasesForTestPlan',$input);
    warn $result->result->{'message'} if $result->result->{'code'};
    return $result->result unless $result->result->{'code'};
    return 0;
}


sub getLatestBuildForTestPlan {
    my ($self,$plan_id) = @_;
    confess("Object parameters must be called by an instance") unless ref($self);

    my $input = {
        devKey     => $self->apikey,
        tplanid    => $plan_id, #documented arg, but that's LIES, apparently it wants the next one
        testplanid => $plan_id
    };

    my $rpc = XMLRPC::Lite->proxy($self->apiurl);
    my $result = $rpc->call('tl.getLatestBuildForTestPlan',$input);

    #Handle mixed return type
    my $res = $result->result;
    $res = [$res] if reftype($res) eq 'HASH';

    warn $res->[0]->{'message'} if $res->[0]->{'code'};
    return $res->[0] unless $res->[0]->{'code'};
    return 0;
}


#TODO cache stuff, don't require proj id?
sub getBuildByName {
    my ($self,$build_name,$project_id) = @_;
    confess("Object parameters must be called by an instance") unless ref($self);

    my $plans = $self->getTestPlansForProject($project_id);
    for my $plan (@$plans) {
        my $builds = $self->getBuildsForTestPlan($plan->{'id'});
        for my $build (@$builds) {
            return $build if $build->{'name'} eq $build_name;
        }
    }
    return 0;
}


sub getTotalsForTestPlan {
    my ($self,$plan_id) = @_;
    confess("Object parameters must be called by an instance") unless ref($self);

    my $input = {
        devKey     => $self->apikey,
        tplanid    => $plan_id, #documented arg, but that's LIES, apparently it wants the next one
        testplanid => $plan_id
    };

    my $rpc = XMLRPC::Lite->proxy($self->apiurl);
    my $result = $rpc->call('tl.getTotalsForTestPlan',$input);

    warn $result->result->{'message'} if $result->result->{'code'};
    return $result->result unless $result->result->{'code'};
    return 0;
}


sub dump {
    my ($self,$project,$attachment,$flat) = @_;
    confess("Object parameters must be called by an instance") unless ref($self);
    confess("Getting attachments not yet implemented") if $attachment;

    my $res = $self->_cacheProjectTree($project,$flat);
    return [] if !$res;

    return $res if !$project || $flat;
    foreach my $pj (@{$res}) {
        return $pj if $pj->{'name'} eq $project;
    }
    croak "COULD NOT DUMP, SOMETHING HORRIBLY WRONG";
}

sub _cacheProjectTree {
    my ($self,$project,$flat,$use_project_id,$get_tests) = @_;
    confess("Object parameters must be called by an instance") unless ref($self);

    $flat //= 0;
    $use_project_id //= 0;
    $get_tests //= 1;

    #Cache Projects
    if (!scalar(@{$self->{'testtree'}})) {
        $self->getProjects();
    }

    my @flattener = @{$self->{'testtree'}};

    for my $projhash (@flattener) {
        if ($use_project_id) {
            next if $project && $project ne $projhash->{'id'} && (defined($projhash->{'type'}) && $projhash->{'type'} eq 'project');
        } else {
            next if $project && $project ne $projhash->{'name'} && (defined($projhash->{'type'}) && $projhash->{'type'} eq 'project');
        }

        #If TestSuites are not defined, this must be a TS which we have not traversed yet, so go and get it
        if (exists($projhash->{'type'}) && $projhash->{'type'} eq 'project') {
            $projhash->{'testsuites'} = $self->getTLDTestSuitesForProject($projhash->{'id'},$get_tests);
        } else {
            $projhash->{'testsuites'} = $self->getTestSuitesForTestSuite($projhash->{'id'},$get_tests);
        }

        $projhash->{'testsuites'} = [] if !$projhash->{'testsuites'};
        for my $tshash (@{$projhash->{'testsuites'}}) {
            #Otherwise, push it's children to the end of our array so we can recurse as needed.
            #I hope the designers of TL's schema were smart enough to not allow self-referential or circular suites..
            push(@flattener,clone $tshash);
        }

    }

    #Keep this for simple searches in the future.
    $self->{'flattree'} = clone \@flattener;
    return $self->{'flattree'} if $flat;
    return $self->_expandTree($project,@flattener);
}

sub _expandTree {
    my $self = shift;
    confess("Object parameters must be called by an instance") unless ref($self);
    my $project = shift;
    my @flattener = @_;
    #The following algorithm relies implicitly on pass-by-reference.
    #So we have a flat array of testsuites we want to map into parent-child relationships.
    my ($i,$j);
    foreach my $suite (@flattener) {
        if (defined($suite->{'type'}) && $suite->{'type'} eq 'project') {
            #Then skip it, since it's not a suite.
            shift @flattener;
            next;
        }

        #This means we need to walk the hierarchy of every project, or just the one we passed
        for ($j=0; $j < scalar(@{$self->{'testtree'}}); $j++) {
            #If we have a project, skip the other ones
            next unless $project && $self->{'testtree'}->[$j]->{'name'} eq $project;

            #Get the ball rolling if we have to
            $self->{'testtree'}->[$j]->{'testsuites'} = $self->getTLDTestSuitesForProject($self->{'testtree'}->[$j]->{'id'},1) if !defined($self->{'testtree'}->[$j]->{'testsuites'});

            #So, let's tail recurse over the testsuites.
            for ($i=0; $i < scalar(@{$self->{'testtree'}->[$j]->{'testsuites'}}); $i++) {
                my $tailRecurseTSWalker = sub  {
                    my ($ts,$desired_ts) = @_;

                    #Mark it down if we found it
                    if ($ts->{'id'} eq $desired_ts->{'parent_id'}) {

                        #Set the REF's 'testsuites' param, and quit searching
                        $ts->{'testsuites'} = [] if !defined($ts->{'testsuites'});
                        push(@{$ts->{'testsuites'}},$desired_ts);
                        $desired_ts->{'found'} = 1;
                        return;
                    }

                    #If there's already (nonblank) hierarchy in the passed TS, then WE HAVE TO GO DEEPER
                    if (defined($ts->{'testsuites'}) && scalar(@{$desired_ts->{'testsuites'}})) {
                        for (my $i=0; $i < scalar(@{$ts->{'testsuites'}}); $i++) {
                            _tailRecurseTSWalker($ts->{'testsuites'}->[$i],$desired_ts);
                        }
                    }

                    return;
                };

                &$tailRecurseTSWalker($self->{'testtree'}->[$j]->{'testsuites'}->[$i],$suite);
                #OPTIMIZE: break out if we found it already
                last if $suite->{'found'};
            }
            last if $suite->{'found'};
        }

        #If we didn't find this one yet, as the hierarchy build is progressive, add it to the end until it gets picked up.
        if (!$suite->{'found'}) {
            push(@flattener,shift @flattener); # If it wasn't found, push it on to the end of the array so the walk might find it next time.
        } else {
            shift @flattener;
        }
    }
    return $self->{'testtree'};
}

1;

__END__