Example TestLink XMLRPC Clients in Perl

There are not many good examples floating around of Perl clients for TestLink’s XMLRPC API. There are two examples included with the 1.9.3 source, but they are very brief. I wrote two scripts to support a first-blush attempt at automated test running, and while they will get a lot more refinement over time, I thought abstracted versions of them might be beneficial for others trying to write Perl clients (or in any language – they perl samples were so sparse I largely based my script on the python example).

Test Runner

The first script is an example test runner, run-testplan-simple.pl, which can be found at https://github.com/jetmore/TestLink-Misc/blob/master/scripts/run-testplan-simple.pl or inline and collapsed at the end of this post. In terms of a full-featured test runner this is still pretty sparse, but it has some string points as an example:

A demonstration of several more API methods than the standard perl example script
An attempt at a reusable error checking function for api responses
A method for storing external test information in test cases
Example of posting results back to TestLink via tl.reportTCResult

Based on the amount of Google hits I’ve seen on other TestLink posts I’ve made, it looks like the usage information for tl.reportTCResult will be useful for people.

In my opinion the most useful thing in this script is the generalized error checking. The TestLink API is a mess in terms of standardized responses. There’s no “this is an error response” flag, so you have to determine errors heuristically, which is less than ideal. The isResponseError() function is my attempt to identify as many failure conditions as possible in one function.

The variables $testServer, $APIKey, and $projectName at the top of the script need to be uncommented and populated with the appropriate values. An API Key for your TestLink install can be generated from your user page in the TestLink UI.

Test Reporter

The second script is a reporter. Because we are in very early stages of implementing automated testing, we have many tests that are blocking (we wrote tests for functionality that isn’t implemented yet, and I chose to register that as a blocked test case in TestLink). So, at the moment, individual test case status is not very interesting to me. What is interesting is changes in status. If a test passed two nights ago, but blocked last night, I want to know about it.

