line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package TestLink::API; |
2
|
|
|
|
|
|
|
{ |
3
|
|
|
|
|
|
|
$TestLink::API::VERSION = '0.007'; |
4
|
|
|
|
|
|
|
} |
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
=head1 NAME |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
TestLink::API - Provides an interface to TestLink's XMLRPC api via HTTP |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
=head1 SYNOPSIS |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
use TestLink::API; |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
my $tl = TestLink::API->new('http://tl.test/testlink/lib/api/xmlrpc/v1/xmlrpc.php', 'gobbledygook123'); |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
#Look up test definitions |
18
|
|
|
|
|
|
|
my $projects = $tl->getProjects(); |
19
|
|
|
|
|
|
|
my $suites = $tl->getTLDTestSuitesForProject($projects->[0]->{'id'}); |
20
|
|
|
|
|
|
|
my $childsuites = $tl->getTestSuitesForTestSuite($suites->[0]->{'id'}); |
21
|
|
|
|
|
|
|
my $tests = $tl->getTestCasesForTestSuite($childsuites->[0]->{'id'}); |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
#Look up test plans/builds |
24
|
|
|
|
|
|
|
my $plans = $tl->getTestPlansForProject($projects->[0]->{'id'}); |
25
|
|
|
|
|
|
|
my $tests2 = $tl->getTestCasesForTestPlan($plans->[0]->{'id'}); |
26
|
|
|
|
|
|
|
my $builds = $tl->getBuildsForTestPlan($plans->[0]->{'id'}); |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
#Set results |
29
|
|
|
|
|
|
|
my $testResults = doSomethingReturningBoolean(); |
30
|
|
|
|
|
|
|
my $results = $tl->reportTCResult($tests2->[0]->{'id'},$plans->[0]->{'id'},$builds->[0]->{'id'}, $testResults ? 'p' : 'f'); |
31
|
|
|
|
|
|
|
$tl->uploadExecutionAttachment($results->{'id'},'test.txt','text/plain',encode_base64('MOO MOO MOOOOOO'),'bovine emissions','whee') |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
=head1 DESCRIPTION |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
C provides methods to access an existing TestLink account. You can then do things like look up tests, set statuses and create builds from lists of tests. |
36
|
|
|
|
|
|
|
The getter methods cache the test tree up to whatever depth is required by your getter calls. This is to speed up automated creation/reading/setting of the test db based on existing automated tests. |
37
|
|
|
|
|
|
|
Cache expires at the end of script execution. (TODO memcache controlled by constructor, with create methods invalidating cache?) |
38
|
|
|
|
|
|
|
Getter/setter methods that take args assume that the relevant project/testsuite/test/plan/build provided exists (TODO: use cache to check exists, provide more verbose error reason...), and returns false if not. |
39
|
|
|
|
|
|
|
Create methods assume desired entry provided is not already in the DB (TODO (again): use cache to check exists, provide more verbose error reason...), and returns false if not. |
40
|
|
|
|
|
|
|
It is by no means exhaustively implementing every TestLink API function. Designed with TestLink 1.9.9, but will likely work on (some) other versions. |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
=cut |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
|
45
|
1
|
|
|
1
|
|
27451
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
28
|
|
46
|
1
|
|
|
1
|
|
5
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
20
|
|
47
|
1
|
|
|
1
|
|
5
|
use Carp; |
|
1
|
|
|
|
|
5
|
|
|
1
|
|
|
|
|
45
|
|
48
|
1
|
|
|
1
|
|
5
|
use Scalar::Util qw{reftype looks_like_number}; #boo, some functions return hashes and arrays depending on # of results (1 or many) |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
117
|
|
49
|
1
|
|
|
1
|
|
724
|
use Data::Validate::URI 'is_uri'; |
|
1
|
|
|
|
|
66283
|
|
|
1
|
|
|
|
|
58
|
|
50
|
|
|
|
|
|
|
|
51
|
1
|
|
|
1
|
|
773
|
use Clone 'clone'; |
|
1
|
|
|
|
|
665
|
|
|
1
|
|
|
|
|
46
|
|
52
|
|
|
|
|
|
|
|
53
|
1
|
|
|
1
|
|
1597
|
use XMLRPC::Lite; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
=head1 CONSTRUCTOR |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
=head2 B |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
Creates new C object. |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
=over 4 |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
=item C - URL to your testlink API endpoint. |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
=item C - TestLink API key. |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
=back |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
Returns C object if login is successful. |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
my $tl = TestLink::API->new('http://tl.test/testlink/lib/api/xmlrpc/v1/xmlrpc.php', 'gobbledygook123'); |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
=cut |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
sub new { |
76
|
|
|
|
|
|
|
my ($class,$apiurl,$apikey) = @_; |
77
|
|
|
|
|
|
|
confess("Constructor must be called statically, not by an instance") if ref($class); |
78
|
|
|
|
|
|
|
$apiurl ||= $ENV{'TESTLINK_SERVER_ADDR'}; |
79
|
|
|
|
|
|
|
$apikey ||= $ENV{'TESTLINK_API_KEY'}; |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
confess("No API key provided.") if !$apiurl; |
82
|
|
|
|
|
|
|
confess("No API URL provided.") if !$apikey; |
83
|
|
|
|
|
|
|
confess("API URL provided not valid.") unless is_uri($apiurl); |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
my $self = { |
86
|
|
|
|
|
|
|
apiurl => $apiurl, |
87
|
|
|
|
|
|
|
apikey => $apikey, |
88
|
|
|
|
|
|
|
testtree => [], |
89
|
|
|
|
|
|
|
flattree => [], |
90
|
|
|
|
|
|
|
invalidate_cache => 1 #since we don't have a cache right now... #TODO this should be granular down to project rather than global |
91
|
|
|
|
|
|
|
}; |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
bless $self, $class; |
94
|
|
|
|
|
|
|
return $self; |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
=head1 PROPERTIES |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
=over 4 |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
apiurl and apikey can be accessed/set: |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
$url = $tl->apiurl; |
104
|
|
|
|
|
|
|
$tl = $tl->apiurl('http//some.new.url/foo.php'); |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
=back |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
=cut |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
#EZ get/set of obj vars |
111
|
|
|
|
|
|
|
sub AUTOLOAD { |
112
|
|
|
|
|
|
|
my %public_elements = map {$_,1} qw{apiurl apikey}; #Public element access |
113
|
|
|
|
|
|
|
our $AUTOLOAD; |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
if ($AUTOLOAD =~ /::(\w+)$/ and exists $public_elements{$1} ) { |
116
|
|
|
|
|
|
|
my $field = $1; |
117
|
|
|
|
|
|
|
{ |
118
|
|
|
|
|
|
|
no strict 'refs'; |
119
|
|
|
|
|
|
|
*{$AUTOLOAD} = sub { |
120
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($_[0]); |
121
|
|
|
|
|
|
|
return $_[0]->{$field} unless defined $_[1]; |
122
|
|
|
|
|
|
|
$_[0]->{$field} = $_[1]; |
123
|
|
|
|
|
|
|
return $_[0]; |
124
|
|
|
|
|
|
|
}; |
125
|
|
|
|
|
|
|
} |
126
|
|
|
|
|
|
|
goto &{$AUTOLOAD}; |
127
|
|
|
|
|
|
|
} |
128
|
|
|
|
|
|
|
confess("$AUTOLOAD not accessible property") unless $AUTOLOAD =~ /DESTROY$/; |
129
|
|
|
|
|
|
|
} |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
=head1 CREATE METHODS |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
=head2 B |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
Creates new Test plan with given name in the given project. |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
=over 4 |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
=item STRING C - Desired test plan name. |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
=item STRING C - The name of some project existing in TestLink. |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
=item STRING C (optional) - Additional description of test plan. Default value is 'res ipsa loquiter' |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
=item BOOLEAN C (optional) - Whether or not the test plan is active. Default value is true. |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
=item BOOLEAN C (optional) - Whether or not the test plan is public. Default is true. |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
=back |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
Returns (integer) test plan ID if creation is successful. |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
my $tpid = $tl->createTestPlan('shock&awe', 'enduringfreedom'); |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
=cut |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
sub createTestPlan { |
158
|
|
|
|
|
|
|
my ($self,$name,$project,$notes,$active,$public) = @_; |
159
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($self); |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
confess("Desired Test Plan Name is a required argument (0th).") if !$name; |
162
|
|
|
|
|
|
|
confess("Parent Project Name is a required argument (1st).") if !$project; |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
$notes ||= 'res ipsa loquiter'; |
165
|
|
|
|
|
|
|
$active ||= 1; |
166
|
|
|
|
|
|
|
$public ||= 1; |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
my $input = { |
169
|
|
|
|
|
|
|
devKey => $self->apikey, |
170
|
|
|
|
|
|
|
testplanname => $name, |
171
|
|
|
|
|
|
|
testprojectname => $project, |
172
|
|
|
|
|
|
|
notes => $notes, |
173
|
|
|
|
|
|
|
active => $active, |
174
|
|
|
|
|
|
|
public => $public |
175
|
|
|
|
|
|
|
}; |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
my $rpc = XMLRPC::Lite->proxy($self->apiurl); |
178
|
|
|
|
|
|
|
my $result = $rpc->call('tl.createTestPlan',$input); |
179
|
|
|
|
|
|
|
warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'}; |
180
|
|
|
|
|
|
|
return $result->result->[0]->{'id'} if $result->result->[0]->{'id'}; |
181
|
|
|
|
|
|
|
return 0; |
182
|
|
|
|
|
|
|
} |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
=head2 B |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
Creates new 'Build' (test run in common parlance) from given test plan having given name and notes. |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
=over 4 |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
=item INTEGER C - ID of test plan to base test run on. |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
=item STRING C - Desired name for test run. |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
=item STRING C (optional) - Additional description of run. Default value is 'res ipsa loquiter'. |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
=back |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
Returns true if case addition is successful, false otherwise. |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
$tl->createBuild(1234, "Bossin' up", 'Crushing our enemies, seeing them driven before us and hearing the lamentations of their support engineers.'); |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
=cut |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
sub createBuild { |
205
|
|
|
|
|
|
|
my ($self,$plan_id,$name,$notes) = @_; |
206
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($self); |
207
|
|
|
|
|
|
|
confess("Plan ID must be integer") unless looks_like_number($plan_id); |
208
|
|
|
|
|
|
|
confess("Build name is a required argument (1st)") if !$name; |
209
|
|
|
|
|
|
|
$notes ||= 'res ipsa loquiter'; |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
my $input = { |
212
|
|
|
|
|
|
|
devKey => $self->apikey, |
213
|
|
|
|
|
|
|
testplanid => $plan_id, |
214
|
|
|
|
|
|
|
buildname => $name, |
215
|
|
|
|
|
|
|
buildnotes => $notes |
216
|
|
|
|
|
|
|
}; |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
my $rpc = XMLRPC::Lite->proxy($self->apiurl); |
219
|
|
|
|
|
|
|
my $result = $rpc->call('tl.createBuild',$input); |
220
|
|
|
|
|
|
|
warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'}; |
221
|
|
|
|
|
|
|
return $result->result->[0]->{'id'} if $result->result->[0]->{'id'}; |
222
|
|
|
|
|
|
|
return 0; |
223
|
|
|
|
|
|
|
} |
224
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
=head2 B |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
Creates new TestSuite (folder of tests) in the database of test specifications under given project id having given name and details. |
228
|
|
|
|
|
|
|
Optionally, can have a parent test suite (this is an analog to a hierarchical file tree after all) and what order to have this suite be amongst it's peers. |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
=over 4 |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
=item INTEGER C - ID of project this test suite should be under. |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
=item STRING C - Desired name of test suite. |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
=item STRING C (optional) - Description of test suite. Default value is 'res ipsa loquiter'. |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
=item INTEGER C (optional) - Parent test suite ID. Defaults to top level of project. |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
=item INTEGER C (optional) - Desired order amongst peer testsuites. Defaults to last in list. |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
=back |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
Returns (integer) build ID on success, false otherwise. |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
$tl->createTestSuite(1, 'broken tests', 'Tests that should be reviewed', 2345, -1); |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
=cut |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
sub createTestSuite { |
251
|
|
|
|
|
|
|
my ($self,$project_id,$name,$details,$parent_id,$order) = @_; |
252
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($self); |
253
|
|
|
|
|
|
|
confess("Parent Project ID (arg 0) must be an integer") unless looks_like_number($project_id); |
254
|
|
|
|
|
|
|
confess("Name (arg 1) cannot be undefined") unless $name; |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
$details ||= 'res ipsa loquiter'; |
257
|
|
|
|
|
|
|
$order ||= -1; |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
my $input = { |
260
|
|
|
|
|
|
|
devKey => $self->apikey, |
261
|
|
|
|
|
|
|
testprojectid => $project_id, |
262
|
|
|
|
|
|
|
testsuitename => $name, |
263
|
|
|
|
|
|
|
details => $details, |
264
|
|
|
|
|
|
|
parentid => $parent_id, |
265
|
|
|
|
|
|
|
order => $order |
266
|
|
|
|
|
|
|
}; |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
my $rpc = XMLRPC::Lite->proxy($self->apiurl); |
269
|
|
|
|
|
|
|
my $result = $rpc->call('tl.createTestSuite',$input); |
270
|
|
|
|
|
|
|
warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'}; |
271
|
|
|
|
|
|
|
$self->{'invalidate_cache'} = 1 if $result->result->[0]->{'id'}; |
272
|
|
|
|
|
|
|
return $result->result->[0]->{'id'} if $result->result->[0]->{'id'}; |
273
|
|
|
|
|
|
|
return 0; |
274
|
|
|
|
|
|
|
} |
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
=head2 B |
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
Creates new Project (Database of testsuites/tests) with given name and case prefix. |
279
|
|
|
|
|
|
|
Optionally, can have notes, options, set the project as active/inactive and public/private. |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
=over 4 |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
=item STRING C - Desired name of project. |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
=item STRING C - Desired prefix of project's external test case IDs. |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
=item STRING C (optional) - Description of project. Default value is 'res ipsa loquiter'. |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
=item HASHREF{BOOLEAN} C (optional) - Hash with keys: requirementsEnabled,testPriorityEnabled,automationEnabled,inventoryEnabled. |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
=item BOOLEAN C (optional) - Whether to mark the project active or not. Default True. |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
=item BOOLEAN C (optional) - Whether the project is public or not. Default true. |
294
|
|
|
|
|
|
|
|
295
|
|
|
|
|
|
|
=back |
296
|
|
|
|
|
|
|
|
297
|
|
|
|
|
|
|
Returns (integer) project ID on success, false otherwise. |
298
|
|
|
|
|
|
|
|
299
|
|
|
|
|
|
|
$tl->createTestProject('Widgetronic 4000', 'Tests for the whiz-bang new product', {'inventoryEnabled=>true}, true, true); |
300
|
|
|
|
|
|
|
|
301
|
|
|
|
|
|
|
=cut |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
#XXX probably should not use |
304
|
|
|
|
|
|
|
sub createTestProject { |
305
|
|
|
|
|
|
|
my ($self,$name,$case_prefix,$notes,$options,$active,$public) = @_; |
306
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($self); |
307
|
|
|
|
|
|
|
$notes //= 'res ipsa loquiter'; |
308
|
|
|
|
|
|
|
$options //= {}; |
309
|
|
|
|
|
|
|
$public //= 1; |
310
|
|
|
|
|
|
|
$active //= 1; |
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
my $input = { |
313
|
|
|
|
|
|
|
devKey => $self->apikey, |
314
|
|
|
|
|
|
|
testprojectname => $name, |
315
|
|
|
|
|
|
|
testcaseprefix => $case_prefix, |
316
|
|
|
|
|
|
|
notes => $notes, |
317
|
|
|
|
|
|
|
options => $options, |
318
|
|
|
|
|
|
|
active => $active, |
319
|
|
|
|
|
|
|
public => $public |
320
|
|
|
|
|
|
|
}; |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
my $rpc = XMLRPC::Lite->proxy($self->apiurl); |
323
|
|
|
|
|
|
|
my $result = $rpc->call('tl.createTestProject',$input); |
324
|
|
|
|
|
|
|
#XXX i'm being very safe (haha), there's probably a better check |
325
|
|
|
|
|
|
|
warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'}; |
326
|
|
|
|
|
|
|
$self->{'invalidate_cache'} = 1 if $result->result->[0]->{'id'}; |
327
|
|
|
|
|
|
|
return $result->result->[0]->{'id'} if $result->result->[0]->{'id'}; |
328
|
|
|
|
|
|
|
return 0; |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
} |
331
|
|
|
|
|
|
|
|
332
|
|
|
|
|
|
|
=head2 B |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
Creates new test case with given test suite id and project id. |
335
|
|
|
|
|
|
|
Author, Summary and Steps are mandatory for reasons that should be obvious to any experienced QA professional. |
336
|
|
|
|
|
|
|
Execution type and Test order is optional. |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
=over 4 |
339
|
|
|
|
|
|
|
|
340
|
|
|
|
|
|
|
=item STRING C - Desired name of test case. |
341
|
|
|
|
|
|
|
|
342
|
|
|
|
|
|
|
=item INTEGER C - ID of parent test suite. |
343
|
|
|
|
|
|
|
|
344
|
|
|
|
|
|
|
=item INTEGER C - ID of parent project |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
=item STRING C - Author of test case. |
347
|
|
|
|
|
|
|
|
348
|
|
|
|
|
|
|
=item STRING C - Summary of test case. |
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
=item STRING C - Test steps. |
351
|
|
|
|
|
|
|
|
352
|
|
|
|
|
|
|
=item STRING C - Prereqs for running the test, if any. |
353
|
|
|
|
|
|
|
|
354
|
|
|
|
|
|
|
=item STRING C (optional) - Execution type. Defaults to 'manual'. |
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
=item INTEGER C (optional) - Order of test amongst peers. |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
=back |
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
Returns (HASHREF) with Test Case ID and Test Case External ID on success, false otherwise. |
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
$tl->createTestCase('Verify Whatsit Throbs at correct frequency', 123, 456, 'Gnaeus Pompieus Maximus', 'Make sure throbber on Whatsit doesn't work out of harmony with other throbbers', '1. Connect measurement harness. 2. ??? 3. PROFIT!', 'automated', 2); |
363
|
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
=cut |
365
|
|
|
|
|
|
|
|
366
|
|
|
|
|
|
|
sub createTestCase { |
367
|
|
|
|
|
|
|
my ($self,$test_name,$test_suite_id,$test_project_id,$author_name,$summary,$steps,$preconditions,$execution,$order) = @_; |
368
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($self); |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
my $input = { |
371
|
|
|
|
|
|
|
devKey => $self->apikey, |
372
|
|
|
|
|
|
|
testcasename => $test_name, |
373
|
|
|
|
|
|
|
testsuiteid => $test_suite_id, |
374
|
|
|
|
|
|
|
testprojectid => $test_project_id, |
375
|
|
|
|
|
|
|
authorlogin => $author_name, |
376
|
|
|
|
|
|
|
summary => $summary, |
377
|
|
|
|
|
|
|
steps => $steps, |
378
|
|
|
|
|
|
|
preconditions => $preconditions, |
379
|
|
|
|
|
|
|
execution => $execution, |
380
|
|
|
|
|
|
|
order => $order |
381
|
|
|
|
|
|
|
}; |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
my $rpc = XMLRPC::Lite->proxy($self->apiurl); |
384
|
|
|
|
|
|
|
my $result = $rpc->call('tl.createTestCase',$input); |
385
|
|
|
|
|
|
|
#XXX i'm being very safe (haha), there's probably a better check |
386
|
|
|
|
|
|
|
warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'}; |
387
|
|
|
|
|
|
|
return $result->result->[0] if $result->result->[0]->{'id'}; |
388
|
|
|
|
|
|
|
return 0; |
389
|
|
|
|
|
|
|
|
390
|
|
|
|
|
|
|
} |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
=head1 SETTER METHODS |
393
|
|
|
|
|
|
|
|
394
|
|
|
|
|
|
|
=head2 B |
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
Report results of a test case with a given ID, plan and build ID. Set case results to status given. |
397
|
|
|
|
|
|
|
Platform is mandatory if available, otherwise optional. |
398
|
|
|
|
|
|
|
Notes and Bug Ids for whatever tracker you use are optional. |
399
|
|
|
|
|
|
|
|
400
|
|
|
|
|
|
|
=over 4 |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
=item INTEGER C - Desired test case. |
403
|
|
|
|
|
|
|
|
404
|
|
|
|
|
|
|
=item INTEGER C - ID of relevant test plan. |
405
|
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
=item INTEGER C - ID of relevant build. |
407
|
|
|
|
|
|
|
|
408
|
|
|
|
|
|
|
=item STRING C - Desired Test Status Code. Codes not documented anywhere but in your cfg/const.inc.php of the TestLink Install. |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
=item STRING C (semi-optional) - Relevant platform tested on. |
411
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
=item STRING C (optional) - Relevant information gleaned during testing process. |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
=item STRING C (optional) - Relevant bug ID for regression tests, or if you auto-open bugs based on failures. |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
=back |
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
Returns project ID on success, false otherwise. |
419
|
|
|
|
|
|
|
|
420
|
|
|
|
|
|
|
$tl->reportTCResult('T-1000', 7779311, 8675309, 'Tool Failure', 'Skynet Infiltration Model 1000', 'Catastrophic systems failure due to falling into vat of molten metal' 'TERMINATOR-2'); |
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
=cut |
423
|
|
|
|
|
|
|
|
424
|
|
|
|
|
|
|
sub reportTCResult { |
425
|
|
|
|
|
|
|
my ($self,$case_id,$plan_id,$build_id,$status,$platform,$notes,$bugid) = @_; |
426
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($self); |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
my $input = { |
429
|
|
|
|
|
|
|
devKey => $self->apikey, |
430
|
|
|
|
|
|
|
testcaseid => $case_id, |
431
|
|
|
|
|
|
|
testplanid => $plan_id, |
432
|
|
|
|
|
|
|
buildid => $build_id, |
433
|
|
|
|
|
|
|
status => $status, |
434
|
|
|
|
|
|
|
platformid => $platform, |
435
|
|
|
|
|
|
|
notes => $notes, |
436
|
|
|
|
|
|
|
bugid => $bugid |
437
|
|
|
|
|
|
|
}; |
438
|
|
|
|
|
|
|
|
439
|
|
|
|
|
|
|
my $rpc = XMLRPC::Lite->proxy($self->apiurl); |
440
|
|
|
|
|
|
|
my $result = $rpc->call('tl.reportTCResult',$input); |
441
|
|
|
|
|
|
|
warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'}; |
442
|
|
|
|
|
|
|
return $result->result->[0] unless $result->result->[0]->{'code'}; |
443
|
|
|
|
|
|
|
return 0; |
444
|
|
|
|
|
|
|
} |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
=head2 B |
447
|
|
|
|
|
|
|
|
448
|
|
|
|
|
|
|
Creates new Test plan with given name in the given project. |
449
|
|
|
|
|
|
|
|
450
|
|
|
|
|
|
|
=over 4 |
451
|
|
|
|
|
|
|
|
452
|
|
|
|
|
|
|
=item INTEGER C - Desired test plan. |
453
|
|
|
|
|
|
|
|
454
|
|
|
|
|
|
|
=item STRING C - The 'external' name of some existing test in TestLink, e.g. TP-12. |
455
|
|
|
|
|
|
|
|
456
|
|
|
|
|
|
|
=item INTEGER C - The ID of some project in testlink |
457
|
|
|
|
|
|
|
|
458
|
|
|
|
|
|
|
=item INTEGER C - The desired version of the test to add. |
459
|
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
=item STRING C (semi-optional) - The name of the desired platform to run on for this test (if any). |
461
|
|
|
|
|
|
|
|
462
|
|
|
|
|
|
|
=item INTEGER C (optional) - The order in which to execute this test amongst it's peers. |
463
|
|
|
|
|
|
|
|
464
|
|
|
|
|
|
|
=item INTEGER C (optional) - The priority of the case in the plan. |
465
|
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
=back |
467
|
|
|
|
|
|
|
|
468
|
|
|
|
|
|
|
Returns true if case addition is successful. |
469
|
|
|
|
|
|
|
|
470
|
|
|
|
|
|
|
$tl->addTestCaseToTestPlan(666, 'cp-90210', 121, '3.11', 'OS2/WARP', 3, 1); |
471
|
|
|
|
|
|
|
|
472
|
|
|
|
|
|
|
=cut |
473
|
|
|
|
|
|
|
|
474
|
|
|
|
|
|
|
#XXX this should be able to be done in batch |
475
|
|
|
|
|
|
|
sub addTestCaseToTestPlan { |
476
|
|
|
|
|
|
|
my ($self,$plan_id,$case_id,$project_id,$version,$platform,$order,$urgency) = @_; |
477
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($self); |
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
my $input = { |
480
|
|
|
|
|
|
|
devKey => $self->apikey, |
481
|
|
|
|
|
|
|
testplanid => $plan_id, |
482
|
|
|
|
|
|
|
testcaseexternalid => $case_id, |
483
|
|
|
|
|
|
|
testprojectid => $project_id, |
484
|
|
|
|
|
|
|
version => $version, |
485
|
|
|
|
|
|
|
platformid => $platform, |
486
|
|
|
|
|
|
|
executionorder => $order, |
487
|
|
|
|
|
|
|
urgency => $urgency |
488
|
|
|
|
|
|
|
}; |
489
|
|
|
|
|
|
|
|
490
|
|
|
|
|
|
|
my $rpc = XMLRPC::Lite->proxy($self->apiurl); |
491
|
|
|
|
|
|
|
my $result = $rpc->call('tl.addTestCaseToTestPlan',$input); |
492
|
|
|
|
|
|
|
warn $result->result->{'message'} if $result->result->{'code'}; |
493
|
|
|
|
|
|
|
return 1 unless $result->result->{'code'}; |
494
|
|
|
|
|
|
|
return 0; |
495
|
|
|
|
|
|
|
} |
496
|
|
|
|
|
|
|
|
497
|
|
|
|
|
|
|
=head2 B |
498
|
|
|
|
|
|
|
|
499
|
|
|
|
|
|
|
Uploads the provided file and associates it with the given execution. |
500
|
|
|
|
|
|
|
|
501
|
|
|
|
|
|
|
=over 4 |
502
|
|
|
|
|
|
|
|
503
|
|
|
|
|
|
|
=item INTEGER C - ID of a successful execution, such as the id key from the hash that is returned by reportTCResult. |
504
|
|
|
|
|
|
|
|
505
|
|
|
|
|
|
|
=item STRING C - The name you want this file to appear as. |
506
|
|
|
|
|
|
|
|
507
|
|
|
|
|
|
|
=item INTEGER C - The mimetype of the file uploaded, so we can tell the browser what to do with it when downloaded |
508
|
|
|
|
|
|
|
|
509
|
|
|
|
|
|
|
=item INTEGER C - The base64 encoded content of the file you want to upload. |
510
|
|
|
|
|
|
|
|
511
|
|
|
|
|
|
|
=item STRING C (optional) - A title for this attachment. |
512
|
|
|
|
|
|
|
|
513
|
|
|
|
|
|
|
=item INTEGER C (optional) - A short description of who/what/why this was attached. |
514
|
|
|
|
|
|
|
|
515
|
|
|
|
|
|
|
=back |
516
|
|
|
|
|
|
|
|
517
|
|
|
|
|
|
|
Returns true if attachment addition is successful. |
518
|
|
|
|
|
|
|
|
519
|
|
|
|
|
|
|
$tl->uploadExecutionAttachment(1234, 'moo.txt', 'text/cow', APR::Base64::encode('MOO MOO MOOOOOO'), 'MOO', 'Test observed deranged bleatings of domestic ungulates, please investigate.'); |
520
|
|
|
|
|
|
|
|
521
|
|
|
|
|
|
|
=cut |
522
|
|
|
|
|
|
|
|
523
|
|
|
|
|
|
|
sub uploadExecutionAttachment { |
524
|
|
|
|
|
|
|
my ($self,$execution_id,$filename,$filetype,$content,$title,$description) = @_; |
525
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($self); |
526
|
|
|
|
|
|
|
|
527
|
|
|
|
|
|
|
my $input = { |
528
|
|
|
|
|
|
|
devKey => $self->apikey, |
529
|
|
|
|
|
|
|
executionid => $execution_id, |
530
|
|
|
|
|
|
|
title => $title, |
531
|
|
|
|
|
|
|
description => $description, |
532
|
|
|
|
|
|
|
filename => $filename, |
533
|
|
|
|
|
|
|
filetype => $filetype, |
534
|
|
|
|
|
|
|
content => $content |
535
|
|
|
|
|
|
|
}; |
536
|
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
my $rpc = XMLRPC::Lite->proxy($self->apiurl); |
538
|
|
|
|
|
|
|
my $result = $rpc->call('tl.uploadExecutionAttachment',$input); |
539
|
|
|
|
|
|
|
warn $result->result->{'message'} if $result->result->{'code'}; |
540
|
|
|
|
|
|
|
return 1 unless $result->result->{'code'}; |
541
|
|
|
|
|
|
|
return 0; |
542
|
|
|
|
|
|
|
} |
543
|
|
|
|
|
|
|
|
544
|
|
|
|
|
|
|
=head2 B |
545
|
|
|
|
|
|
|
|
546
|
|
|
|
|
|
|
Uploads the provided file and associates it with the given execution. |
547
|
|
|
|
|
|
|
|
548
|
|
|
|
|
|
|
=over 4 |
549
|
|
|
|
|
|
|
|
550
|
|
|
|
|
|
|
=item INTEGER C - ID of desired test case |
551
|
|
|
|
|
|
|
|
552
|
|
|
|
|
|
|
=item STRING C - The name you want this file to appear as. |
553
|
|
|
|
|
|
|
|
554
|
|
|
|
|
|
|
=item INTEGER C - The mimetype of the file uploaded, so we can tell the browser what to do with it when downloaded |
555
|
|
|
|
|
|
|
|
556
|
|
|
|
|
|
|
=item INTEGER C - The base64 encoded content of the file you want to upload. |
557
|
|
|
|
|
|
|
|
558
|
|
|
|
|
|
|
=item STRING C (optional) - A title for this attachment. |
559
|
|
|
|
|
|
|
|
560
|
|
|
|
|
|
|
=item INTEGER C (optional) - A short description of who/what/why this was attached. |
561
|
|
|
|
|
|
|
|
562
|
|
|
|
|
|
|
=back |
563
|
|
|
|
|
|
|
|
564
|
|
|
|
|
|
|
Returns true if attachment addition is successful. |
565
|
|
|
|
|
|
|
|
566
|
|
|
|
|
|
|
$tl->uploadTestCaseAttachment(1234, 'doStuff.t', 'text/perl', APR::Base64::encode($slurped_file_content), 'doStuff.t', 'Test File.'); |
567
|
|
|
|
|
|
|
|
568
|
|
|
|
|
|
|
=cut |
569
|
|
|
|
|
|
|
|
570
|
|
|
|
|
|
|
sub uploadTestCaseAttachment { |
571
|
|
|
|
|
|
|
my ($self,$case_id,$filename,$filetype,$content,$title,$description) = @_; |
572
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($self); |
573
|
|
|
|
|
|
|
|
574
|
|
|
|
|
|
|
my $input = { |
575
|
|
|
|
|
|
|
devKey => $self->apikey, |
576
|
|
|
|
|
|
|
testcaseid => $case_id, |
577
|
|
|
|
|
|
|
title => $title, |
578
|
|
|
|
|
|
|
description => $description, |
579
|
|
|
|
|
|
|
filename => $filename, |
580
|
|
|
|
|
|
|
filetype => $filetype, |
581
|
|
|
|
|
|
|
content => $content |
582
|
|
|
|
|
|
|
}; |
583
|
|
|
|
|
|
|
|
584
|
|
|
|
|
|
|
my $rpc = XMLRPC::Lite->proxy($self->apiurl); |
585
|
|
|
|
|
|
|
my $result = $rpc->call('tl.uploadTestCaseAttachment',$input); |
586
|
|
|
|
|
|
|
warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'}; |
587
|
|
|
|
|
|
|
return 1 unless $result->result->[0]->{'code'}; |
588
|
|
|
|
|
|
|
return 0; |
589
|
|
|
|
|
|
|
} |
590
|
|
|
|
|
|
|
|
591
|
|
|
|
|
|
|
|
592
|
|
|
|
|
|
|
=head1 GETTER METHODS |
593
|
|
|
|
|
|
|
|
594
|
|
|
|
|
|
|
=head2 B |
595
|
|
|
|
|
|
|
|
596
|
|
|
|
|
|
|
Get all available projects |
597
|
|
|
|
|
|
|
|
598
|
|
|
|
|
|
|
Returns array of project definition hashes, false otherwise. |
599
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
$projects = $tl->getProjects; |
601
|
|
|
|
|
|
|
|
602
|
|
|
|
|
|
|
=cut |
603
|
|
|
|
|
|
|
|
604
|
|
|
|
|
|
|
sub getProjects { |
605
|
|
|
|
|
|
|
my $self = shift; |
606
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($self); |
607
|
|
|
|
|
|
|
|
608
|
|
|
|
|
|
|
my $input = { |
609
|
|
|
|
|
|
|
devKey => $self->apikey |
610
|
|
|
|
|
|
|
}; |
611
|
|
|
|
|
|
|
|
612
|
|
|
|
|
|
|
my $rpc = XMLRPC::Lite->proxy($self->apiurl); |
613
|
|
|
|
|
|
|
my $result = $rpc->call('tl.getProjects',$input); |
614
|
|
|
|
|
|
|
warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'}; |
615
|
|
|
|
|
|
|
|
616
|
|
|
|
|
|
|
#Save state for future use, if needed |
617
|
|
|
|
|
|
|
if (!scalar(@{$self->{'testtree'}})) { |
618
|
|
|
|
|
|
|
$self->{'testtree'} = $result->result unless $result->result->[0]->{'code'}; |
619
|
|
|
|
|
|
|
} |
620
|
|
|
|
|
|
|
|
621
|
|
|
|
|
|
|
if (!exists($result->result->[0]->{'code'})) { |
622
|
|
|
|
|
|
|
#Note that it's a project for future reference by recursive tree search |
623
|
|
|
|
|
|
|
for my $pj (@{$result->result}) { |
624
|
|
|
|
|
|
|
$pj->{'type'} = 'project'; |
625
|
|
|
|
|
|
|
} |
626
|
|
|
|
|
|
|
return $result->result; |
627
|
|
|
|
|
|
|
} |
628
|
|
|
|
|
|
|
|
629
|
|
|
|
|
|
|
return 0; |
630
|
|
|
|
|
|
|
} |
631
|
|
|
|
|
|
|
|
632
|
|
|
|
|
|
|
=head2 B |
633
|
|
|
|
|
|
|
|
634
|
|
|
|
|
|
|
Gets some project definition hash by it's name |
635
|
|
|
|
|
|
|
|
636
|
|
|
|
|
|
|
=over 4 |
637
|
|
|
|
|
|
|
|
638
|
|
|
|
|
|
|
=item STRING C - desired project |
639
|
|
|
|
|
|
|
|
640
|
|
|
|
|
|
|
=back |
641
|
|
|
|
|
|
|
|
642
|
|
|
|
|
|
|
Returns desired project def hash, false otherwise. |
643
|
|
|
|
|
|
|
|
644
|
|
|
|
|
|
|
$projects = $tl->getProjectByName('FunProject'); |
645
|
|
|
|
|
|
|
|
646
|
|
|
|
|
|
|
=cut |
647
|
|
|
|
|
|
|
|
648
|
|
|
|
|
|
|
sub getProjectByName { |
649
|
|
|
|
|
|
|
my ($self,$project) = @_; |
650
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($self); |
651
|
|
|
|
|
|
|
confess "No project provided." unless $project; |
652
|
|
|
|
|
|
|
|
653
|
|
|
|
|
|
|
#See if we already have the project list... |
654
|
|
|
|
|
|
|
my $projects = $self->{'testtree'}; |
655
|
|
|
|
|
|
|
$projects = $self->getProjects() unless scalar(@$projects); |
656
|
|
|
|
|
|
|
|
657
|
|
|
|
|
|
|
#Search project list for project |
658
|
|
|
|
|
|
|
for my $candidate (@$projects) { |
659
|
|
|
|
|
|
|
return $candidate if ($candidate->{'name'} eq $project); |
660
|
|
|
|
|
|
|
} |
661
|
|
|
|
|
|
|
|
662
|
|
|
|
|
|
|
return 0; |
663
|
|
|
|
|
|
|
} |
664
|
|
|
|
|
|
|
|
665
|
|
|
|
|
|
|
=head2 B |
666
|
|
|
|
|
|
|
|
667
|
|
|
|
|
|
|
Gets some project definition hash by it's ID |
668
|
|
|
|
|
|
|
|
669
|
|
|
|
|
|
|
=over 4 |
670
|
|
|
|
|
|
|
|
671
|
|
|
|
|
|
|
=item INTEGER C - desired project |
672
|
|
|
|
|
|
|
|
673
|
|
|
|
|
|
|
=back |
674
|
|
|
|
|
|
|
|
675
|
|
|
|
|
|
|
Returns desired project def hash, false otherwise. |
676
|
|
|
|
|
|
|
|
677
|
|
|
|
|
|
|
$projects = $tl->getProjectByID(222); |
678
|
|
|
|
|
|
|
|
679
|
|
|
|
|
|
|
=cut |
680
|
|
|
|
|
|
|
|
681
|
|
|
|
|
|
|
sub getProjectByID { |
682
|
|
|
|
|
|
|
my ($self,$project) = @_; |
683
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($self); |
684
|
|
|
|
|
|
|
confess "No project provided." unless $project; |
685
|
|
|
|
|
|
|
|
686
|
|
|
|
|
|
|
#See if we already have the project list... |
687
|
|
|
|
|
|
|
my $projects = $self->{'testtree'}; |
688
|
|
|
|
|
|
|
$projects = $self->getProjects() unless scalar(@$projects); |
689
|
|
|
|
|
|
|
|
690
|
|
|
|
|
|
|
#Search project list for project |
691
|
|
|
|
|
|
|
for my $candidate (@$projects) { |
692
|
|
|
|
|
|
|
return $candidate if ($candidate->{'id'} eq $project); |
693
|
|
|
|
|
|
|
} |
694
|
|
|
|
|
|
|
|
695
|
|
|
|
|
|
|
return 0; |
696
|
|
|
|
|
|
|
} |
697
|
|
|
|
|
|
|
|
698
|
|
|
|
|
|
|
|
699
|
|
|
|
|
|
|
=head2 B |
700
|
|
|
|
|
|
|
|
701
|
|
|
|
|
|
|
Gets the testsuites in the top level of a project |
702
|
|
|
|
|
|
|
|
703
|
|
|
|
|
|
|
=over 4 |
704
|
|
|
|
|
|
|
|
705
|
|
|
|
|
|
|
=item STRING C - desired project's ID |
706
|
|
|
|
|
|
|
=item BOOLEAN C - Get tests for suites returned, set them as 'tests' key in hash |
707
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
=back |
709
|
|
|
|
|
|
|
|
710
|
|
|
|
|
|
|
Returns desired testsuites' definition hashes, 0 on error and -1 when there is no such project. |
711
|
|
|
|
|
|
|
|
712
|
|
|
|
|
|
|
$projects = $tl->getTLDTestSuitesForProject(123); |
713
|
|
|
|
|
|
|
|
714
|
|
|
|
|
|
|
=cut |
715
|
|
|
|
|
|
|
|
716
|
|
|
|
|
|
|
sub getTLDTestSuitesForProject { |
717
|
|
|
|
|
|
|
my ($self,$project,$get_tests) = @_; |
718
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($self); |
719
|
|
|
|
|
|
|
confess "No project ID provided." unless $project; |
720
|
|
|
|
|
|
|
|
721
|
|
|
|
|
|
|
my $input = { |
722
|
|
|
|
|
|
|
devKey => $self->apikey, |
723
|
|
|
|
|
|
|
testprojectid => $project |
724
|
|
|
|
|
|
|
}; |
725
|
|
|
|
|
|
|
|
726
|
|
|
|
|
|
|
my $rpc = XMLRPC::Lite->proxy($self->apiurl); |
727
|
|
|
|
|
|
|
my $result = $rpc->call('tl.getFirstLevelTestSuitesForTestProject',$input); |
728
|
|
|
|
|
|
|
|
729
|
|
|
|
|
|
|
#Error condition, return right away |
730
|
|
|
|
|
|
|
warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'}; |
731
|
|
|
|
|
|
|
return [] if $result->result->[0]->{'code'}; |
732
|
|
|
|
|
|
|
|
733
|
|
|
|
|
|
|
#Handle bizarre output |
734
|
|
|
|
|
|
|
if ($result->result && !(reftype($result->result) eq 'HASH' || reftype($result->result) eq 'ARRAY')) { |
735
|
|
|
|
|
|
|
return []; |
736
|
|
|
|
|
|
|
} |
737
|
|
|
|
|
|
|
return [] if !$result->result; |
738
|
|
|
|
|
|
|
|
739
|
|
|
|
|
|
|
#Handle mixed return type for this function -- this POS will return arrayrefs, and 2 types of hashrefs. |
740
|
|
|
|
|
|
|
my $res = []; |
741
|
|
|
|
|
|
|
$res = $result->result if reftype($result->result) eq 'ARRAY'; |
742
|
|
|
|
|
|
|
@$res = values(%{$result->result}) if reftype($result->result) eq 'HASH' && !defined($result->result->{'id'}); |
743
|
|
|
|
|
|
|
$res = [$result->result] if reftype($result->result) eq 'HASH' && defined($result->result->{'id'}); |
744
|
|
|
|
|
|
|
return [] if (!scalar(keys(%{$res->[0]}))); #Catch bizarre edge case of blank hash being only thing there |
745
|
|
|
|
|
|
|
|
746
|
|
|
|
|
|
|
if ($get_tests) { |
747
|
|
|
|
|
|
|
for (my $i=0; $i < scalar(@{$result->result}); $i++) { |
748
|
|
|
|
|
|
|
$result->result->[$i]->{'tests'} = $self->getTestCasesForTestSuite($result->result->[$i]->{'id'},0,1); |
749
|
|
|
|
|
|
|
} |
750
|
|
|
|
|
|
|
} |
751
|
|
|
|
|
|
|
|
752
|
|
|
|
|
|
|
return $result->result; |
753
|
|
|
|
|
|
|
} |
754
|
|
|
|
|
|
|
|
755
|
|
|
|
|
|
|
=head2 B |
756
|
|
|
|
|
|
|
|
757
|
|
|
|
|
|
|
Gets the testsuites that are children of the provided testsuite. |
758
|
|
|
|
|
|
|
|
759
|
|
|
|
|
|
|
=over 4 |
760
|
|
|
|
|
|
|
|
761
|
|
|
|
|
|
|
=item STRING C - desired parent testsuite ID |
762
|
|
|
|
|
|
|
=item STRING C - whether to get child tests as well |
763
|
|
|
|
|
|
|
|
764
|
|
|
|
|
|
|
=back |
765
|
|
|
|
|
|
|
|
766
|
|
|
|
|
|
|
Returns desired testsuites' definition hashes, false otherwise. |
767
|
|
|
|
|
|
|
|
768
|
|
|
|
|
|
|
$suites = $tl->getTestSuitesForTestSuite(123); |
769
|
|
|
|
|
|
|
$suitesWithCases = $tl->getTestSuitesForTestSuite(123,1); |
770
|
|
|
|
|
|
|
|
771
|
|
|
|
|
|
|
=cut |
772
|
|
|
|
|
|
|
|
773
|
|
|
|
|
|
|
sub getTestSuitesForTestSuite { |
774
|
|
|
|
|
|
|
my ($self,$tsid,$get_tests) = @_; |
775
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($self); |
776
|
|
|
|
|
|
|
confess "No TestSuite ID provided." unless $tsid; |
777
|
|
|
|
|
|
|
|
778
|
|
|
|
|
|
|
my $input = { |
779
|
|
|
|
|
|
|
devKey => $self->apikey, |
780
|
|
|
|
|
|
|
testsuiteid => $tsid |
781
|
|
|
|
|
|
|
}; |
782
|
|
|
|
|
|
|
|
783
|
|
|
|
|
|
|
my $rpc = XMLRPC::Lite->proxy($self->apiurl); |
784
|
|
|
|
|
|
|
my $result = $rpc->call('tl.getTestSuitesForTestSuite',$input); |
785
|
|
|
|
|
|
|
|
786
|
|
|
|
|
|
|
#Handle bizarre output |
787
|
|
|
|
|
|
|
if ($result->result && !(reftype($result->result) eq 'HASH' || reftype($result->result) eq 'ARRAY')) { |
788
|
|
|
|
|
|
|
return []; |
789
|
|
|
|
|
|
|
} |
790
|
|
|
|
|
|
|
return [] if !$result->result; |
791
|
|
|
|
|
|
|
|
792
|
|
|
|
|
|
|
#Handle mixed return type for this function -- this POS will return arrayrefs, and 2 types of hashrefs. |
793
|
|
|
|
|
|
|
my $res = []; |
794
|
|
|
|
|
|
|
$res = $result->result if reftype($result->result) eq 'ARRAY'; |
795
|
|
|
|
|
|
|
@$res = values(%{$result->result}) if reftype($result->result) eq 'HASH' && !defined($result->result->{'id'}); |
796
|
|
|
|
|
|
|
$res = [$result->result] if reftype($result->result) eq 'HASH' && defined($result->result->{'id'}); |
797
|
|
|
|
|
|
|
|
798
|
|
|
|
|
|
|
if ($get_tests) { |
799
|
|
|
|
|
|
|
foreach my $row (@$res) { |
800
|
|
|
|
|
|
|
$row->{'tests'} = $self->getTestCasesForTestSuite($row->{'id'},0,1); |
801
|
|
|
|
|
|
|
} |
802
|
|
|
|
|
|
|
} |
803
|
|
|
|
|
|
|
|
804
|
|
|
|
|
|
|
#Error condition, return false and don't bother searching arrays |
805
|
|
|
|
|
|
|
warn $res->{'message'} if $res->[0]->{'code'}; |
806
|
|
|
|
|
|
|
return [] if $res->[0]->{'code'}; |
807
|
|
|
|
|
|
|
return $res; |
808
|
|
|
|
|
|
|
} |
809
|
|
|
|
|
|
|
|
810
|
|
|
|
|
|
|
|
811
|
|
|
|
|
|
|
=head2 B |
812
|
|
|
|
|
|
|
|
813
|
|
|
|
|
|
|
Gets the testsuite(s) that match given name inside of given project name. |
814
|
|
|
|
|
|
|
WARNING: this will slurp the enitre testsuite tree. This can take a while on large projects, but the results are cached so that subsequent calls are not as onerous. |
815
|
|
|
|
|
|
|
|
816
|
|
|
|
|
|
|
=over 4 |
817
|
|
|
|
|
|
|
|
818
|
|
|
|
|
|
|
=item STRING C - ID of project holding this testsuite |
819
|
|
|
|
|
|
|
|
820
|
|
|
|
|
|
|
=item STRING C - desired parent testsuite name |
821
|
|
|
|
|
|
|
|
822
|
|
|
|
|
|
|
=item BOOLEAN C (optional) - whether or not PROJECT NAME is a regex (default false, uses 'eq' to compare). |
823
|
|
|
|
|
|
|
|
824
|
|
|
|
|
|
|
=back |
825
|
|
|
|
|
|
|
|
826
|
|
|
|
|
|
|
Returns desired testsuites' definition hashes, false otherwise. |
827
|
|
|
|
|
|
|
|
828
|
|
|
|
|
|
|
$suites = $tl->getTestSuitesByName(321, 'hugSuite'); |
829
|
|
|
|
|
|
|
$suitesr = $tl->getTestSuitesByName(123, qr/^hug/, 1); |
830
|
|
|
|
|
|
|
|
831
|
|
|
|
|
|
|
=cut |
832
|
|
|
|
|
|
|
|
833
|
|
|
|
|
|
|
sub getTestSuitesByName { |
834
|
|
|
|
|
|
|
my ($self,$project_id,$testsuite_name,$do_regex) = @_; |
835
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($self); |
836
|
|
|
|
|
|
|
return 0 if (!$project_id || !$testsuite_name); #GIGO |
837
|
|
|
|
|
|
|
|
838
|
|
|
|
|
|
|
#use caching methods here to speed up subsequent calls |
839
|
|
|
|
|
|
|
$self->_cacheProjectTree($project_id,1,1,0) if $self->{'invalidate_cache'}; |
840
|
|
|
|
|
|
|
|
841
|
|
|
|
|
|
|
#my $tld = $self->getTLDTestSuitesForProject($project_id); |
842
|
|
|
|
|
|
|
my $candidates = []; |
843
|
|
|
|
|
|
|
|
844
|
|
|
|
|
|
|
#Walk the whole tree. No other way to be sure. |
845
|
|
|
|
|
|
|
foreach my $ts (@{$self->{'flattree'}}) { |
846
|
|
|
|
|
|
|
if ($do_regex) { |
847
|
|
|
|
|
|
|
push(@$candidates,$ts) if $ts->{'name'} =~ $testsuite_name; |
848
|
|
|
|
|
|
|
} else { |
849
|
|
|
|
|
|
|
push(@$candidates,$ts) if $ts->{'name'} eq $testsuite_name; |
850
|
|
|
|
|
|
|
} |
851
|
|
|
|
|
|
|
} |
852
|
|
|
|
|
|
|
return $candidates; |
853
|
|
|
|
|
|
|
|
854
|
|
|
|
|
|
|
} |
855
|
|
|
|
|
|
|
|
856
|
|
|
|
|
|
|
=head2 B |
857
|
|
|
|
|
|
|
|
858
|
|
|
|
|
|
|
Gets the testsuite with the given ID. |
859
|
|
|
|
|
|
|
|
860
|
|
|
|
|
|
|
=over 4 |
861
|
|
|
|
|
|
|
|
862
|
|
|
|
|
|
|
=item STRING C - Testsuite ID. |
863
|
|
|
|
|
|
|
|
864
|
|
|
|
|
|
|
=back |
865
|
|
|
|
|
|
|
|
866
|
|
|
|
|
|
|
Returns desired testsuite definition hash, false otherwise. |
867
|
|
|
|
|
|
|
|
868
|
|
|
|
|
|
|
$tests = $tl->getTestSuiteByID(123); |
869
|
|
|
|
|
|
|
|
870
|
|
|
|
|
|
|
=cut |
871
|
|
|
|
|
|
|
|
872
|
|
|
|
|
|
|
sub getTestSuiteByID { |
873
|
|
|
|
|
|
|
my ($self,$testsuite_id) = @_; |
874
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($self); |
875
|
|
|
|
|
|
|
|
876
|
|
|
|
|
|
|
my $input = { |
877
|
|
|
|
|
|
|
devKey => $self->apikey, |
878
|
|
|
|
|
|
|
testsuiteid => $testsuite_id |
879
|
|
|
|
|
|
|
}; |
880
|
|
|
|
|
|
|
|
881
|
|
|
|
|
|
|
my $rpc = XMLRPC::Lite->proxy($self->apiurl); |
882
|
|
|
|
|
|
|
my $result = $rpc->call('tl.getTestSuiteByID',$input); |
883
|
|
|
|
|
|
|
warn $result->result->{'message'} if $result->result->{'code'}; |
884
|
|
|
|
|
|
|
return $result->result unless $result->result->{'code'}; |
885
|
|
|
|
|
|
|
return 0; |
886
|
|
|
|
|
|
|
} |
887
|
|
|
|
|
|
|
|
888
|
|
|
|
|
|
|
=head2 B |
889
|
|
|
|
|
|
|
|
890
|
|
|
|
|
|
|
Gets the testsuites that match given name inside of given project name. |
891
|
|
|
|
|
|
|
|
892
|
|
|
|
|
|
|
=over 4 |
893
|
|
|
|
|
|
|
|
894
|
|
|
|
|
|
|
=item STRING C - Testsuite ID. |
895
|
|
|
|
|
|
|
|
896
|
|
|
|
|
|
|
=item BOOLEAN C - Search testsuite tree recursively for tests below the provided testsuite |
897
|
|
|
|
|
|
|
|
898
|
|
|
|
|
|
|
=item BOOLEAN C (optional) - whether or not to return more detailed test info (steps,summary,expected results). Defaults to false. |
899
|
|
|
|
|
|
|
|
900
|
|
|
|
|
|
|
=back |
901
|
|
|
|
|
|
|
|
902
|
|
|
|
|
|
|
Returns desired case definition hashes, false otherwise. |
903
|
|
|
|
|
|
|
|
904
|
|
|
|
|
|
|
$tests = $tl->getTestCasesForTestSuite(123,1,1); |
905
|
|
|
|
|
|
|
|
906
|
|
|
|
|
|
|
=cut |
907
|
|
|
|
|
|
|
|
908
|
|
|
|
|
|
|
sub getTestCasesForTestSuite { |
909
|
|
|
|
|
|
|
my ($self,$testsuite_id,$deep,$details) = @_; |
910
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($self); |
911
|
|
|
|
|
|
|
|
912
|
|
|
|
|
|
|
$details = 'full' if $details; |
913
|
|
|
|
|
|
|
|
914
|
|
|
|
|
|
|
my $input = { |
915
|
|
|
|
|
|
|
devKey => $self->apikey, |
916
|
|
|
|
|
|
|
testsuiteid => $testsuite_id, |
917
|
|
|
|
|
|
|
deep => $deep, |
918
|
|
|
|
|
|
|
details => $details |
919
|
|
|
|
|
|
|
}; |
920
|
|
|
|
|
|
|
|
921
|
|
|
|
|
|
|
my $rpc = XMLRPC::Lite->proxy($self->apiurl); |
922
|
|
|
|
|
|
|
my $result = $rpc->call('tl.getTestCasesForTestSuite',$input); |
923
|
|
|
|
|
|
|
return [] if !$result->result; |
924
|
|
|
|
|
|
|
|
925
|
|
|
|
|
|
|
return [] if !scalar(keys(%{$result->result->[0]})); # No tests |
926
|
|
|
|
|
|
|
|
927
|
|
|
|
|
|
|
warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'}; |
928
|
|
|
|
|
|
|
return $result->result unless $result->result->[0]->{'code'}; |
929
|
|
|
|
|
|
|
return []; |
930
|
|
|
|
|
|
|
} |
931
|
|
|
|
|
|
|
|
932
|
|
|
|
|
|
|
=head2 B |
933
|
|
|
|
|
|
|
|
934
|
|
|
|
|
|
|
Gets the test case with the given external ID (e.g. projprefix-123) at provided version. |
935
|
|
|
|
|
|
|
|
936
|
|
|
|
|
|
|
=over 4 |
937
|
|
|
|
|
|
|
|
938
|
|
|
|
|
|
|
=item STRING C - desired external case ID |
939
|
|
|
|
|
|
|
|
940
|
|
|
|
|
|
|
=item STRING C - desired test case version. Defaults to most recent version. |
941
|
|
|
|
|
|
|
|
942
|
|
|
|
|
|
|
=back |
943
|
|
|
|
|
|
|
|
944
|
|
|
|
|
|
|
Returns desired case definition hash, false otherwise. |
945
|
|
|
|
|
|
|
|
946
|
|
|
|
|
|
|
$case = $tl->getTestCaseByExternalId('eee-123'); |
947
|
|
|
|
|
|
|
|
948
|
|
|
|
|
|
|
=cut |
949
|
|
|
|
|
|
|
|
950
|
|
|
|
|
|
|
sub getTestCaseByExternalId { |
951
|
|
|
|
|
|
|
my ($self,$case_id,$version) = @_; |
952
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($self); |
953
|
|
|
|
|
|
|
|
954
|
|
|
|
|
|
|
my $input = { |
955
|
|
|
|
|
|
|
devKey => $self->apikey, |
956
|
|
|
|
|
|
|
testcaseexternalid => $case_id, |
957
|
|
|
|
|
|
|
version => $version |
958
|
|
|
|
|
|
|
}; |
959
|
|
|
|
|
|
|
|
960
|
|
|
|
|
|
|
my $rpc = XMLRPC::Lite->proxy($self->apiurl); |
961
|
|
|
|
|
|
|
my $result = $rpc->call('tl.getTestCase',$input); |
962
|
|
|
|
|
|
|
warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'}; |
963
|
|
|
|
|
|
|
return $result->result->[0] unless $result->result->[0]->{'code'}; |
964
|
|
|
|
|
|
|
return 0; |
965
|
|
|
|
|
|
|
} |
966
|
|
|
|
|
|
|
|
967
|
|
|
|
|
|
|
=head2 B |
968
|
|
|
|
|
|
|
|
969
|
|
|
|
|
|
|
Gets the test case with the given internal ID at provided version. |
970
|
|
|
|
|
|
|
|
971
|
|
|
|
|
|
|
=over 4 |
972
|
|
|
|
|
|
|
|
973
|
|
|
|
|
|
|
=item STRING C - desired internal case ID |
974
|
|
|
|
|
|
|
|
975
|
|
|
|
|
|
|
=item STRING C - desired test case version. Defaults to most recent version. |
976
|
|
|
|
|
|
|
|
977
|
|
|
|
|
|
|
=back |
978
|
|
|
|
|
|
|
|
979
|
|
|
|
|
|
|
Returns desired case definition hash, false otherwise. |
980
|
|
|
|
|
|
|
|
981
|
|
|
|
|
|
|
$case = $tl->getTestCaseById(28474,5); |
982
|
|
|
|
|
|
|
|
983
|
|
|
|
|
|
|
=cut |
984
|
|
|
|
|
|
|
|
985
|
|
|
|
|
|
|
sub getTestCaseById { |
986
|
|
|
|
|
|
|
my ($self,$case_id,$version) = @_; |
987
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($self); |
988
|
|
|
|
|
|
|
|
989
|
|
|
|
|
|
|
my $input = { |
990
|
|
|
|
|
|
|
devKey => $self->apikey, |
991
|
|
|
|
|
|
|
testcaseid => $case_id, |
992
|
|
|
|
|
|
|
version => $version |
993
|
|
|
|
|
|
|
}; |
994
|
|
|
|
|
|
|
|
995
|
|
|
|
|
|
|
my $rpc = XMLRPC::Lite->proxy($self->apiurl); |
996
|
|
|
|
|
|
|
my $result = $rpc->call('tl.getTestCase',$input); |
997
|
|
|
|
|
|
|
warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'}; |
998
|
|
|
|
|
|
|
return $result->result->[0] unless $result->result->[0]->{'code'}; |
999
|
|
|
|
|
|
|
return 0; |
1000
|
|
|
|
|
|
|
} |
1001
|
|
|
|
|
|
|
|
1002
|
|
|
|
|
|
|
=head2 B |
1003
|
|
|
|
|
|
|
|
1004
|
|
|
|
|
|
|
Gets the test case with the given internal ID at provided version. |
1005
|
|
|
|
|
|
|
|
1006
|
|
|
|
|
|
|
=over 4 |
1007
|
|
|
|
|
|
|
|
1008
|
|
|
|
|
|
|
=item STRING C - desired internal case ID |
1009
|
|
|
|
|
|
|
|
1010
|
|
|
|
|
|
|
=item STRING C - parent suite's name |
1011
|
|
|
|
|
|
|
|
1012
|
|
|
|
|
|
|
=item STRING C - parent project's name |
1013
|
|
|
|
|
|
|
|
1014
|
|
|
|
|
|
|
=item STRING C (optional)- Full path to TC. Please see documentation for more info: http://jetmore.org/john/misc/phpdoc-testlink193-api/TestlinkAPI/TestlinkXMLRPCServer.html#getTestCaseIDByName |
1015
|
|
|
|
|
|
|
|
1016
|
|
|
|
|
|
|
=item STRING C (optional)- desired test case version. Defaults to most recent version. |
1017
|
|
|
|
|
|
|
|
1018
|
|
|
|
|
|
|
=back |
1019
|
|
|
|
|
|
|
|
1020
|
|
|
|
|
|
|
Returns desired case definition hash, false otherwise. |
1021
|
|
|
|
|
|
|
|
1022
|
|
|
|
|
|
|
$case = $tl->getTestCaseByName('nugCase','gravySuite','chickenProject'); |
1023
|
|
|
|
|
|
|
|
1024
|
|
|
|
|
|
|
=cut |
1025
|
|
|
|
|
|
|
|
1026
|
|
|
|
|
|
|
sub getTestCaseByName { |
1027
|
|
|
|
|
|
|
my ($self, $casename, $suitename, $projectname, $testcasepathname, $version) = @_; |
1028
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($self); |
1029
|
|
|
|
|
|
|
|
1030
|
|
|
|
|
|
|
my $input = { |
1031
|
|
|
|
|
|
|
devKey => $self->apikey, |
1032
|
|
|
|
|
|
|
testcasename => $casename, |
1033
|
|
|
|
|
|
|
testsuitename => $suitename, |
1034
|
|
|
|
|
|
|
testprojectname => $projectname, |
1035
|
|
|
|
|
|
|
testcasepathname => $testcasepathname |
1036
|
|
|
|
|
|
|
}; |
1037
|
|
|
|
|
|
|
|
1038
|
|
|
|
|
|
|
my $rpc = XMLRPC::Lite->proxy($self->apiurl); |
1039
|
|
|
|
|
|
|
my $result = $rpc->call('tl.getTestCaseIDByName',$input); |
1040
|
|
|
|
|
|
|
warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'}; |
1041
|
|
|
|
|
|
|
return $result->result->[0] unless $result->result->[0]->{'code'}; |
1042
|
|
|
|
|
|
|
return 0; |
1043
|
|
|
|
|
|
|
} |
1044
|
|
|
|
|
|
|
|
1045
|
|
|
|
|
|
|
=head2 B |
1046
|
|
|
|
|
|
|
|
1047
|
|
|
|
|
|
|
Gets the attachments for some case. |
1048
|
|
|
|
|
|
|
|
1049
|
|
|
|
|
|
|
=over 4 |
1050
|
|
|
|
|
|
|
|
1051
|
|
|
|
|
|
|
=item STRING C - desired external case ID |
1052
|
|
|
|
|
|
|
|
1053
|
|
|
|
|
|
|
=back |
1054
|
|
|
|
|
|
|
|
1055
|
|
|
|
|
|
|
Returns desired attachment definition hash, false otherwise. Content key is the file base64 encoded. |
1056
|
|
|
|
|
|
|
|
1057
|
|
|
|
|
|
|
$att = $tl->getTestCaseAttachments('CP-222'); |
1058
|
|
|
|
|
|
|
|
1059
|
|
|
|
|
|
|
=cut |
1060
|
|
|
|
|
|
|
|
1061
|
|
|
|
|
|
|
sub getTestCaseAttachments { |
1062
|
|
|
|
|
|
|
my ($self, $case_ext_id) = @_; |
1063
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($self); |
1064
|
|
|
|
|
|
|
|
1065
|
|
|
|
|
|
|
my $input = { |
1066
|
|
|
|
|
|
|
devKey => $self->apikey, |
1067
|
|
|
|
|
|
|
testcaseexternalid => $case_ext_id, |
1068
|
|
|
|
|
|
|
}; |
1069
|
|
|
|
|
|
|
|
1070
|
|
|
|
|
|
|
my $rpc = XMLRPC::Lite->proxy($self->apiurl); |
1071
|
|
|
|
|
|
|
my $result = $rpc->call('tl.getTestCaseAttachments',$input); |
1072
|
|
|
|
|
|
|
return 0 if (!$result->result); |
1073
|
|
|
|
|
|
|
warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'}; |
1074
|
|
|
|
|
|
|
return $result->result->[0] unless $result->result->[0]->{'code'}; |
1075
|
|
|
|
|
|
|
return 0; |
1076
|
|
|
|
|
|
|
} |
1077
|
|
|
|
|
|
|
|
1078
|
|
|
|
|
|
|
=head2 B |
1079
|
|
|
|
|
|
|
|
1080
|
|
|
|
|
|
|
Gets the test plans within given project id |
1081
|
|
|
|
|
|
|
|
1082
|
|
|
|
|
|
|
=over 4 |
1083
|
|
|
|
|
|
|
|
1084
|
|
|
|
|
|
|
=item STRING C - project ID |
1085
|
|
|
|
|
|
|
|
1086
|
|
|
|
|
|
|
=back |
1087
|
|
|
|
|
|
|
|
1088
|
|
|
|
|
|
|
Returns desired test plan definition hashes, false otherwise. |
1089
|
|
|
|
|
|
|
|
1090
|
|
|
|
|
|
|
$plans = $tl->getTestPlansForProject(23); |
1091
|
|
|
|
|
|
|
|
1092
|
|
|
|
|
|
|
=cut |
1093
|
|
|
|
|
|
|
|
1094
|
|
|
|
|
|
|
sub getTestPlansForProject { |
1095
|
|
|
|
|
|
|
my ($self,$project_id) = @_; |
1096
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($self); |
1097
|
|
|
|
|
|
|
|
1098
|
|
|
|
|
|
|
my $input = { |
1099
|
|
|
|
|
|
|
devKey => $self->apikey, |
1100
|
|
|
|
|
|
|
testprojectid => $project_id |
1101
|
|
|
|
|
|
|
}; |
1102
|
|
|
|
|
|
|
|
1103
|
|
|
|
|
|
|
my $rpc = XMLRPC::Lite->proxy($self->apiurl); |
1104
|
|
|
|
|
|
|
my $result = $rpc->call('tl.getProjectTestPlans',$input); |
1105
|
|
|
|
|
|
|
warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'}; |
1106
|
|
|
|
|
|
|
return $result->result unless $result->result->[0]->{'code'}; |
1107
|
|
|
|
|
|
|
return 0; |
1108
|
|
|
|
|
|
|
} |
1109
|
|
|
|
|
|
|
|
1110
|
|
|
|
|
|
|
=head2 B |
1111
|
|
|
|
|
|
|
|
1112
|
|
|
|
|
|
|
Gets the test plan within given project name |
1113
|
|
|
|
|
|
|
|
1114
|
|
|
|
|
|
|
=over 4 |
1115
|
|
|
|
|
|
|
|
1116
|
|
|
|
|
|
|
=item STRING C - desired test plan name |
1117
|
|
|
|
|
|
|
|
1118
|
|
|
|
|
|
|
=item STRING C - project name |
1119
|
|
|
|
|
|
|
|
1120
|
|
|
|
|
|
|
=back |
1121
|
|
|
|
|
|
|
|
1122
|
|
|
|
|
|
|
Returns desired test plan definition hash, false otherwise. |
1123
|
|
|
|
|
|
|
|
1124
|
|
|
|
|
|
|
$suites = $tl->getTestPlanByName('nugs','gravy'); |
1125
|
|
|
|
|
|
|
|
1126
|
|
|
|
|
|
|
=cut |
1127
|
|
|
|
|
|
|
|
1128
|
|
|
|
|
|
|
# I find it highly bizarre that the only 'by name' method exists for test plans, and it's the only test plan getter. |
1129
|
|
|
|
|
|
|
sub getTestPlanByName { |
1130
|
|
|
|
|
|
|
my ($self,$plan_name,$project_name) = @_; |
1131
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($self); |
1132
|
|
|
|
|
|
|
|
1133
|
|
|
|
|
|
|
my $input = { |
1134
|
|
|
|
|
|
|
devKey => $self->apikey, |
1135
|
|
|
|
|
|
|
testplanname => $plan_name, |
1136
|
|
|
|
|
|
|
testprojectname => $project_name |
1137
|
|
|
|
|
|
|
}; |
1138
|
|
|
|
|
|
|
|
1139
|
|
|
|
|
|
|
my $rpc = XMLRPC::Lite->proxy($self->apiurl); |
1140
|
|
|
|
|
|
|
my $result = $rpc->call('tl.getTestPlanByName',$input); |
1141
|
|
|
|
|
|
|
warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'}; |
1142
|
|
|
|
|
|
|
return $result->result->[0] unless $result->result->[0]->{'code'}; |
1143
|
|
|
|
|
|
|
return 0; |
1144
|
|
|
|
|
|
|
} |
1145
|
|
|
|
|
|
|
|
1146
|
|
|
|
|
|
|
=head2 B |
1147
|
|
|
|
|
|
|
|
1148
|
|
|
|
|
|
|
Gets the builds for given test plan |
1149
|
|
|
|
|
|
|
|
1150
|
|
|
|
|
|
|
=over 4 |
1151
|
|
|
|
|
|
|
|
1152
|
|
|
|
|
|
|
=item STRING C - desired test plan ID |
1153
|
|
|
|
|
|
|
|
1154
|
|
|
|
|
|
|
=back |
1155
|
|
|
|
|
|
|
|
1156
|
|
|
|
|
|
|
Returns desired builds' definition hashes, false otherwise. |
1157
|
|
|
|
|
|
|
|
1158
|
|
|
|
|
|
|
$builds = $tl->getBuildsForTestPlan(1234); |
1159
|
|
|
|
|
|
|
|
1160
|
|
|
|
|
|
|
=cut |
1161
|
|
|
|
|
|
|
|
1162
|
|
|
|
|
|
|
sub getBuildsForTestPlan { |
1163
|
|
|
|
|
|
|
my ($self,$plan_id) = @_; |
1164
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($self); |
1165
|
|
|
|
|
|
|
|
1166
|
|
|
|
|
|
|
my $input = { |
1167
|
|
|
|
|
|
|
devKey => $self->apikey, |
1168
|
|
|
|
|
|
|
testplanid => $plan_id |
1169
|
|
|
|
|
|
|
}; |
1170
|
|
|
|
|
|
|
|
1171
|
|
|
|
|
|
|
my $rpc = XMLRPC::Lite->proxy($self->apiurl); |
1172
|
|
|
|
|
|
|
my $result = $rpc->call('tl.getBuildsForTestPlan',$input); |
1173
|
|
|
|
|
|
|
warn $result->result->[0]->{'message'} if $result->result->[0]->{'code'}; |
1174
|
|
|
|
|
|
|
return $result->result unless $result->result->[0]->{'code'}; |
1175
|
|
|
|
|
|
|
return 0; |
1176
|
|
|
|
|
|
|
} |
1177
|
|
|
|
|
|
|
|
1178
|
|
|
|
|
|
|
=head2 B |
1179
|
|
|
|
|
|
|
|
1180
|
|
|
|
|
|
|
Gets the cases in provided test plan |
1181
|
|
|
|
|
|
|
|
1182
|
|
|
|
|
|
|
=over 4 |
1183
|
|
|
|
|
|
|
|
1184
|
|
|
|
|
|
|
=item STRING C - desired test plan ID |
1185
|
|
|
|
|
|
|
|
1186
|
|
|
|
|
|
|
=back |
1187
|
|
|
|
|
|
|
|
1188
|
|
|
|
|
|
|
Returns desired tests' definition hashes sorted by parent test plan ID, false otherwise. |
1189
|
|
|
|
|
|
|
|
1190
|
|
|
|
|
|
|
Example output: |
1191
|
|
|
|
|
|
|
{ 1234 => [{case1},{case2},...], 33212 => [cases...]} |
1192
|
|
|
|
|
|
|
|
1193
|
|
|
|
|
|
|
Example usage: |
1194
|
|
|
|
|
|
|
$builds = $tl->getTestCasesForTestPlan(1234); |
1195
|
|
|
|
|
|
|
|
1196
|
|
|
|
|
|
|
=cut |
1197
|
|
|
|
|
|
|
|
1198
|
|
|
|
|
|
|
sub getTestCasesForTestPlan { |
1199
|
|
|
|
|
|
|
my ($self,$plan_id) = @_; |
1200
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($self); |
1201
|
|
|
|
|
|
|
|
1202
|
|
|
|
|
|
|
my $input = { |
1203
|
|
|
|
|
|
|
devKey => $self->apikey, |
1204
|
|
|
|
|
|
|
testplanid => $plan_id |
1205
|
|
|
|
|
|
|
}; |
1206
|
|
|
|
|
|
|
|
1207
|
|
|
|
|
|
|
my $rpc = XMLRPC::Lite->proxy($self->apiurl); |
1208
|
|
|
|
|
|
|
my $result = $rpc->call('tl.getTestCasesForTestPlan',$input); |
1209
|
|
|
|
|
|
|
warn $result->result->{'message'} if $result->result->{'code'}; |
1210
|
|
|
|
|
|
|
return $result->result unless $result->result->{'code'}; |
1211
|
|
|
|
|
|
|
return 0; |
1212
|
|
|
|
|
|
|
} |
1213
|
|
|
|
|
|
|
|
1214
|
|
|
|
|
|
|
=head2 B |
1215
|
|
|
|
|
|
|
|
1216
|
|
|
|
|
|
|
Gets the latest build for the provided test plan |
1217
|
|
|
|
|
|
|
|
1218
|
|
|
|
|
|
|
=over 4 |
1219
|
|
|
|
|
|
|
|
1220
|
|
|
|
|
|
|
=item STRING C - desired test plan ID |
1221
|
|
|
|
|
|
|
|
1222
|
|
|
|
|
|
|
=back |
1223
|
|
|
|
|
|
|
|
1224
|
|
|
|
|
|
|
Returns desired build definition hash, false otherwise. |
1225
|
|
|
|
|
|
|
|
1226
|
|
|
|
|
|
|
$build = $tl->getLatestBuildForTestPlan(1234); |
1227
|
|
|
|
|
|
|
|
1228
|
|
|
|
|
|
|
=cut |
1229
|
|
|
|
|
|
|
|
1230
|
|
|
|
|
|
|
sub getLatestBuildForTestPlan { |
1231
|
|
|
|
|
|
|
my ($self,$plan_id) = @_; |
1232
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($self); |
1233
|
|
|
|
|
|
|
|
1234
|
|
|
|
|
|
|
my $input = { |
1235
|
|
|
|
|
|
|
devKey => $self->apikey, |
1236
|
|
|
|
|
|
|
tplanid => $plan_id, #documented arg, but that's LIES, apparently it wants the next one |
1237
|
|
|
|
|
|
|
testplanid => $plan_id |
1238
|
|
|
|
|
|
|
}; |
1239
|
|
|
|
|
|
|
|
1240
|
|
|
|
|
|
|
my $rpc = XMLRPC::Lite->proxy($self->apiurl); |
1241
|
|
|
|
|
|
|
my $result = $rpc->call('tl.getLatestBuildForTestPlan',$input); |
1242
|
|
|
|
|
|
|
|
1243
|
|
|
|
|
|
|
#Handle mixed return type |
1244
|
|
|
|
|
|
|
my $res = $result->result; |
1245
|
|
|
|
|
|
|
$res = [$res] if reftype($res) eq 'HASH'; |
1246
|
|
|
|
|
|
|
|
1247
|
|
|
|
|
|
|
warn $res->[0]->{'message'} if $res->[0]->{'code'}; |
1248
|
|
|
|
|
|
|
return $res->[0] unless $res->[0]->{'code'}; |
1249
|
|
|
|
|
|
|
return 0; |
1250
|
|
|
|
|
|
|
} |
1251
|
|
|
|
|
|
|
|
1252
|
|
|
|
|
|
|
=head2 B |
1253
|
|
|
|
|
|
|
|
1254
|
|
|
|
|
|
|
Gets the desired build in project id by name |
1255
|
|
|
|
|
|
|
|
1256
|
|
|
|
|
|
|
=over 4 |
1257
|
|
|
|
|
|
|
|
1258
|
|
|
|
|
|
|
=item STRING C - desired build's name |
1259
|
|
|
|
|
|
|
|
1260
|
|
|
|
|
|
|
=item INTEGER C - desired test project ID |
1261
|
|
|
|
|
|
|
|
1262
|
|
|
|
|
|
|
=back |
1263
|
|
|
|
|
|
|
|
1264
|
|
|
|
|
|
|
Returns desired build definition hash, false otherwise. |
1265
|
|
|
|
|
|
|
|
1266
|
|
|
|
|
|
|
$build = $tl->getBuildByName('foo',1234); |
1267
|
|
|
|
|
|
|
|
1268
|
|
|
|
|
|
|
=cut |
1269
|
|
|
|
|
|
|
|
1270
|
|
|
|
|
|
|
#TODO cache stuff, don't require proj id? |
1271
|
|
|
|
|
|
|
sub getBuildByName { |
1272
|
|
|
|
|
|
|
my ($self,$build_name,$project_id) = @_; |
1273
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($self); |
1274
|
|
|
|
|
|
|
|
1275
|
|
|
|
|
|
|
my $plans = $self->getTestPlansForProject($project_id); |
1276
|
|
|
|
|
|
|
for my $plan (@$plans) { |
1277
|
|
|
|
|
|
|
my $builds = $self->getBuildsForTestPlan($plan->{'id'}); |
1278
|
|
|
|
|
|
|
for my $build (@$builds) { |
1279
|
|
|
|
|
|
|
return $build if $build->{'name'} eq $build_name; |
1280
|
|
|
|
|
|
|
} |
1281
|
|
|
|
|
|
|
} |
1282
|
|
|
|
|
|
|
return 0; |
1283
|
|
|
|
|
|
|
} |
1284
|
|
|
|
|
|
|
|
1285
|
|
|
|
|
|
|
=head1 REPORTING METHODS |
1286
|
|
|
|
|
|
|
|
1287
|
|
|
|
|
|
|
=head2 B |
1288
|
|
|
|
|
|
|
|
1289
|
|
|
|
|
|
|
Gets the results summary for a test plan, even though what you really want is results by build/platform |
1290
|
|
|
|
|
|
|
|
1291
|
|
|
|
|
|
|
=over 4 |
1292
|
|
|
|
|
|
|
|
1293
|
|
|
|
|
|
|
=item INTEGER C - desired test plan |
1294
|
|
|
|
|
|
|
|
1295
|
|
|
|
|
|
|
=back |
1296
|
|
|
|
|
|
|
|
1297
|
|
|
|
|
|
|
Returns Hash describing test results. |
1298
|
|
|
|
|
|
|
|
1299
|
|
|
|
|
|
|
$res = $tl->getTotalsForTestPlan(2322); |
1300
|
|
|
|
|
|
|
|
1301
|
|
|
|
|
|
|
=cut |
1302
|
|
|
|
|
|
|
|
1303
|
|
|
|
|
|
|
sub getTotalsForTestPlan { |
1304
|
|
|
|
|
|
|
my ($self,$plan_id) = @_; |
1305
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($self); |
1306
|
|
|
|
|
|
|
|
1307
|
|
|
|
|
|
|
my $input = { |
1308
|
|
|
|
|
|
|
devKey => $self->apikey, |
1309
|
|
|
|
|
|
|
tplanid => $plan_id, #documented arg, but that's LIES, apparently it wants the next one |
1310
|
|
|
|
|
|
|
testplanid => $plan_id |
1311
|
|
|
|
|
|
|
}; |
1312
|
|
|
|
|
|
|
|
1313
|
|
|
|
|
|
|
my $rpc = XMLRPC::Lite->proxy($self->apiurl); |
1314
|
|
|
|
|
|
|
my $result = $rpc->call('tl.getTotalsForTestPlan',$input); |
1315
|
|
|
|
|
|
|
|
1316
|
|
|
|
|
|
|
warn $result->result->{'message'} if $result->result->{'code'}; |
1317
|
|
|
|
|
|
|
return $result->result unless $result->result->{'code'}; |
1318
|
|
|
|
|
|
|
return 0; |
1319
|
|
|
|
|
|
|
} |
1320
|
|
|
|
|
|
|
|
1321
|
|
|
|
|
|
|
=head1 EXPORT/IMPORT METHODS |
1322
|
|
|
|
|
|
|
|
1323
|
|
|
|
|
|
|
=head2 B |
1324
|
|
|
|
|
|
|
|
1325
|
|
|
|
|
|
|
Return all info for all (or only the specified) projects. |
1326
|
|
|
|
|
|
|
It will have the entire testsuite hierarchy and it's tests/attachments in an array of HASHREFs. |
1327
|
|
|
|
|
|
|
The idea would be that you then could encode as JSON/XML as a backup, or to facilitate migration to other systems. |
1328
|
|
|
|
|
|
|
|
1329
|
|
|
|
|
|
|
The project hashes will be what you would expect from getProjectByName calls. |
1330
|
|
|
|
|
|
|
Those will have a key 'testsuites' with a list of it's child testsuites. |
1331
|
|
|
|
|
|
|
These testsuites will themselves have 'testsuites' and 'test' keys describing their children. |
1332
|
|
|
|
|
|
|
Both the test and testsuite hashes will have an 'attachment' parameter with the base64 encoded attachment as a string if the get_attachments option is passed. |
1333
|
|
|
|
|
|
|
|
1334
|
|
|
|
|
|
|
WARNING: I have observed some locking related issues with cases/suites etc. |
1335
|
|
|
|
|
|
|
Sometimes calls to get tests/suites during dumps fails, sometimes subsequent calls to getTestSuites/getTestCasesForTestSuite fail. |
1336
|
|
|
|
|
|
|
If you are experiencing issues, try to put some wait() in there until it starts behaving right. |
1337
|
|
|
|
|
|
|
Alternatively, just XML dump the whole project and use XML::Simple or somesuch to get the project tree. |
1338
|
|
|
|
|
|
|
|
1339
|
|
|
|
|
|
|
ALSO: Attachment getting is not enabled due to the underlying XMLRPC calls appearing not to work. This option will be ignored until a workaround can be found. |
1340
|
|
|
|
|
|
|
|
1341
|
|
|
|
|
|
|
=over 4 |
1342
|
|
|
|
|
|
|
|
1343
|
|
|
|
|
|
|
=item INTEGER C (optional) - desired project |
1344
|
|
|
|
|
|
|
=item BOOLEAN C (optional) - whether or not to get attachments. Default false. |
1345
|
|
|
|
|
|
|
=item BOOLEAN C (optional) - Whether to return a flattened structure (you will need to corellate parent to child yourself, but this is faster due to not walking the tree). Preferred output for those not comfortable with doing tail recursion. |
1346
|
|
|
|
|
|
|
|
1347
|
|
|
|
|
|
|
=back |
1348
|
|
|
|
|
|
|
|
1349
|
|
|
|
|
|
|
Returns ARRAYREF describing everything. |
1350
|
|
|
|
|
|
|
|
1351
|
|
|
|
|
|
|
$ultradump = $tl->dump(); |
1352
|
|
|
|
|
|
|
$dumpWithAtts = $tl->dump('TestProject',1); |
1353
|
|
|
|
|
|
|
$flatDump = $tl->dump('testProj',0,1); |
1354
|
|
|
|
|
|
|
|
1355
|
|
|
|
|
|
|
=cut |
1356
|
|
|
|
|
|
|
|
1357
|
|
|
|
|
|
|
sub dump { |
1358
|
|
|
|
|
|
|
my ($self,$project,$attachment,$flat) = @_; |
1359
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($self); |
1360
|
|
|
|
|
|
|
|
1361
|
|
|
|
|
|
|
my $res = $self->_cacheProjectTree($project,$flat); |
1362
|
|
|
|
|
|
|
return [] if !$res; |
1363
|
|
|
|
|
|
|
|
1364
|
|
|
|
|
|
|
return $res if !$project || $flat; |
1365
|
|
|
|
|
|
|
foreach my $pj (@{$res}) { |
1366
|
|
|
|
|
|
|
return $pj if $pj->{'name'} eq $project; |
1367
|
|
|
|
|
|
|
} |
1368
|
|
|
|
|
|
|
croak "COULD NOT DUMP, SOMETHING HORRIBLY WRONG"; |
1369
|
|
|
|
|
|
|
} |
1370
|
|
|
|
|
|
|
|
1371
|
|
|
|
|
|
|
sub _cacheProjectTree { |
1372
|
|
|
|
|
|
|
my ($self,$project,$flat,$use_project_id,$get_tests) = @_; |
1373
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($self); |
1374
|
|
|
|
|
|
|
|
1375
|
|
|
|
|
|
|
$flat //= 0; |
1376
|
|
|
|
|
|
|
$use_project_id //= 0; |
1377
|
|
|
|
|
|
|
$get_tests //= 1; |
1378
|
|
|
|
|
|
|
|
1379
|
|
|
|
|
|
|
#Cache Projects |
1380
|
|
|
|
|
|
|
if (!scalar(@{$self->{'testtree'}})) { |
1381
|
|
|
|
|
|
|
$self->getProjects(); |
1382
|
|
|
|
|
|
|
} |
1383
|
|
|
|
|
|
|
|
1384
|
|
|
|
|
|
|
my @flattener = @{$self->{'testtree'}}; |
1385
|
|
|
|
|
|
|
|
1386
|
|
|
|
|
|
|
for my $projhash (@flattener) { |
1387
|
|
|
|
|
|
|
if ($use_project_id) { |
1388
|
|
|
|
|
|
|
next if $project && $project ne $projhash->{'id'} && (defined($projhash->{'type'}) && $projhash->{'type'} eq 'project'); |
1389
|
|
|
|
|
|
|
} else { |
1390
|
|
|
|
|
|
|
next if $project && $project ne $projhash->{'name'} && (defined($projhash->{'type'}) && $projhash->{'type'} eq 'project'); |
1391
|
|
|
|
|
|
|
} |
1392
|
|
|
|
|
|
|
|
1393
|
|
|
|
|
|
|
#If Testsuites are not defined, this must be a TS which we have not traversed yet, so go and get it |
1394
|
|
|
|
|
|
|
if (exists($projhash->{'type'}) && $projhash->{'type'} eq 'project') { |
1395
|
|
|
|
|
|
|
$projhash->{'testsuites'} = $self->getTLDTestSuitesForProject($projhash->{'id'},$get_tests); |
1396
|
|
|
|
|
|
|
} else { |
1397
|
|
|
|
|
|
|
$projhash->{'testsuites'} = $self->getTestSuitesForTestSuite($projhash->{'id'},$get_tests); |
1398
|
|
|
|
|
|
|
} |
1399
|
|
|
|
|
|
|
|
1400
|
|
|
|
|
|
|
$projhash->{'testsuites'} = [] if !$projhash->{'testsuites'}; |
1401
|
|
|
|
|
|
|
for my $tshash (@{$projhash->{'testsuites'}}) { |
1402
|
|
|
|
|
|
|
#Otherwise, push it's children to the end of our array so we can recurse as needed. |
1403
|
|
|
|
|
|
|
#I hope the designers of TL's schema were smart enough to not allow self-referential or circular suites.. |
1404
|
|
|
|
|
|
|
push(@flattener,clone $tshash); |
1405
|
|
|
|
|
|
|
} |
1406
|
|
|
|
|
|
|
|
1407
|
|
|
|
|
|
|
} |
1408
|
|
|
|
|
|
|
|
1409
|
|
|
|
|
|
|
#Keep this for simple searches in the future. |
1410
|
|
|
|
|
|
|
$self->{'flattree'} = clone \@flattener; |
1411
|
|
|
|
|
|
|
my @debuglist = map {$_->{'tests'}} @flattener; |
1412
|
|
|
|
|
|
|
return $self->{'flattree'} if $flat; |
1413
|
|
|
|
|
|
|
return $self->_expandTree($project,@flattener); |
1414
|
|
|
|
|
|
|
} |
1415
|
|
|
|
|
|
|
|
1416
|
|
|
|
|
|
|
sub _expandTree { |
1417
|
|
|
|
|
|
|
my $self = shift; |
1418
|
|
|
|
|
|
|
confess("Object parameters must be called by an instance") unless ref($self); |
1419
|
|
|
|
|
|
|
my $project = shift; |
1420
|
|
|
|
|
|
|
my @flattener = @_; |
1421
|
|
|
|
|
|
|
#The following algorithm relies implicitly on pass-by-reference. |
1422
|
|
|
|
|
|
|
#So we have a flat array of testsuites we want to map into parent-child relationships. |
1423
|
|
|
|
|
|
|
my ($i,$j); |
1424
|
|
|
|
|
|
|
foreach my $suite (@flattener) { |
1425
|
|
|
|
|
|
|
if (defined($suite->{'type'}) && $suite->{'type'} eq 'project') { |
1426
|
|
|
|
|
|
|
#Then skip it, since it's not a suite. |
1427
|
|
|
|
|
|
|
shift @flattener; |
1428
|
|
|
|
|
|
|
next; |
1429
|
|
|
|
|
|
|
} |
1430
|
|
|
|
|
|
|
|
1431
|
|
|
|
|
|
|
#This means we need to walk the hierarchy of every project, or just the one we passed |
1432
|
|
|
|
|
|
|
for ($j=0; $j < scalar(@{$self->{'testtree'}}); $j++) { |
1433
|
|
|
|
|
|
|
#If we have a project, skip the other ones |
1434
|
|
|
|
|
|
|
next unless $project && $self->{'testtree'}->[$j]->{'name'} eq $project; |
1435
|
|
|
|
|
|
|
|
1436
|
|
|
|
|
|
|
#Get the ball rolling if we have to |
1437
|
|
|
|
|
|
|
$self->{'testtree'}->[$j]->{'testsuites'} = $self->getTLDTestSuitesForProject($self->{'testtree'}->[$j]->{'id'},1) if !defined($self->{'testtree'}->[$j]->{'testsuites'}); |
1438
|
|
|
|
|
|
|
|
1439
|
|
|
|
|
|
|
#So, let's tail recurse over the testsuites. |
1440
|
|
|
|
|
|
|
for ($i=0; $i < scalar(@{$self->{'testtree'}->[$j]->{'testsuites'}}); $i++) { |
1441
|
|
|
|
|
|
|
my $tailRecurseTSWalker = sub { |
1442
|
|
|
|
|
|
|
my ($ts,$desired_ts) = @_; |
1443
|
|
|
|
|
|
|
|
1444
|
|
|
|
|
|
|
#Mark it down if we found it |
1445
|
|
|
|
|
|
|
if ($ts->{'id'} eq $desired_ts->{'parent_id'}) { |
1446
|
|
|
|
|
|
|
|
1447
|
|
|
|
|
|
|
#Set the REF's 'testsuites' param, and quit searching |
1448
|
|
|
|
|
|
|
$ts->{'testsuites'} = [] if !defined($ts->{'testsuites'}); |
1449
|
|
|
|
|
|
|
push(@{$ts->{'testsuites'}},$desired_ts); |
1450
|
|
|
|
|
|
|
$desired_ts->{'found'} = 1; |
1451
|
|
|
|
|
|
|
return; |
1452
|
|
|
|
|
|
|
} |
1453
|
|
|
|
|
|
|
|
1454
|
|
|
|
|
|
|
#If there's already (nonblank) hierarchy in the passed TS, then WE HAVE TO GO DEEPER |
1455
|
|
|
|
|
|
|
if (defined($ts->{'testsuites'}) && scalar(@{$desired_ts->{'testsuites'}})) { |
1456
|
|
|
|
|
|
|
for (my $i=0; $i < scalar(@{$ts->{'testsuites'}}); $i++) { |
1457
|
|
|
|
|
|
|
_tailRecurseTSWalker($ts->{'testsuites'}->[$i],$desired_ts); |
1458
|
|
|
|
|
|
|
} |
1459
|
|
|
|
|
|
|
} |
1460
|
|
|
|
|
|
|
|
1461
|
|
|
|
|
|
|
return; |
1462
|
|
|
|
|
|
|
}; |
1463
|
|
|
|
|
|
|
|
1464
|
|
|
|
|
|
|
&$tailRecurseTSWalker($self->{'testtree'}->[$j]->{'testsuites'}->[$i],$suite); |
1465
|
|
|
|
|
|
|
#OPTIMIZE: break out if we found it already |
1466
|
|
|
|
|
|
|
last if $suite->{'found'}; |
1467
|
|
|
|
|
|
|
} |
1468
|
|
|
|
|
|
|
last if $suite->{'found'}; |
1469
|
|
|
|
|
|
|
} |
1470
|
|
|
|
|
|
|
|
1471
|
|
|
|
|
|
|
#If we didn't find this one yet, as the hierarchy build is progressive, add it to the end until it gets picked up. |
1472
|
|
|
|
|
|
|
if (!$suite->{'found'}) { |
1473
|
|
|
|
|
|
|
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. |
1474
|
|
|
|
|
|
|
} else { |
1475
|
|
|
|
|
|
|
shift @flattener; |
1476
|
|
|
|
|
|
|
} |
1477
|
|
|
|
|
|
|
} |
1478
|
|
|
|
|
|
|
return $self->{'testtree'}; |
1479
|
|
|
|
|
|
|
} |
1480
|
|
|
|
|
|
|
|
1481
|
|
|
|
|
|
|
1; |
1482
|
|
|
|
|
|
|
|
1483
|
|
|
|
|
|
|
__END__ |