I wrote get-testplan-status.pl (https://github.com/jetmore/TestLink-Misc/blob/master/scripts/get-testplan-status.pl) to do this reporting for me. This script is largely similar to run-testplan-simple.pl above, but it is a read-only script, which might make it more interesting for initial exploring.

This script also makes use of the non-standard API call getExecutionResults(). I wrote this new interface to allow more than one result to be returned for a test case. See https://www.jetmore.org/john/blog/2012/03/missing-testlink-api-function-getexecutionresults/ for more details on the function, including the code itself.

As with run-testplan-simple.pl, the variables $testServer, $APIKey, and $projectName at the top of the script need to be uncommented and populated with the appropriate values.

Code

The code for these two scripts at the time I wrote this post is included inline below, hopefully minimized…

run-testplan-simple.pl

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

311

312

313

314

315

316

317

318

319

320

321

322

323

324

325

326

327

328

329

330

331

332

333

334

335

336

337

338

339

#!/usr/bin/perl
 
# This is a sanitized version of the "nightly test runner" I bashed up for my company.
# It is very unlikely to be usable verbatim, but it shows some fundamental concepts:
#   - how to interact w/ TestLink XMLRPC api with a perl client
#   - an attempt at an error checking function for api responses
#   - a method for storing external test information in test cases
#   - how to post results back to TestLink
 
# -- John Jetmore, 2012
 
# yum install perl-Crypt-SSLeay
# yum install perl-RPC-XML
# http://www.softwaretestingconcepts.com/test-automation-using-testlink-xmlrpc-api-steps-and-sample-python-client-program
# http://search.cpan.org/~rjray/RPC-XML-0.71/
# http://jetmore.org/john/misc/phpdoc-testlink193-api/TestlinkAPI/TestlinkXMLRPCServer.html
 
use strict;
 
use RPC::XML;
use RPC::XML::Client;
use Data::Dumper;
 
# !!! You have to change all three of these to valid local settings to get this to work:
#my $testServer  = 'https://localhost/testlink/lib/api/xmlrpc.php';
#my $APIKey      = 'PUT_YOUR_API_ACCESS_KEY_IN_HERE';
#my $projectName = 'PUT_THE_NAME_OF_YOUR_PROJECT_HERE';
 
 
my $resp;
my $method;
my $options;
my $log      = -t STDIN ? 1 : 0; # only log if we're being run via a term
my %statuses = ('passed' => 'p', 'failed' => 'f', 'blocked' => 'b');
 
my $planName    = shift || die "Need Test Plan name to continue\n";
 
my $client = RPC::XML::Client->new($testServer);
 
#############
# Confirm test plan exists, get planID
$resp = $client->send_request('tl.getTestPlanByName', {
    'devKey' => $APIKey, 'testprojectname' => $projectName, testplanname => $planName
});
if (isResponseError($resp)) {
    die "An error occurred in getTestPlanByName ($main::apiLastResponseCode): $main::apiLastResponseString\n";
}
#print Dumper($resp); # uncomment to see what the raw response looks like
my $projectID = $resp->value->[0]{testproject_id};
my $planID    = $resp->value->[0]{id};
print "Found planID = $planID, projectID = $projectID\n" if ($log);
 
 
############
# This just picks the first build returned and uses it.  Errors if no build available
# for test plan.
$resp = $client->send_request('tl.getBuildsForTestPlan', {
    'devKey' => $APIKey, 'testplanid' => $planID
});
if (isResponseError($resp)) {
    die "An error occurred in getBuildsForTestPlan ($main::apiLastResponseCode): $main::apiLastResponseString\n";
}
#print Dumper($resp); # uncomment to see what the raw response looks like
my $buildID = $resp->value->[0]{id};
print "Found buildID = $buildID\n" if ($log);
 
 
###############
# Get all available test plan platforms.  This is kind of simple right now.  For now, if test runner is on linux, we will run
# any test case assigned to a plan with "Linux" in it, and same with Windows.  In future we probably want to filter
# on specific os releases and architectures
$resp = $client->send_request('tl.getTestPlanPlatforms', {
    'devKey' => $APIKey, 'testplanid' => $planID
});
if (isResponseError($resp)) {
    die "An error occurred in getTestPlanPlatforms ($main::apiLastResponseCode): $main::apiLastResponseString\n";
}
#print Dumper($resp); # uncomment to see what the raw response looks like
my %platformInfo = ();
# This heuristic was specific to my company's use.  Tailor to taste.
foreach my $platform (@{$resp->value()}) {
    if ($^O eq 'linux' && ($platform->{name} =~ /\bCentOS\b/i || $platform->{name} =~ /\bLinux\b/i)) {
        %platformInfo = %$platform;
        last;
    }
    elsif ($^O eq 'windows' && $platform->{name} =~ /\bWindows\b/i) {
        %platformInfo = %$platform;
        last;
    }
}
if (!$platformInfo{id}) {
    die "No available platform matched current platform\n" .
        "Current: $^O\n" .
        "Available: \n" . Dumper($resp->value());
}
print "Found platform = $platformInfo{id}, $platformInfo{name}\n" if ($log);
 
 
#################
# Now get all test cases in the test plan.
$resp = $client->send_request('tl.getTestCasesForTestPlan', {
    'devKey' => $APIKey, 'testplanid' => $planID,
});
if (isResponseError($resp)) {
    die "An error occurred in getTestCasesForTestPlan ($main::apiLastResponseCode): $main::apiLastResponseString\n";
}
#print Dumper($resp); # uncomment to see what the raw response looks like
my $respData  = $resp->value();
my %testCases = ();
# manually filter the test cases in the test plan against our currently selected platform
foreach my $caseID (keys %$respData) {
    foreach my $platformID (keys %{$respData->{$caseID}}) {
        if ($platformID eq $platformInfo{id} && $respData->{$caseID}{$platformID}{active} == 1) {
            $testCases{$caseID}{$platformID} = $respData->{$caseID}{$platformID};
        }
    }
}
#print Dumper(\%testCases);
print "Found ", scalar(keys(%testCases)), " test cases to run\n" if ($log);
 
 
###########################
# Now we loop and execute
foreach my $caseID (keys %testCases) {
     
    # As far as I can tell there's no real standard for how external test information is stored
    # in a testlink testcase.  We chose to pursue:
    #   1) 1 external test script per test case
    #   2) external test "configs" are stored in the testcase's "summary" field
    #   3) configs are:
    #       - one config per line
    #       - line format is KEY: VALUE
    #   4) Specific keys:
    #       - TestScript - complete path, including executable, of external test script
    #       - TestScriptOptions - Any command line options for TestScript
    #       - TestType - free text right now, but allow us a way to tell the test executor to run
    #                    different tests
    foreach my $platformID (keys %{$testCases{$caseID}}) {
        my $notes       = "";
        my $status      = "";
        my $tc          = $testCases{$caseID}{$platformID};
        my $caseConfigs = getCaseConfigs($tc->{summary});
         
        if (!$caseConfigs->{TestScript}) {
            $notes  = "Can't execute test, no TestScript set on test case";
            $status = $statuses{blocked};
        }
        else {
            ($status,$notes) = getTestStatus($caseConfigs->{TestScript}, $caseConfigs->{TestScriptOptions});
        }
        $resp = $client->send_request('tl.reportTCResult', {
            'devKey'     => $APIKey,
            'testcaseid' => $caseID,
            'testplanid' => $planID,
            'status'     => $status,
            'buildid'    => $buildID,
            'notes'      => $notes,
            'platformid' => $platformID,
        });
        if (isResponseError($resp)) {
            print STDERR "Unable to save result for TC:$caseID, platform:$platformID:\n",
                         "\t($main::apiLastResponseCode): $main::apiLastResponseString\n",
                         "\t\$notes = $notes\n",
                         "\t\$status = $status\n";
        }
        print "TC:$caseID, P:$platformID, $status", ($notes =~ m|\n|sm ? '' : ", $notes"), "\n" if ($log);
    }
}
 
exit;
 
sub getTestStatus {
    my $testScript  = shift;
    my $testOptions = shift;
    $testScript    = "/path/to/standard/test/repo/$testScript" if ($testScript !~ m|^/|);
 
    if (!-e $testScript) {
        return($statuses{blocked}, "$testScript does not exist");
    }
    elsif (!-x $testScript) {
        return($statuses{blocked}, "$testScript is not executable");
    }
     
    # this needs to be more flexible long term (path to perl and base needs to be flexible)
    my $cmd = "$testScript $testOptions 2>&1";
    if (!open(P, "$cmd |")) {
        return($statuses{blocked}, "Error opening pipe to $cmd: $!");
    }
    my $output = join('', <P>);
    close(P);
     
    if ($?) {
        return($statuses{failed}, $output);
    }
    elsif ($output =~ /TODO/) {
        # We're using perl test harnesses for our initial implementation, so we have a very specific
        # check here that, even if the external test script returned "0" (success), we still need
        # to mark the test case as blocked if there's any "TODO" individual tests
         
        # this might need to be changed, but for now if there's a TODO, set the status to block
        # to indicate that, while it's not a hard failure, it's still not "right" yet.
        return($statuses{blocked}, $output);
    }
    return($statuses{passed}, $output);
}
 
# take a case's summary field and return a ref to a hash containing key->value pairs.
# the summary field might look like this:
#<div>
#<div>TestScript: coreAAA-ui/Users.t</div>
#<div>TestType: Standard</div>
#</div>
sub getCaseConfigs {
    my $summary = shift;
    my $null    = chr(0);
    my %config  = ();
     
    $summary =~ s|</div>\n<div>|$null|smg;
    $summary =~ s|</?div>|$null|g;
    $summary =~ s|$null{2,}|$null|;
    $summary =~ s|^$null+||;
    $summary =~ s|$null+$||;
     
    foreach my $pair (split(/$null/, $summary)) {
        next if ($pair =~ m|^\s*$|); # silently skip blank lines
        $pair =~ s|<[^>]+>||g;
        $pair =~ s|\n||gsm;
        if ($pair !~ m|^\w+:\s|) {
            print STDERR "saw config line '$pair', can't normalize to 'key: value', skipping\n";
            next;
        }
        else {
            my($k,$v) = split(/:\s+/, $pair, 2);
            $config{$k} = $v;
        }
    }
     
    return(\%config);
}
 
# Hoo boy is the API for TestLink messed up when it comes to error checking.  This is my best attempt
# at a single function that checks for error states in the returned object.  It works for every function
# I've used it on, but it wouldn't surprise me a bit if it incorrectlt reported an error condition 
# for interfaces I haven't tried yet.
 
# takes a response from an API call and tells you if it is an error or not.
# returns one of the following:
# 0 - no error, we have data in the object
# 1 - API error - we received an error in the API response itself
# 2 - unknown local error
# 3 - unknown local HTTP level error (bad URL, remote host offline, etc)
# 4 - XMLRPC fault (for instance, incorrect RPC method name)
# 5 - unknown API response type (no data in response, unsure if this error type exists)
# 6 - code error in this module - shouldn't happen
# Also sets:
#    $main::apiLastResponseCode  - return code as described above
#    $main::apiLastResponseString - a text string describing the last api response (typically
#                                   something like the description above, plus any error text
#                                   that might have been returned by the tools
sub isResponseError {
    my $apiResp = shift;
     
    my $code = \$main::apiLastResponseCode;
    my $text = \$main::apiLastResponseString;
     
    $$code = 6;
    $$text = "unknown subroutine error";
     
    if (!$apiResp) {
        $$code = 2;
        $$text = "Unknown local error";
        #print STDERR "Request failed, exiting\n";
        #exit 1;
    }
    elsif (!ref($apiResp)) {
        # can get this by using incorrect url (I added "2" to the end of the URL)
        $$code = 3;
        $$text = "Local request error: $apiResp";
    }
    elsif ($apiResp->is_fault) {
        # can get this by using an incorrect method (I changed method to "getTestPlanByName2")
        #print STDERR "XMLRPC Fault: ", $resp->value->{faultCode}, ": ", $resp->value->{faultString}, "\n";
        #exit 3;
        $$code = 4;
        $$text = 'XMLRPC Fault: ' . $resp->value->{faultCode} . ': ' . $resp->value->{faultString};
    }
    else {
        my $respData = $resp->value;
         
        #print Dumper($respData), "\n";
         
        # note every valid response returns an array ref for data (see getTestCasesForTestPlan), so
        # split our error checking
        if (ref($respData) eq 'ARRAY') {
            if (scalar(@$respData) == 0) {
                # not sure if this is a real condition or not
                #print STDERR "Unexpected response from server: No objects in response\n";
                #exit 4;
                $$code = 5;
                $$text = "Unexpected response from server: No objects in response";
            }
            # there's no single "API Error" flag, this is the best test I could come up with
            # It is an API error response if:
            #  - the data is an array ref
            #  - the first element in the array is a hash ref
            #  - that hash has exactly two keys
            #  - the two keys are {code} and {message}
            # One interesting thing to note is that you can have two error objects (for instance, if you make a
            # getTestPlanByName call with an invalid API Key, you will get two errors, the first will be "Invalid
            # API Key" and the second will be "Test Plan Not Found").  It appears that the first is the most relevant,
            # so I'll be using it as if it were the sole error
            #elsif (isError($respData)) {
            elsif (ref($respData->[0]) eq 'HASH' && scalar(keys(%{$respData->[0]})) == 2 &&
                    exists($respData->[0]{code}) && exists($respData->[0]{message})) {
                # simulate by passing in a plan name that doesn't exist
                #print "Unable to find testplan '$planName': ($respData->[0]{code}) $respData->[0]{message}\n";
                #exit 5;
                $$code = 1;
                $$text = "($respData->[0]{code}) $respData->[0]{message}";
            }
            # turing off the checking for this state, I don't think it's a global error condition
            #elsif (scalar(@$respData) > 1) {
            #   # not sure if this is a real error state or not
            #   print STDERR "Something unexpected happened - received >1 items in response to getTestPlanByName:\n", Dumper($respData), "\n";
            #   exit 6;
            #}
            else {
                $$code = 0;
                $$text = "";
            }
        }
        # I haven't seen very many example of the data key being a hash, assume it's always ok for now
        elsif (ref($respData) eq 'HASH') {
            $$code = 0;
            $$text = "";
        }
    }
    return $$code;
}

get-testplan-status.pl

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

#!/usr/bin/perl
 
# yum install perl-Crypt-SSLeay
# yum install perl-RPC-XML
# http://www.softwaretestingconcepts.com/test-automation-using-testlink-xmlrpc-api-steps-and-sample-python-client-program
# http://search.cpan.org/~rjray/RPC-XML-0.71/
# http://jetmore.org/john/misc/phpdoc-testlink193-api/TestlinkAPI/TestlinkXMLRPCServer.html
 
use strict;
 
use RPC::XML;
use RPC::XML::Client;
use Data::Dumper;
 
my $dumpRaw    = 0;
# !!! You have to change all three of these to valid local settings to get this to work:
#my $testServer  = 'https://localhost/testlink/lib/api/xmlrpc.php';
#my $APIKey      = 'PUT_YOUR_API_ACCESS_KEY_IN_HERE';
#my $projectName = 'PUT_THE_NAME_OF_YOUR_PROJECT_HERE';
 
my $resp;
my $method;
my $options;
my $log      = -t STDIN ? 1 : 0; # only log if we're being run via a term
my %statuses = ('passed' => 'p', 'failed' => 'f', 'blocked' => 'b');
 
my $planName    = shift || die "Need Test Plan name to continue\n";
 
my $client = RPC::XML::Client->new($testServer);
 
#############
# Confirm test plan exists, get planID
$resp = $client->send_request('tl.getTestPlanByName', {
    'devKey' => $APIKey, 'testprojectname' => $projectName, testplanname => $planName
});
if (isResponseError($resp)) {
    die "An error occurred in getTestPlanByName ($main::apiLastResponseCode): $main::apiLastResponseString\n";
}
#print Dumper($resp);
my $projectID = $resp->value->[0]{testproject_id};
my $planID    = $resp->value->[0]{id};
print "Found planID = $planID, projectID = $projectID\n" if ($log);
 
 
############
# In the future, get all builds, pick the right one if it exists, or create new.
# For now though, just assign all tests to the 'HEAD' build
$resp = $client->send_request('tl.getBuildsForTestPlan', {
    'devKey' => $APIKey, 'testplanid' => $planID
});
if (isResponseError($resp)) {
    die "An error occurred in getBuildsForTestPlan ($main::apiLastResponseCode): $main::apiLastResponseString\n";
}
#print Dumper($resp);
my $buildID = $resp->value->[0]{id};
print "Found buildID = $buildID\n" if ($log);
 
 
###############
# Get all available test plan platforms.  This is kind of simple right now.  For now, if test runner is on linux, we will run
# any test case assigned to a plan with "Linux" in it, and same with Windows.  In future we probably want to filter
# on specific os releases and architectures
$resp = $client->send_request('tl.getTestPlanPlatforms', {
    'devKey' => $APIKey, 'testplanid' => $planID
});
if (isResponseError($resp)) {
    die "An error occurred in getTestPlanPlatforms ($main::apiLastResponseCode): $main::apiLastResponseString\n";
}
#print Dumper($resp);
my %platformInfo = ();
foreach my $platform (@{$resp->value()}) {
    $platformInfo{$platform->{id}} = $platform;
}
 
#################
# Now get all test cases in the test plan.
$resp = $client->send_request('tl.getTestCasesForTestPlan', {
    'devKey' => $APIKey, 'testplanid' => $planID,
});
if (isResponseError($resp)) {
    die "An error occurred in getTestCasesForTestPlan ($main::apiLastResponseCode): $main::apiLastResponseString\n";
}
#print Dumper($resp);
my $respData  = $resp->value();
my %testCases = ();
# manually filter the test cases in the test plan against our currently selected platform
foreach my $caseID (keys %$respData) {
    foreach my $platformID (keys %{$respData->{$caseID}}) {
    #   if ($platformID eq $platformInfo{id} && $respData->{$caseID}{$platformID}{active} == 1) {
            $testCases{$caseID}{$platformID} = $respData->{$caseID}{$platformID};
    #   }
    }
}
#print Dumper(\%testCases);
print "Found ", scalar(keys(%testCases)), " test cases to run\n" if ($log);
 
 
###########################
# Now we loop and execute
my %tcResults = ();
foreach my $caseID (keys %testCases) {
    $resp = $client->send_request('tl.getExecutionResults', {
        'devKey' => $APIKey, 'testplanid' => $planID, 'testcaseid' => $caseID, 'numexecs' => 2,
    });
    if (isResponseError($resp)) {
        die "An error occurred in getExecutionResult ($main::apiLastResponseCode): $main::apiLastResponseString\n";
    }
    $tcResults{$caseID}{results} = $resp->value();
    $tcResults{$caseID}{configs} = getCaseConfigs($testCases{$caseID}{(keys(%{$testCases{$caseID}}))[0]}{summary});
    #print Dumper($resp);
}
 
# this is super quick and dirty.  Long term I would like to see an email that has an attachment which is a CSV file
# with values like this:
# package,component,testScript,platform,ExecDate,Status
# CoreDevice,Categories,Categories.t,server - CentOS 5.5 x86_64,2012-03-27 15:31:03,failed
# and with an easily-readible body that includes HTML like the following (only include lines for case/platform
# pairs that have changed status:
# TCID,TestScript,Platform,prevExecTime,lastExecTime
# 1234,codeDevice-ui/Categories.t,server - CentOS 5.5 x86_64,2012-03-26 14:31:03,2012-03-27 15:31:03
# the key to the HTML in the body is that the BGcolor for the last two cells will indicate the status of
# that test run (green = passed, red = failed, blue = blocked, black = not run).  This allows an easily-scannable
# list of _changed_ test cases.
 
# For now though, just use text.  Also ignore platform for right now.
foreach my $caseID (keys %tcResults) {
    my $r = $tcResults{$caseID}{results};
    my $c = $tcResults{$caseID}{configs};
    # skip if it's never been run
    next if ($r->[0]{id} == -1);
    # skip if there's not a change in the results
    next if ($r->[0]{status} eq $r->[1]{status});
     
    #print "$caseID $tcResults{$caseID}{configs}{TestScript} $r->[1]{status} -> $r->[0]{status}\n";
    printf "%-8s %6s %s\n               %3s %20s -> %3s %20s\n",
        $caseID,
        "$r->[1]{status} -> $r->[0]{status}",
        $c->{TestScript},
        $r->[1]{platform_id}, $r->[1]{execution_ts},
        $r->[0]{platform_id}, $r->[0]{execution_ts};
}
 
exit;
 
 
# take a case's summary field and return a ref to a hash containing key->value pairs.
# the summary field might look like this:
#<div>
#<div>TestScript: coreAAA-ui/Users.t</div>
#<div>TestType: Standard</div>
#</div>
sub getCaseConfigs {
    my $summary = shift;
    my $null    = chr(0);
    my %config  = ();
     
    $summary =~ s|</div>\n<div>|$null|smg;
    $summary =~ s|</?div>|$null|g;
    $summary =~ s|$null{2,}|$null|;
    $summary =~ s|^$null+||;
    $summary =~ s|$null+$||;
     
    foreach my $pair (split(/$null/, $summary)) {
        next if ($pair =~ m|^\s*$|); # silently skip blank lines
        $pair =~ s|<[^>]+>||g;
        $pair =~ s|\n||gsm;
        if ($pair !~ m|^\w+:\s|) {
            print STDERR "saw config line '$pair', can normalize to 'key: value', skipping\n";
            next;
        }
        else {
            my($k,$v) = split(/:\s+/, $pair, 2);
            $config{$k} = $v;
        }
    }
     
    return(\%config);
}
 
# takes a response from an API call and tells you if it is an error or not.
# returns one of the following:
# 0 - no error, we have data in the object
# 1 - API error - we received an error in the API response itself
# 2 - unknown local error
# 3 - unknown local HTTP level error (bad URL, remote host offline, etc)
# 4 - XMLRPC fault (for instance, incorrect RPC method name)
# 5 - unknown API response type (no data in response, unsure if this error type exists)
# 6 - code error in this module - shouldn't happen
# Also sets:
#    $main::apiLastResponseCode  - return code as described above
#    $main::apiLastResponseString - a text string describing the last api response (typically
#                                   something like the description above, plus any error text
#                                   that might have been returned by the tools
sub isResponseError {
    my $apiResp = shift;
     
    my $code = \$main::apiLastResponseCode;
    my $text = \$main::apiLastResponseString;
     
    $$code = 6;
    $$text = "unknown subroutine error";
     
    if (!$apiResp) {
        $$code = 2;
        $$text = "Unknown local error";
        #print STDERR "Request failed, exiting\n";
        #exit 1;
    }
    elsif (!ref($apiResp)) {
        # can get this by using incorrect url (I added "2" to the end of the URL)
        $$code = 3;
        $$text = "Local request error: $apiResp";
    }
    elsif ($apiResp->is_fault) {
        # can get this by using an incorrect method (I changed method to "getTestPlanByName2")
        #print STDERR "XMLRPC Fault: ", $resp->value->{faultCode}, ": ", $resp->value->{faultString}, "\n";
        #exit 3;
        $$code = 4;
        $$text = 'XMLRPC Fault: ' . $resp->value->{faultCode} . ': ' . $resp->value->{faultString};
    }
    else {
        my $respData = $resp->value;
         
        #print Dumper($respData), "\n";
         
        # note every valid response returns an array ref for data (see getTestCasesForTestPlan), so
        # split our error checking
        if (ref($respData) eq 'ARRAY') {
            if (scalar(@$respData) == 0) {
                # not sure if this is a real condition or not
                #print STDERR "Unexpected response from server: No objects in response\n";
                #exit 4;
                $$code = 5;
                $$text = "Unexpected response from server: No objects in response";
            }
            # there's no single "API Error" flag, this is the best test I could come up with
            # It is an API error response if:
            #  - the data is an array ref
            #  - the first element in the array is a hash ref
            #  - that hash has exactly two keys
            #  - the two keys are {code} and {message}
            # One interesting thing to note is that you can have two error objects (for instance, if you make a
            # getTestPlanByName call with an invalid API Key, you will get two errors, the first will be "Invalid
            # API Key" and the second will be "Test Plan Not Found").  It appears that the first is the most relevant,
            # so I'll be using it as if it were the sole error
            #elsif (isError($respData)) {
            elsif (ref($respData->[0]) eq 'HASH' && scalar(keys(%{$respData->[0]})) == 2 &&
                    exists($respData->[0]{code}) && exists($respData->[0]{message})) {
                # simulate by passing in a plan name that doesn't exist
                #print "Unable to find testplan '$planName': ($respData->[0]{code}) $respData->[0]{message}\n";
                #exit 5;
                $$code = 1;
                $$text = "($respData->[0]{code}) $respData->[0]{message}";
            }
            # turing off the checking for this state, I don't think it's a global error condition
            #elsif (scalar(@$respData) > 1) {
            #   # not sure if this is a real error state or not
            #   print STDERR "Something unexpected happened - received >1 items in response to getTestPlanByName:\n", Dumper($respData), "\n";
            #   exit 6;
            #}
            else {
                $$code = 0;
                $$text = "";
            }
        }
        # I haven't seen very many example of the data key being a hash, assume it's always ok for now
        elsif (ref($respData) eq 'HASH') {
            $$code = 0;
            $$text = "";
        }
    }
    return $$code;
}

#! jetmore

Example TestLink XMLRPC Clients in Perl

Test Runner

Test Reporter

Code

Leave a Reply Cancel reply