]>
Commit | Line | Data |
---|---|---|
84fb5b46 MKG |
1 | # BEGIN BPS TAGGED BLOCK {{{ |
2 | # | |
3 | # COPYRIGHT: | |
4 | # | |
3ffc5f4f | 5 | # This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC |
84fb5b46 MKG |
6 | # <sales@bestpractical.com> |
7 | # | |
8 | # (Except where explicitly superseded by other copyright notices) | |
9 | # | |
10 | # | |
11 | # LICENSE: | |
12 | # | |
13 | # This work is made available to you under the terms of Version 2 of | |
14 | # the GNU General Public License. A copy of that license should have | |
15 | # been provided with this software, but in any event can be snarfed | |
16 | # from www.gnu.org. | |
17 | # | |
18 | # This work is distributed in the hope that it will be useful, but | |
19 | # WITHOUT ANY WARRANTY; without even the implied warranty of | |
20 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
21 | # General Public License for more details. | |
22 | # | |
23 | # You should have received a copy of the GNU General Public License | |
24 | # along with this program; if not, write to the Free Software | |
25 | # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA | |
26 | # 02110-1301 or visit their web page on the internet at | |
27 | # http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. | |
28 | # | |
29 | # | |
30 | # CONTRIBUTION SUBMISSION POLICY: | |
31 | # | |
32 | # (The following paragraph is not intended to limit the rights granted | |
33 | # to you to modify and distribute this software under the terms of | |
34 | # the GNU General Public License and is only of importance to you if | |
35 | # you choose to contribute your changes and enhancements to the | |
36 | # community by submitting them to Best Practical Solutions, LLC.) | |
37 | # | |
38 | # By intentionally submitting any modifications, corrections or | |
39 | # derivatives to this work, or any other work intended for use with | |
40 | # Request Tracker, to Best Practical Solutions, LLC, you confirm that | |
41 | # you are the copyright holder for those contributions and you grant | |
42 | # Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, | |
43 | # royalty-free, perpetual, license to use, copy, create derivative | |
44 | # works based on those contributions, and sublicense and distribute | |
45 | # those contributions and any derivatives thereof. | |
46 | # | |
47 | # END BPS TAGGED BLOCK }}} | |
48 | ||
49 | package RT::Test; | |
50 | ||
51 | use strict; | |
52 | use warnings; | |
53 | ||
3ffc5f4f | 54 | BEGIN { $^W = 1 }; |
84fb5b46 MKG |
55 | |
56 | use base 'Test::More'; | |
57 | ||
3ffc5f4f MKG |
58 | BEGIN { |
59 | # Warn about role consumers overriding role methods so we catch it in tests. | |
60 | $ENV{PERL_ROLE_OVERRIDE_WARN} = 1; | |
61 | } | |
62 | ||
403d7b0b MKG |
63 | # We use the Test::NoWarnings catching and reporting functionality, but need to |
64 | # wrap it in our own special handler because of the warn handler installed via | |
65 | # RT->InitLogging(). | |
66 | require Test::NoWarnings; | |
67 | ||
68 | my $Test_NoWarnings_Catcher = $SIG{__WARN__}; | |
69 | my $check_warnings_in_end = 1; | |
70 | ||
84fb5b46 MKG |
71 | use Socket; |
72 | use File::Temp qw(tempfile); | |
73 | use File::Path qw(mkpath); | |
74 | use File::Spec; | |
3ffc5f4f MKG |
75 | use File::Which qw(); |
76 | use Scalar::Util qw(blessed); | |
84fb5b46 | 77 | |
403d7b0b | 78 | our @EXPORT = qw(is_empty diag parse_mail works fails plan done_testing); |
84fb5b46 MKG |
79 | |
80 | my %tmp = ( | |
81 | directory => undef, | |
82 | config => { | |
83 | RT => undef, | |
84 | apache => undef, | |
85 | }, | |
86 | mailbox => undef, | |
87 | ); | |
88 | ||
89 | my %rttest_opt; | |
90 | ||
91 | =head1 NAME | |
92 | ||
93 | RT::Test - RT Testing | |
94 | ||
95 | =head1 NOTES | |
96 | ||
97 | =head2 COVERAGE | |
98 | ||
99 | To run the rt test suite with coverage support, install L<Devel::Cover> and run: | |
100 | ||
101 | make test RT_DBA_USER=.. RT_DBA_PASSWORD=.. HARNESS_PERL_SWITCHES=-MDevel::Cover | |
102 | cover -ignore_re '^var/mason_data/' -ignore_re '^t/' | |
103 | ||
104 | The coverage tests have DevelMode turned off, and have | |
105 | C<named_component_subs> enabled for L<HTML::Mason> to avoid an optimizer | |
106 | problem in Perl that hides the top-level optree from L<Devel::Cover>. | |
107 | ||
108 | =cut | |
109 | ||
110 | our $port; | |
111 | our @SERVERS; | |
112 | ||
403d7b0b MKG |
113 | BEGIN { |
114 | delete $ENV{$_} for qw/LANGUAGE LC_ALL LC_MESSAGES LANG/; | |
115 | $ENV{LANG} = "C"; | |
116 | }; | |
117 | ||
84fb5b46 MKG |
118 | sub import { |
119 | my $class = shift; | |
120 | my %args = %rttest_opt = @_; | |
121 | ||
c36a7e1d MKG |
122 | $rttest_opt{'nodb'} = $args{'nodb'} = 1 if $^C; |
123 | ||
84fb5b46 MKG |
124 | # Spit out a plan (if we got one) *before* we load modules |
125 | if ( $args{'tests'} ) { | |
403d7b0b | 126 | plan( tests => $args{'tests'} ) |
84fb5b46 MKG |
127 | unless $args{'tests'} eq 'no_declare'; |
128 | } | |
129 | elsif ( exists $args{'tests'} ) { | |
130 | # do nothing if they say "tests => undef" - let them make the plan | |
131 | } | |
132 | elsif ( $args{'skip_all'} ) { | |
403d7b0b | 133 | plan(skip_all => $args{'skip_all'}); |
84fb5b46 MKG |
134 | } |
135 | else { | |
136 | $class->builder->no_plan unless $class->builder->has_plan; | |
137 | } | |
138 | ||
139 | push @{ $args{'plugins'} ||= [] }, @{ $args{'requires'} } | |
140 | if $args{'requires'}; | |
141 | push @{ $args{'plugins'} ||= [] }, $args{'testing'} | |
142 | if $args{'testing'}; | |
3ffc5f4f MKG |
143 | push @{ $args{'plugins'} ||= [] }, split " ", $ENV{RT_TEST_PLUGINS} |
144 | if $ENV{RT_TEST_PLUGINS}; | |
84fb5b46 MKG |
145 | |
146 | $class->bootstrap_tempdir; | |
147 | ||
148 | $class->bootstrap_port; | |
149 | ||
150 | $class->bootstrap_plugins_paths( %args ); | |
151 | ||
152 | $class->bootstrap_config( %args ); | |
153 | ||
154 | use RT; | |
84fb5b46 | 155 | |
3ffc5f4f | 156 | RT::LoadConfig; |
84fb5b46 | 157 | |
84fb5b46 | 158 | RT::InitPluginPaths(); |
dab09ea8 MKG |
159 | RT::InitClasses(); |
160 | ||
3ffc5f4f | 161 | RT::I18N->Init(); |
dab09ea8 | 162 | $class->bootstrap_db( %args ); |
84fb5b46 MKG |
163 | |
164 | __reconnect_rt() | |
165 | unless $args{nodb}; | |
166 | ||
403d7b0b | 167 | __init_logging(); |
84fb5b46 MKG |
168 | |
169 | RT->Plugins; | |
170 | ||
84fb5b46 MKG |
171 | RT->Config->PostLoadCheck; |
172 | ||
173 | $class->set_config_wrapper; | |
174 | ||
3ffc5f4f MKG |
175 | $class->encode_output; |
176 | ||
84fb5b46 MKG |
177 | my $screen_logger = $RT::Logger->remove( 'screen' ); |
178 | require Log::Dispatch::Perl; | |
179 | $RT::Logger->add( Log::Dispatch::Perl->new | |
180 | ( name => 'rttest', | |
181 | min_level => $screen_logger->min_level, | |
182 | action => { error => 'warn', | |
183 | critical => 'warn' } ) ); | |
184 | ||
185 | # XXX: this should really be totally isolated environment so we | |
186 | # can parallelize and be sane | |
187 | mkpath [ $RT::MasonSessionDir ] | |
188 | if RT->Config->Get('DatabaseType'); | |
189 | ||
190 | my $level = 1; | |
191 | while ( my ($package) = caller($level-1) ) { | |
192 | last unless $package =~ /Test/; | |
193 | $level++; | |
194 | } | |
195 | ||
3ffc5f4f MKG |
196 | # By default we test HTML templates, but text templates are |
197 | # available on request | |
198 | if ( $args{'text_templates'} ) { | |
199 | $class->switch_templates_ok('text'); | |
200 | } | |
201 | ||
84fb5b46 | 202 | Test::More->export_to_level($level); |
403d7b0b | 203 | Test::NoWarnings->export_to_level($level); |
84fb5b46 | 204 | |
403d7b0b | 205 | # Blow away symbols we redefine to avoid warnings. |
84fb5b46 MKG |
206 | # better than "no warnings 'redefine'" because we might accidentally |
207 | # suppress a mistaken redefinition | |
208 | no strict 'refs'; | |
209 | delete ${ caller($level) . '::' }{diag}; | |
403d7b0b MKG |
210 | delete ${ caller($level) . '::' }{plan}; |
211 | delete ${ caller($level) . '::' }{done_testing}; | |
84fb5b46 MKG |
212 | __PACKAGE__->export_to_level($level); |
213 | } | |
214 | ||
215 | sub is_empty($;$) { | |
216 | my ($v, $d) = shift; | |
217 | local $Test::Builder::Level = $Test::Builder::Level + 1; | |
218 | return Test::More::ok(1, $d) unless defined $v; | |
219 | return Test::More::ok(1, $d) unless length $v; | |
220 | return Test::More::is($v, '', $d); | |
221 | } | |
222 | ||
223 | my $created_new_db; # have we created new db? mainly for parallel testing | |
224 | ||
225 | sub db_requires_no_dba { | |
226 | my $self = shift; | |
227 | my $db_type = RT->Config->Get('DatabaseType'); | |
228 | return 1 if $db_type eq 'SQLite'; | |
229 | } | |
230 | ||
231 | sub bootstrap_port { | |
232 | my $class = shift; | |
233 | ||
234 | my %ports; | |
235 | ||
236 | # Determine which ports are in use | |
237 | use Fcntl qw(:DEFAULT :flock); | |
238 | my $portfile = "$tmp{'directory'}/../ports"; | |
239 | sysopen(PORTS, $portfile, O_RDWR|O_CREAT) | |
240 | or die "Can't write to ports file $portfile: $!"; | |
241 | flock(PORTS, LOCK_EX) | |
242 | or die "Can't write-lock ports file $portfile: $!"; | |
243 | $ports{$_}++ for split ' ', join("",<PORTS>); | |
244 | ||
245 | # Pick a random port, checking that the port isn't in our in-use | |
246 | # list, and that something isn't already listening there. | |
247 | { | |
248 | $port = 1024 + int rand(10_000) + $$ % 1024; | |
249 | redo if $ports{$port}; | |
250 | ||
251 | # There is a race condition in here, where some non-RT::Test | |
252 | # process claims the port after we check here but before our | |
253 | # server binds. However, since we mostly care about race | |
254 | # conditions with ourselves under high concurrency, this is | |
255 | # generally good enough. | |
256 | my $paddr = sockaddr_in( $port, inet_aton('localhost') ); | |
257 | socket( SOCK, PF_INET, SOCK_STREAM, getprotobyname('tcp') ) | |
258 | or die "socket: $!"; | |
259 | if ( connect( SOCK, $paddr ) ) { | |
260 | close(SOCK); | |
261 | redo; | |
262 | } | |
263 | close(SOCK); | |
264 | } | |
265 | ||
266 | $ports{$port}++; | |
267 | ||
268 | # Write back out the in-use ports | |
269 | seek(PORTS, 0, 0); | |
270 | truncate(PORTS, 0); | |
271 | print PORTS "$_\n" for sort {$a <=> $b} keys %ports; | |
272 | close(PORTS) or die "Can't close ports file: $!"; | |
273 | } | |
274 | ||
275 | sub bootstrap_tempdir { | |
276 | my $self = shift; | |
277 | my ($test_dir, $test_file) = ('t', ''); | |
278 | ||
279 | if (File::Spec->rel2abs($0) =~ m{(?:^|[\\/])(x?t)[/\\](.*)}) { | |
280 | $test_dir = $1; | |
281 | $test_file = "$2-"; | |
282 | $test_file =~ s{[/\\]}{-}g; | |
283 | } | |
284 | ||
285 | my $dir_name = File::Spec->rel2abs("$test_dir/tmp"); | |
286 | mkpath( $dir_name ); | |
287 | return $tmp{'directory'} = File::Temp->newdir( | |
288 | "${test_file}XXXXXXXX", | |
289 | DIR => $dir_name | |
290 | ); | |
291 | } | |
292 | ||
293 | sub bootstrap_config { | |
294 | my $self = shift; | |
295 | my %args = @_; | |
296 | ||
297 | $tmp{'config'}{'RT'} = File::Spec->catfile( | |
298 | "$tmp{'directory'}", 'RT_SiteConfig.pm' | |
299 | ); | |
300 | open( my $config, '>', $tmp{'config'}{'RT'} ) | |
301 | or die "Couldn't open $tmp{'config'}{'RT'}: $!"; | |
302 | ||
303 | my $dbname = $ENV{RT_TEST_PARALLEL}? "rt4test_$port" : "rt4test"; | |
304 | print $config qq{ | |
305 | Set( \$WebDomain, "localhost"); | |
306 | Set( \$WebPort, $port); | |
307 | Set( \$WebPath, ""); | |
3ffc5f4f | 308 | Set( \@LexiconLanguages, qw(en zh_TW zh_CN fr ja)); |
84fb5b46 | 309 | Set( \$RTAddressRegexp , qr/^bad_re_that_doesnt_match\$/i); |
3ffc5f4f | 310 | Set( \$ShowHistory, "always"); |
84fb5b46 MKG |
311 | }; |
312 | if ( $ENV{'RT_TEST_DB_SID'} ) { # oracle case | |
313 | print $config "Set( \$DatabaseName , '$ENV{'RT_TEST_DB_SID'}' );\n"; | |
314 | print $config "Set( \$DatabaseUser , '$dbname');\n"; | |
315 | } else { | |
316 | print $config "Set( \$DatabaseName , '$dbname');\n"; | |
317 | print $config "Set( \$DatabaseUser , 'u${dbname}');\n"; | |
318 | } | |
5b0d0914 MKG |
319 | if ( $ENV{'RT_TEST_DB_HOST'} ) { |
320 | print $config "Set( \$DatabaseHost , '$ENV{'RT_TEST_DB_HOST'}');\n"; | |
321 | } | |
84fb5b46 MKG |
322 | |
323 | if ( $args{'plugins'} ) { | |
324 | print $config "Set( \@Plugins, qw(". join( ' ', @{ $args{'plugins'} } ) .") );\n"; | |
403d7b0b MKG |
325 | |
326 | my $plugin_data = File::Spec->rel2abs("t/data/plugins"); | |
327 | print $config qq[\$RT::PluginPath = "$plugin_data";\n]; | |
84fb5b46 MKG |
328 | } |
329 | ||
330 | if ( $INC{'Devel/Cover.pm'} ) { | |
331 | print $config "Set( \$DevelMode, 0 );\n"; | |
332 | } | |
333 | elsif ( $ENV{RT_TEST_DEVEL} ) { | |
334 | print $config "Set( \$DevelMode, 1 );\n"; | |
335 | } | |
336 | else { | |
337 | print $config "Set( \$DevelMode, 0 );\n"; | |
338 | } | |
339 | ||
340 | $self->bootstrap_logging( $config ); | |
341 | ||
342 | # set mail catcher | |
343 | my $mail_catcher = $tmp{'mailbox'} = File::Spec->catfile( | |
344 | $tmp{'directory'}->dirname, 'mailbox.eml' | |
345 | ); | |
346 | print $config <<END; | |
347 | Set( \$MailCommand, sub { | |
348 | my \$MIME = shift; | |
349 | ||
350 | open( my \$handle, '>>', '$mail_catcher' ) | |
351 | or die "Unable to open '$mail_catcher' for appending: \$!"; | |
352 | ||
353 | \$MIME->print(\$handle); | |
354 | print \$handle "%% split me! %%\n"; | |
355 | close \$handle; | |
356 | } ); | |
357 | END | |
358 | ||
359 | $self->bootstrap_more_config($config, \%args); | |
360 | ||
361 | print $config $args{'config'} if $args{'config'}; | |
362 | ||
363 | print $config "\n1;\n"; | |
364 | $ENV{'RT_SITE_CONFIG'} = $tmp{'config'}{'RT'}; | |
365 | close $config; | |
366 | ||
367 | return $config; | |
368 | } | |
369 | ||
370 | sub bootstrap_more_config { } | |
371 | ||
372 | sub bootstrap_logging { | |
373 | my $self = shift; | |
374 | my $config = shift; | |
375 | ||
376 | # prepare file for logging | |
377 | $tmp{'log'}{'RT'} = File::Spec->catfile( | |
378 | "$tmp{'directory'}", 'rt.debug.log' | |
379 | ); | |
380 | open( my $fh, '>', $tmp{'log'}{'RT'} ) | |
381 | or die "Couldn't open $tmp{'config'}{'RT'}: $!"; | |
382 | # make world writable so apache under different user | |
383 | # can write into it | |
384 | chmod 0666, $tmp{'log'}{'RT'}; | |
385 | ||
386 | print $config <<END; | |
387 | Set( \$LogToSyslog , undef); | |
3ffc5f4f | 388 | Set( \$LogToSTDERR , "warning"); |
84fb5b46 MKG |
389 | Set( \$LogToFile, 'debug' ); |
390 | Set( \$LogDir, q{$tmp{'directory'}} ); | |
391 | Set( \$LogToFileNamed, 'rt.debug.log' ); | |
392 | END | |
393 | } | |
394 | ||
395 | sub set_config_wrapper { | |
396 | my $self = shift; | |
397 | ||
398 | my $old_sub = \&RT::Config::Set; | |
399 | no warnings 'redefine'; | |
400 | *RT::Config::Set = sub { | |
401 | # Determine if the caller is either from a test script, or | |
402 | # from helper functions called by test script to alter | |
403 | # configuration that should be written. This is necessary | |
404 | # because some extensions (RTIR, for example) temporarily swap | |
405 | # configuration values out and back in Mason during requests. | |
406 | my @caller = caller(1); # preserve list context | |
407 | @caller = caller(0) unless @caller; | |
408 | ||
409 | if ( ($caller[1]||'') =~ /\.t$/) { | |
410 | my ($self, $name) = @_; | |
411 | my $type = $RT::Config::META{$name}->{'Type'} || 'SCALAR'; | |
412 | my %sigils = ( | |
413 | HASH => '%', | |
414 | ARRAY => '@', | |
415 | SCALAR => '$', | |
416 | ); | |
417 | my $sigil = $sigils{$type} || $sigils{'SCALAR'}; | |
3ffc5f4f | 418 | open( my $fh, '<', $tmp{'config'}{'RT'} ) |
84fb5b46 | 419 | or die "Couldn't open config file: $!"; |
3ffc5f4f MKG |
420 | my @lines; |
421 | while (<$fh>) { | |
422 | if (not @lines or /^Set\(/) { | |
423 | push @lines, $_; | |
424 | } else { | |
425 | $lines[-1] .= $_; | |
426 | } | |
427 | } | |
428 | close $fh; | |
429 | ||
430 | # Traim trailing newlines and "1;" | |
431 | $lines[-1] =~ s/(^1;\n|^\n)*\Z//m; | |
432 | ||
433 | # Remove any previous definitions of this var | |
434 | @lines = grep {not /^Set\(\s*\Q$sigil$name\E\b/} @lines; | |
435 | ||
436 | # Format the new value for output | |
84fb5b46 MKG |
437 | require Data::Dumper; |
438 | local $Data::Dumper::Terse = 1; | |
439 | my $dump = Data::Dumper::Dumper([@_[2 .. $#_]]); | |
3ffc5f4f MKG |
440 | $dump =~ s/;?\s+\Z//; |
441 | push @lines, "Set( ${sigil}${name}, \@{". $dump ."});\n"; | |
442 | push @lines, "\n1;\n"; | |
443 | ||
444 | # Re-write the configuration file | |
445 | open( $fh, '>', $tmp{'config'}{'RT'} ) | |
446 | or die "Couldn't open config file: $!"; | |
447 | print $fh $_ for @lines; | |
84fb5b46 MKG |
448 | close $fh; |
449 | ||
450 | if ( @SERVERS ) { | |
451 | warn "you're changing config option in a test file" | |
452 | ." when server is active"; | |
453 | } | |
454 | } | |
455 | return $old_sub->(@_); | |
456 | }; | |
457 | } | |
458 | ||
3ffc5f4f MKG |
459 | sub encode_output { |
460 | my $builder = Test::More->builder; | |
461 | binmode $builder->output, ":encoding(utf8)"; | |
462 | binmode $builder->failure_output, ":encoding(utf8)"; | |
463 | binmode $builder->todo_output, ":encoding(utf8)"; | |
464 | } | |
465 | ||
84fb5b46 MKG |
466 | sub bootstrap_db { |
467 | my $self = shift; | |
468 | my %args = @_; | |
469 | ||
470 | unless (defined $ENV{'RT_DBA_USER'} && defined $ENV{'RT_DBA_PASSWORD'}) { | |
471 | Test::More::BAIL_OUT( | |
472 | "RT_DBA_USER and RT_DBA_PASSWORD environment variables need" | |
473 | ." to be set in order to run 'make test'" | |
474 | ) unless $self->db_requires_no_dba; | |
475 | } | |
476 | ||
477 | require RT::Handle; | |
478 | if (my $forceopt = $ENV{RT_TEST_FORCE_OPT}) { | |
479 | Test::More::diag "forcing $forceopt"; | |
480 | $args{$forceopt}=1; | |
481 | } | |
482 | ||
b5747ff2 MKG |
483 | # Short-circuit the rest of ourselves if we don't want a db |
484 | if ($args{nodb}) { | |
485 | __drop_database(); | |
486 | return; | |
487 | } | |
84fb5b46 MKG |
488 | |
489 | my $db_type = RT->Config->Get('DatabaseType'); | |
490 | __create_database(); | |
491 | __reconnect_rt('as dba'); | |
492 | $RT::Handle->InsertSchema; | |
493 | $RT::Handle->InsertACL unless $db_type eq 'Oracle'; | |
494 | ||
403d7b0b | 495 | __init_logging(); |
84fb5b46 MKG |
496 | __reconnect_rt(); |
497 | ||
498 | $RT::Handle->InsertInitialData | |
499 | unless $args{noinitialdata}; | |
500 | ||
501 | $RT::Handle->InsertData( $RT::EtcPath . "/initialdata" ) | |
502 | unless $args{noinitialdata} or $args{nodata}; | |
503 | ||
504 | $self->bootstrap_plugins_db( %args ); | |
505 | } | |
506 | ||
507 | sub bootstrap_plugins_paths { | |
508 | my $self = shift; | |
509 | my %args = @_; | |
510 | ||
511 | return unless $args{'plugins'}; | |
512 | my @plugins = @{ $args{'plugins'} }; | |
513 | ||
514 | my $cwd; | |
515 | if ( $args{'testing'} ) { | |
516 | require Cwd; | |
517 | $cwd = Cwd::getcwd(); | |
518 | } | |
519 | ||
520 | require RT::Plugin; | |
521 | my $old_func = \&RT::Plugin::_BasePath; | |
522 | no warnings 'redefine'; | |
523 | *RT::Plugin::_BasePath = sub { | |
524 | my $name = $_[0]->{'name'}; | |
525 | ||
526 | return $cwd if $args{'testing'} && $name eq $args{'testing'}; | |
527 | ||
528 | if ( grep $name eq $_, @plugins ) { | |
529 | my $variants = join "(?:|::|-|_)", map "\Q$_\E", split /::/, $name; | |
3ffc5f4f | 530 | my ($path) = map $ENV{$_}, grep /^RT_TEST_PLUGIN_(?:$variants).*_ROOT$/i, keys %ENV; |
84fb5b46 MKG |
531 | return $path if $path; |
532 | } | |
533 | return $old_func->(@_); | |
534 | }; | |
535 | } | |
536 | ||
537 | sub bootstrap_plugins_db { | |
538 | my $self = shift; | |
539 | my %args = @_; | |
540 | ||
541 | return unless $args{'plugins'}; | |
542 | ||
543 | require File::Spec; | |
544 | ||
545 | my @plugins = @{ $args{'plugins'} }; | |
546 | foreach my $name ( @plugins ) { | |
547 | my $plugin = RT::Plugin->new( name => $name ); | |
548 | Test::More::diag( "Initializing DB for the $name plugin" ) | |
549 | if $ENV{'TEST_VERBOSE'}; | |
550 | ||
551 | my $etc_path = $plugin->Path('etc'); | |
552 | Test::More::diag( "etc path of the plugin is '$etc_path'" ) | |
553 | if $ENV{'TEST_VERBOSE'}; | |
554 | ||
555 | unless ( -e $etc_path ) { | |
556 | # We can't tell if the plugin has no data, or we screwed up the etc/ path | |
557 | Test::More::ok(1, "There is no etc dir: no schema" ); | |
558 | Test::More::ok(1, "There is no etc dir: no ACLs" ); | |
559 | Test::More::ok(1, "There is no etc dir: no data" ); | |
560 | next; | |
561 | } | |
562 | ||
563 | __reconnect_rt('as dba'); | |
564 | ||
565 | { # schema | |
566 | my ($ret, $msg) = $RT::Handle->InsertSchema( undef, $etc_path ); | |
567 | Test::More::ok($ret || $msg =~ /^Couldn't find schema/, "Created schema: ".($msg||'')); | |
568 | } | |
569 | ||
570 | { # ACLs | |
571 | my ($ret, $msg) = $RT::Handle->InsertACL( undef, $etc_path ); | |
572 | Test::More::ok($ret || $msg =~ /^Couldn't find ACLs/, "Created ACL: ".($msg||'')); | |
573 | } | |
574 | ||
575 | # data | |
576 | my $data_file = File::Spec->catfile( $etc_path, 'initialdata' ); | |
577 | if ( -e $data_file ) { | |
578 | __reconnect_rt(); | |
579 | my ($ret, $msg) = $RT::Handle->InsertData( $data_file );; | |
580 | Test::More::ok($ret, "Inserted data".($msg||'')); | |
581 | } else { | |
582 | Test::More::ok(1, "There is no data file" ); | |
583 | } | |
584 | } | |
585 | __reconnect_rt(); | |
586 | } | |
587 | ||
588 | sub _get_dbh { | |
589 | my ($dsn, $user, $pass) = @_; | |
590 | if ( $dsn =~ /Oracle/i ) { | |
591 | $ENV{'NLS_LANG'} = "AMERICAN_AMERICA.AL32UTF8"; | |
592 | $ENV{'NLS_NCHAR'} = "AL32UTF8"; | |
593 | } | |
594 | my $dbh = DBI->connect( | |
595 | $dsn, $user, $pass, | |
596 | { RaiseError => 0, PrintError => 1 }, | |
597 | ); | |
598 | unless ( $dbh ) { | |
599 | my $msg = "Failed to connect to $dsn as user '$user': ". $DBI::errstr; | |
600 | print STDERR $msg; exit -1; | |
601 | } | |
602 | return $dbh; | |
603 | } | |
604 | ||
605 | sub __create_database { | |
606 | # bootstrap with dba cred | |
607 | my $dbh = _get_dbh( | |
608 | RT::Handle->SystemDSN, | |
609 | $ENV{RT_DBA_USER}, $ENV{RT_DBA_PASSWORD} | |
610 | ); | |
611 | ||
612 | unless ( $ENV{RT_TEST_PARALLEL} ) { | |
613 | # already dropped db in parallel tests, need to do so for other cases. | |
614 | __drop_database( $dbh ); | |
615 | ||
616 | } | |
617 | RT::Handle->CreateDatabase( $dbh ); | |
618 | $dbh->disconnect; | |
619 | $created_new_db++; | |
620 | } | |
621 | ||
622 | sub __drop_database { | |
623 | my $dbh = shift; | |
624 | ||
625 | # Pg doesn't like if you issue a DROP DATABASE while still connected | |
626 | # it's still may fail if web-server is out there and holding a connection | |
627 | __disconnect_rt(); | |
628 | ||
629 | my $my_dbh = $dbh? 0 : 1; | |
630 | $dbh ||= _get_dbh( | |
631 | RT::Handle->SystemDSN, | |
632 | $ENV{RT_DBA_USER}, $ENV{RT_DBA_PASSWORD} | |
633 | ); | |
b5747ff2 MKG |
634 | |
635 | # We ignore errors intentionally by not checking the return value of | |
636 | # DropDatabase below, so let's also suppress DBI's printing of errors when | |
637 | # we overzealously drop. | |
638 | local $dbh->{PrintError} = 0; | |
639 | local $dbh->{PrintWarn} = 0; | |
640 | ||
84fb5b46 MKG |
641 | RT::Handle->DropDatabase( $dbh ); |
642 | $dbh->disconnect if $my_dbh; | |
643 | } | |
644 | ||
645 | sub __reconnect_rt { | |
646 | my $as_dba = shift; | |
647 | __disconnect_rt(); | |
648 | ||
649 | # look at %DBIHandle and $PrevHandle in DBIx::SB::Handle for explanation | |
650 | $RT::Handle = RT::Handle->new; | |
651 | $RT::Handle->dbh( undef ); | |
652 | $RT::Handle->Connect( | |
653 | $as_dba | |
654 | ? (User => $ENV{RT_DBA_USER}, Password => $ENV{RT_DBA_PASSWORD}) | |
655 | : () | |
656 | ); | |
657 | $RT::Handle->PrintError; | |
658 | $RT::Handle->dbh->{PrintError} = 1; | |
659 | return $RT::Handle->dbh; | |
660 | } | |
661 | ||
662 | sub __disconnect_rt { | |
663 | # look at %DBIHandle and $PrevHandle in DBIx::SB::Handle for explanation | |
664 | $RT::Handle->dbh->disconnect if $RT::Handle and $RT::Handle->dbh; | |
665 | ||
666 | %DBIx::SearchBuilder::Handle::DBIHandle = (); | |
667 | $DBIx::SearchBuilder::Handle::PrevHandle = undef; | |
668 | ||
669 | $RT::Handle = undef; | |
670 | ||
671 | delete $RT::System->{attributes}; | |
672 | ||
673 | DBIx::SearchBuilder::Record::Cachable->FlushCache | |
674 | if DBIx::SearchBuilder::Record::Cachable->can("FlushCache"); | |
675 | } | |
676 | ||
403d7b0b MKG |
677 | sub __init_logging { |
678 | my $filter; | |
679 | { | |
680 | # We use local to ensure that the $filter we grab is from InitLogging | |
681 | # and not the handler generated by a previous call to this function | |
682 | # itself. | |
683 | local $SIG{__WARN__}; | |
684 | RT::InitLogging(); | |
685 | $filter = $SIG{__WARN__}; | |
686 | } | |
687 | $SIG{__WARN__} = sub { | |
3ffc5f4f | 688 | $filter->(@_) if $filter; |
403d7b0b MKG |
689 | # Avoid reporting this anonymous call frame as the source of the warning. |
690 | goto &$Test_NoWarnings_Catcher; | |
691 | }; | |
692 | } | |
693 | ||
84fb5b46 MKG |
694 | |
695 | =head1 UTILITIES | |
696 | ||
697 | =head2 load_or_create_user | |
698 | ||
699 | =cut | |
700 | ||
701 | sub load_or_create_user { | |
702 | my $self = shift; | |
703 | my %args = ( Privileged => 1, Disabled => 0, @_ ); | |
704 | ||
705 | my $MemberOf = delete $args{'MemberOf'}; | |
706 | $MemberOf = [ $MemberOf ] if defined $MemberOf && !ref $MemberOf; | |
707 | $MemberOf ||= []; | |
708 | ||
709 | my $obj = RT::User->new( RT->SystemUser ); | |
710 | if ( $args{'Name'} ) { | |
711 | $obj->LoadByCols( Name => $args{'Name'} ); | |
712 | } elsif ( $args{'EmailAddress'} ) { | |
713 | $obj->LoadByCols( EmailAddress => $args{'EmailAddress'} ); | |
714 | } else { | |
715 | die "Name or EmailAddress is required"; | |
716 | } | |
717 | if ( $obj->id ) { | |
718 | # cool | |
719 | $obj->SetPrivileged( $args{'Privileged'} || 0 ) | |
720 | if ($args{'Privileged'}||0) != ($obj->Privileged||0); | |
721 | $obj->SetDisabled( $args{'Disabled'} || 0 ) | |
722 | if ($args{'Disabled'}||0) != ($obj->Disabled||0); | |
723 | } else { | |
724 | my ($val, $msg) = $obj->Create( %args ); | |
725 | die "$msg" unless $val; | |
726 | } | |
727 | ||
728 | # clean group membership | |
729 | { | |
730 | require RT::GroupMembers; | |
731 | my $gms = RT::GroupMembers->new( RT->SystemUser ); | |
732 | my $groups_alias = $gms->Join( | |
733 | FIELD1 => 'GroupId', TABLE2 => 'Groups', FIELD2 => 'id', | |
734 | ); | |
3ffc5f4f MKG |
735 | $gms->Limit( |
736 | ALIAS => $groups_alias, FIELD => 'Domain', VALUE => 'UserDefined', | |
737 | CASESENSITIVE => 0, | |
738 | ); | |
84fb5b46 MKG |
739 | $gms->Limit( FIELD => 'MemberId', VALUE => $obj->id ); |
740 | while ( my $group_member_record = $gms->Next ) { | |
741 | $group_member_record->Delete; | |
742 | } | |
743 | } | |
744 | ||
745 | # add new user to groups | |
746 | foreach ( @$MemberOf ) { | |
747 | my $group = RT::Group->new( RT::SystemUser() ); | |
748 | $group->LoadUserDefinedGroup( $_ ); | |
749 | die "couldn't load group '$_'" unless $group->id; | |
750 | $group->AddMember( $obj->id ); | |
751 | } | |
752 | ||
753 | return $obj; | |
754 | } | |
755 | ||
3ffc5f4f MKG |
756 | |
757 | sub load_or_create_group { | |
758 | my $self = shift; | |
759 | my $name = shift; | |
760 | my %args = (@_); | |
761 | ||
762 | my $group = RT::Group->new( RT->SystemUser ); | |
763 | $group->LoadUserDefinedGroup( $name ); | |
764 | unless ( $group->id ) { | |
765 | my ($id, $msg) = $group->CreateUserDefinedGroup( | |
766 | Name => $name, | |
767 | ); | |
768 | die "$msg" unless $id; | |
769 | } | |
770 | ||
771 | if ( $args{Members} ) { | |
772 | my $cur = $group->MembersObj; | |
773 | while ( my $entry = $cur->Next ) { | |
774 | my ($status, $msg) = $entry->Delete; | |
775 | die "$msg" unless $status; | |
776 | } | |
777 | ||
778 | foreach my $new ( @{ $args{Members} } ) { | |
779 | my ($status, $msg) = $group->AddMember( | |
780 | ref($new)? $new->id : $new, | |
781 | ); | |
782 | die "$msg" unless $status; | |
783 | } | |
784 | } | |
785 | ||
786 | return $group; | |
787 | } | |
788 | ||
84fb5b46 MKG |
789 | =head2 load_or_create_queue |
790 | ||
791 | =cut | |
792 | ||
793 | sub load_or_create_queue { | |
794 | my $self = shift; | |
795 | my %args = ( Disabled => 0, @_ ); | |
796 | my $obj = RT::Queue->new( RT->SystemUser ); | |
797 | if ( $args{'Name'} ) { | |
798 | $obj->LoadByCols( Name => $args{'Name'} ); | |
799 | } else { | |
800 | die "Name is required"; | |
801 | } | |
802 | unless ( $obj->id ) { | |
803 | my ($val, $msg) = $obj->Create( %args ); | |
804 | die "$msg" unless $val; | |
805 | } else { | |
806 | my @fields = qw(CorrespondAddress CommentAddress); | |
807 | foreach my $field ( @fields ) { | |
808 | next unless exists $args{ $field }; | |
809 | next if $args{ $field } eq ($obj->$field || ''); | |
810 | ||
811 | no warnings 'uninitialized'; | |
812 | my $method = 'Set'. $field; | |
813 | my ($val, $msg) = $obj->$method( $args{ $field } ); | |
814 | die "$msg" unless $val; | |
815 | } | |
816 | } | |
817 | ||
818 | return $obj; | |
819 | } | |
820 | ||
821 | sub delete_queue_watchers { | |
822 | my $self = shift; | |
823 | my @queues = @_; | |
824 | ||
825 | foreach my $q ( @queues ) { | |
826 | foreach my $t (qw(Cc AdminCc) ) { | |
827 | $q->DeleteWatcher( Type => $t, PrincipalId => $_->MemberId ) | |
828 | foreach @{ $q->$t()->MembersObj->ItemsArrayRef }; | |
829 | } | |
830 | } | |
831 | } | |
832 | ||
833 | sub create_tickets { | |
834 | local $Test::Builder::Level = $Test::Builder::Level + 1; | |
835 | ||
836 | my $self = shift; | |
837 | my $defaults = shift; | |
838 | my @data = @_; | |
839 | @data = sort { rand(100) <=> rand(100) } @data | |
840 | if delete $defaults->{'RandomOrder'}; | |
841 | ||
842 | $defaults->{'Queue'} ||= 'General'; | |
843 | ||
844 | my @res = (); | |
845 | while ( @data ) { | |
846 | my %args = %{ shift @data }; | |
847 | $args{$_} = $res[ $args{$_} ]->id foreach | |
3ffc5f4f | 848 | grep $args{ $_ }, keys %RT::Link::TYPEMAP; |
84fb5b46 MKG |
849 | push @res, $self->create_ticket( %$defaults, %args ); |
850 | } | |
851 | return @res; | |
852 | } | |
853 | ||
854 | sub create_ticket { | |
855 | local $Test::Builder::Level = $Test::Builder::Level + 1; | |
856 | ||
857 | my $self = shift; | |
858 | my %args = @_; | |
859 | ||
3ffc5f4f MKG |
860 | if ( blessed $args{'Queue'} ) { |
861 | $args{Queue} = $args{'Queue'}->id; | |
862 | } | |
863 | elsif ($args{Queue} && $args{Queue} =~ /\D/) { | |
84fb5b46 MKG |
864 | my $queue = RT::Queue->new(RT->SystemUser); |
865 | if (my $id = $queue->Load($args{Queue}) ) { | |
866 | $args{Queue} = $id; | |
867 | } else { | |
868 | die ("Error: Invalid queue $args{Queue}"); | |
869 | } | |
870 | } | |
871 | ||
872 | if ( my $content = delete $args{'Content'} ) { | |
873 | $args{'MIMEObj'} = MIME::Entity->build( | |
3ffc5f4f MKG |
874 | From => Encode::encode( "UTF-8", $args{'Requestor'} ), |
875 | Subject => RT::Interface::Email::EncodeToMIME( String => $args{'Subject'} ), | |
876 | Type => "text/plain", | |
877 | Charset => "UTF-8", | |
878 | Data => Encode::encode( "UTF-8", $content ), | |
84fb5b46 MKG |
879 | ); |
880 | } | |
881 | ||
3ffc5f4f MKG |
882 | if ( my $cfs = delete $args{'CustomFields'} ) { |
883 | my $q = RT::Queue->new( RT->SystemUser ); | |
884 | $q->Load( $args{'Queue'} ); | |
885 | while ( my ($k, $v) = each %$cfs ) { | |
886 | my $cf = $q->CustomField( $k ); | |
887 | unless ($cf->id) { | |
888 | RT->Logger->error("Couldn't load custom field $k"); | |
889 | next; | |
890 | } | |
891 | ||
892 | $args{'CustomField-'. $cf->id} = $v; | |
893 | } | |
894 | } | |
895 | ||
84fb5b46 MKG |
896 | my $ticket = RT::Ticket->new( RT->SystemUser ); |
897 | my ( $id, undef, $msg ) = $ticket->Create( %args ); | |
898 | Test::More::ok( $id, "ticket created" ) | |
899 | or Test::More::diag("error: $msg"); | |
900 | ||
901 | # hackish, but simpler | |
902 | if ( $args{'LastUpdatedBy'} ) { | |
903 | $ticket->__Set( Field => 'LastUpdatedBy', Value => $args{'LastUpdatedBy'} ); | |
904 | } | |
905 | ||
906 | ||
907 | for my $field ( keys %args ) { | |
908 | #TODO check links and watchers | |
909 | ||
910 | if ( $field =~ /CustomField-(\d+)/ ) { | |
911 | my $cf = $1; | |
912 | my $got = join ',', sort map $_->Content, | |
913 | @{ $ticket->CustomFieldValues($cf)->ItemsArrayRef }; | |
914 | my $expected = ref $args{$field} | |
915 | ? join( ',', sort @{ $args{$field} } ) | |
916 | : $args{$field}; | |
917 | Test::More::is( $got, $expected, 'correct CF values' ); | |
918 | } | |
919 | else { | |
920 | next if ref $args{$field}; | |
921 | next unless $ticket->can($field) or $ticket->_Accessible($field,"read"); | |
922 | next if ref $ticket->$field(); | |
923 | Test::More::is( $ticket->$field(), $args{$field}, "$field is correct" ); | |
924 | } | |
925 | } | |
926 | ||
927 | return $ticket; | |
928 | } | |
929 | ||
930 | sub delete_tickets { | |
931 | my $self = shift; | |
932 | my $query = shift; | |
933 | my $tickets = RT::Tickets->new( RT->SystemUser ); | |
934 | if ( $query ) { | |
935 | $tickets->FromSQL( $query ); | |
936 | } | |
937 | else { | |
938 | $tickets->UnLimit; | |
939 | } | |
940 | while ( my $ticket = $tickets->Next ) { | |
941 | $ticket->Delete; | |
942 | } | |
943 | } | |
944 | ||
945 | =head2 load_or_create_custom_field | |
946 | ||
947 | =cut | |
948 | ||
949 | sub load_or_create_custom_field { | |
950 | my $self = shift; | |
951 | my %args = ( Disabled => 0, @_ ); | |
952 | my $obj = RT::CustomField->new( RT->SystemUser ); | |
953 | if ( $args{'Name'} ) { | |
3ffc5f4f MKG |
954 | $obj->LoadByName( |
955 | Name => $args{'Name'}, | |
956 | LookupType => RT::Ticket->CustomFieldLookupType, | |
957 | ObjectId => $args{'Queue'}, | |
958 | ); | |
84fb5b46 MKG |
959 | } else { |
960 | die "Name is required"; | |
961 | } | |
962 | unless ( $obj->id ) { | |
963 | my ($val, $msg) = $obj->Create( %args ); | |
964 | die "$msg" unless $val; | |
965 | } | |
966 | ||
967 | return $obj; | |
968 | } | |
969 | ||
970 | sub last_ticket { | |
971 | my $self = shift; | |
972 | my $current = shift; | |
973 | $current = $current ? RT::CurrentUser->new($current) : RT->SystemUser; | |
974 | my $tickets = RT::Tickets->new( $current ); | |
975 | $tickets->OrderBy( FIELD => 'id', ORDER => 'DESC' ); | |
976 | $tickets->Limit( FIELD => 'id', OPERATOR => '>', VALUE => '0' ); | |
977 | $tickets->RowsPerPage( 1 ); | |
978 | return $tickets->First; | |
979 | } | |
980 | ||
981 | sub store_rights { | |
982 | my $self = shift; | |
983 | ||
984 | require RT::ACE; | |
985 | # fake construction | |
986 | RT::ACE->new( RT->SystemUser ); | |
987 | my @fields = keys %{ RT::ACE->_ClassAccessible }; | |
988 | ||
989 | require RT::ACL; | |
990 | my $acl = RT::ACL->new( RT->SystemUser ); | |
991 | $acl->Limit( FIELD => 'RightName', OPERATOR => '!=', VALUE => 'SuperUser' ); | |
992 | ||
993 | my @res; | |
994 | while ( my $ace = $acl->Next ) { | |
995 | my $obj = $ace->PrincipalObj->Object; | |
3ffc5f4f | 996 | if ( $obj->isa('RT::Group') && $obj->Domain eq 'ACLEquivalence' && $obj->Instance == RT->Nobody->id ) { |
84fb5b46 MKG |
997 | next; |
998 | } | |
999 | ||
1000 | my %tmp = (); | |
1001 | foreach my $field( @fields ) { | |
1002 | $tmp{ $field } = $ace->__Value( $field ); | |
1003 | } | |
1004 | push @res, \%tmp; | |
1005 | } | |
1006 | return @res; | |
1007 | } | |
1008 | ||
1009 | sub restore_rights { | |
1010 | my $self = shift; | |
1011 | my @entries = @_; | |
1012 | foreach my $entry ( @entries ) { | |
1013 | my $ace = RT::ACE->new( RT->SystemUser ); | |
1014 | my ($status, $msg) = $ace->RT::Record::Create( %$entry ); | |
1015 | unless ( $status ) { | |
1016 | Test::More::diag "couldn't create a record: $msg"; | |
1017 | } | |
1018 | } | |
1019 | } | |
1020 | ||
1021 | sub set_rights { | |
1022 | my $self = shift; | |
1023 | ||
1024 | require RT::ACL; | |
1025 | my $acl = RT::ACL->new( RT->SystemUser ); | |
1026 | $acl->Limit( FIELD => 'RightName', OPERATOR => '!=', VALUE => 'SuperUser' ); | |
1027 | while ( my $ace = $acl->Next ) { | |
1028 | my $obj = $ace->PrincipalObj->Object; | |
3ffc5f4f | 1029 | if ( $obj->isa('RT::Group') && $obj->Domain eq 'ACLEquivalence' && $obj->Instance == RT->Nobody->id ) { |
84fb5b46 MKG |
1030 | next; |
1031 | } | |
1032 | $ace->Delete; | |
1033 | } | |
1034 | return $self->add_rights( @_ ); | |
1035 | } | |
1036 | ||
1037 | sub add_rights { | |
1038 | my $self = shift; | |
1039 | my @list = ref $_[0]? @_: @_? { @_ }: (); | |
1040 | ||
1041 | require RT::ACL; | |
1042 | foreach my $e (@list) { | |
1043 | my $principal = delete $e->{'Principal'}; | |
1044 | unless ( ref $principal ) { | |
1045 | if ( $principal =~ /^(everyone|(?:un)?privileged)$/i ) { | |
1046 | $principal = RT::Group->new( RT->SystemUser ); | |
1047 | $principal->LoadSystemInternalGroup($1); | |
3ffc5f4f MKG |
1048 | } else { |
1049 | my $type = $principal; | |
84fb5b46 | 1050 | $principal = RT::Group->new( RT->SystemUser ); |
3ffc5f4f MKG |
1051 | $principal->LoadRoleGroup( |
1052 | Object => ($e->{'Object'} || RT->System), | |
1053 | Name => $type | |
84fb5b46 | 1054 | ); |
84fb5b46 | 1055 | } |
3ffc5f4f MKG |
1056 | die "Principal is not an object nor the name of a system or role group" |
1057 | unless $principal->id; | |
84fb5b46 MKG |
1058 | } |
1059 | unless ( $principal->isa('RT::Principal') ) { | |
1060 | if ( $principal->can('PrincipalObj') ) { | |
1061 | $principal = $principal->PrincipalObj; | |
1062 | } | |
1063 | } | |
1064 | my @rights = ref $e->{'Right'}? @{ $e->{'Right'} }: ($e->{'Right'}); | |
1065 | foreach my $right ( @rights ) { | |
1066 | my ($status, $msg) = $principal->GrantRight( %$e, Right => $right ); | |
1067 | $RT::Logger->debug($msg); | |
1068 | } | |
1069 | } | |
1070 | return 1; | |
1071 | } | |
1072 | ||
3ffc5f4f MKG |
1073 | =head2 switch_templates_to TYPE |
1074 | ||
1075 | This runs etc/upgrade/switch-templates-to in order to change the templates from | |
1076 | HTML to text or vice versa. TYPE is the type to switch to, either C<html> or | |
1077 | C<text>. | |
1078 | ||
1079 | =cut | |
1080 | ||
1081 | sub switch_templates_to { | |
1082 | my $self = shift; | |
1083 | my $type = shift; | |
1084 | ||
1085 | return $self->run_and_capture( | |
1086 | command => "$RT::EtcPath/upgrade/switch-templates-to", | |
1087 | args => $type, | |
1088 | ); | |
1089 | } | |
1090 | ||
1091 | =head2 switch_templates_ok TYPE | |
1092 | ||
1093 | Calls L<switch_template_to> and tests the return values. | |
1094 | ||
1095 | =cut | |
1096 | ||
1097 | sub switch_templates_ok { | |
1098 | my $self = shift; | |
1099 | my $type = shift; | |
1100 | ||
1101 | my ($exit, $output) = $self->switch_templates_to($type); | |
1102 | ||
1103 | if ($exit >> 8) { | |
1104 | Test::More::fail("Switched templates to $type cleanly"); | |
1105 | diag("**** etc/upgrade/switch-templates-to exited with ".($exit >> 8).":\n$output"); | |
1106 | } else { | |
1107 | Test::More::pass("Switched templates to $type cleanly"); | |
1108 | } | |
1109 | ||
1110 | return ($exit, $output); | |
1111 | } | |
1112 | ||
84fb5b46 MKG |
1113 | sub run_mailgate { |
1114 | my $self = shift; | |
1115 | ||
1116 | require RT::Test::Web; | |
1117 | my %args = ( | |
1118 | url => RT::Test::Web->rt_base_url, | |
1119 | message => '', | |
1120 | action => 'correspond', | |
1121 | queue => 'General', | |
1122 | debug => 1, | |
1123 | command => $RT::BinPath .'/rt-mailgate', | |
1124 | @_ | |
1125 | ); | |
1126 | my $message = delete $args{'message'}; | |
1127 | ||
1128 | $args{after_open} = sub { | |
1129 | my $child_in = shift; | |
1130 | if ( UNIVERSAL::isa($message, 'MIME::Entity') ) { | |
1131 | $message->print( $child_in ); | |
1132 | } else { | |
1133 | print $child_in $message; | |
1134 | } | |
1135 | }; | |
1136 | ||
1137 | $self->run_and_capture(%args); | |
1138 | } | |
1139 | ||
1140 | sub run_and_capture { | |
1141 | my $self = shift; | |
1142 | my %args = @_; | |
1143 | ||
1144 | my $after_open = delete $args{after_open}; | |
1145 | ||
1146 | my $cmd = delete $args{'command'}; | |
1147 | die "Couldn't find command ($cmd)" unless -f $cmd; | |
1148 | ||
1149 | $cmd .= ' --debug' if delete $args{'debug'}; | |
1150 | ||
3ffc5f4f MKG |
1151 | my $args = delete $args{'args'}; |
1152 | ||
84fb5b46 MKG |
1153 | while( my ($k,$v) = each %args ) { |
1154 | next unless $v; | |
1155 | $cmd .= " --$k '$v'"; | |
1156 | } | |
3ffc5f4f | 1157 | $cmd .= " $args" if defined $args; |
84fb5b46 MKG |
1158 | $cmd .= ' 2>&1'; |
1159 | ||
1160 | DBIx::SearchBuilder::Record::Cachable->FlushCache; | |
1161 | ||
1162 | require IPC::Open2; | |
1163 | my ($child_out, $child_in); | |
1164 | my $pid = IPC::Open2::open2($child_out, $child_in, $cmd); | |
1165 | ||
1166 | $after_open->($child_in, $child_out) if $after_open; | |
1167 | ||
1168 | close $child_in; | |
1169 | ||
1170 | my $result = do { local $/; <$child_out> }; | |
1171 | close $child_out; | |
1172 | waitpid $pid, 0; | |
1173 | return ($?, $result); | |
1174 | } | |
1175 | ||
1176 | sub send_via_mailgate_and_http { | |
1177 | my $self = shift; | |
1178 | my $message = shift; | |
1179 | my %args = (@_); | |
1180 | ||
1181 | my ($status, $gate_result) = $self->run_mailgate( | |
1182 | message => $message, %args | |
1183 | ); | |
1184 | ||
1185 | my $id; | |
1186 | unless ( $status >> 8 ) { | |
1187 | ($id) = ($gate_result =~ /Ticket:\s*(\d+)/i); | |
1188 | unless ( $id ) { | |
1189 | Test::More::diag "Couldn't find ticket id in text:\n$gate_result" | |
1190 | if $ENV{'TEST_VERBOSE'}; | |
1191 | } | |
1192 | } else { | |
1193 | Test::More::diag "Mailgate output:\n$gate_result" | |
1194 | if $ENV{'TEST_VERBOSE'}; | |
1195 | } | |
1196 | return ($status, $id); | |
1197 | } | |
1198 | ||
1199 | ||
1200 | sub send_via_mailgate { | |
1201 | my $self = shift; | |
1202 | my $message = shift; | |
1203 | my %args = ( action => 'correspond', | |
1204 | queue => 'General', | |
1205 | @_ | |
1206 | ); | |
1207 | ||
1208 | if ( UNIVERSAL::isa( $message, 'MIME::Entity' ) ) { | |
1209 | $message = $message->as_string; | |
1210 | } | |
1211 | ||
1212 | my ( $status, $error_message, $ticket ) | |
1213 | = RT::Interface::Email::Gateway( {%args, message => $message} ); | |
1214 | return ( $status, $ticket ? $ticket->id : 0 ); | |
1215 | ||
1216 | } | |
1217 | ||
1218 | ||
1219 | sub open_mailgate_ok { | |
3ffc5f4f | 1220 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
84fb5b46 MKG |
1221 | my $class = shift; |
1222 | my $baseurl = shift; | |
1223 | my $queue = shift || 'general'; | |
1224 | my $action = shift || 'correspond'; | |
1225 | Test::More::ok(open(my $mail, '|-', "$RT::BinPath/rt-mailgate --url $baseurl --queue $queue --action $action"), "Opened the mailgate - $!"); | |
1226 | return $mail; | |
1227 | } | |
1228 | ||
1229 | ||
1230 | sub close_mailgate_ok { | |
3ffc5f4f | 1231 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
84fb5b46 MKG |
1232 | my $class = shift; |
1233 | my $mail = shift; | |
1234 | close $mail; | |
1235 | Test::More::is ($? >> 8, 0, "The mail gateway exited normally. yay"); | |
1236 | } | |
1237 | ||
1238 | sub mailsent_ok { | |
3ffc5f4f | 1239 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
84fb5b46 MKG |
1240 | my $class = shift; |
1241 | my $expected = shift; | |
1242 | ||
1243 | my $mailsent = scalar grep /\S/, split /%% split me! %%\n/, | |
1244 | RT::Test->file_content( | |
1245 | $tmp{'mailbox'}, | |
1246 | 'unlink' => 0, | |
1247 | noexist => 1 | |
1248 | ); | |
1249 | ||
1250 | Test::More::is( | |
1251 | $mailsent, $expected, | |
1252 | "The number of mail sent ($expected) matches. yay" | |
1253 | ); | |
1254 | } | |
1255 | ||
1256 | sub fetch_caught_mails { | |
1257 | my $self = shift; | |
1258 | return grep /\S/, split /%% split me! %%\n/, | |
1259 | RT::Test->file_content( | |
1260 | $tmp{'mailbox'}, | |
1261 | 'unlink' => 1, | |
1262 | noexist => 1 | |
1263 | ); | |
1264 | } | |
1265 | ||
1266 | sub clean_caught_mails { | |
1267 | unlink $tmp{'mailbox'}; | |
1268 | } | |
3ffc5f4f MKG |
1269 | my $validator_path = "$RT::SbinPath/rt-validator"; |
1270 | sub run_validator { | |
1271 | my $self = shift; | |
1272 | my %args = (check => 1, resolve => 0, force => 1, @_ ); | |
1273 | ||
1274 | my $cmd = $validator_path; | |
1275 | die "Couldn't find $cmd command" unless -f $cmd; | |
1276 | ||
1277 | while( my ($k,$v) = each %args ) { | |
1278 | next unless $v; | |
1279 | $cmd .= " --$k '$v'"; | |
1280 | } | |
1281 | $cmd .= ' 2>&1'; | |
1282 | ||
1283 | require IPC::Open2; | |
1284 | my ($child_out, $child_in); | |
1285 | my $pid = IPC::Open2::open2($child_out, $child_in, $cmd); | |
1286 | close $child_in; | |
1287 | ||
1288 | my $result = do { local $/; <$child_out> }; | |
1289 | close $child_out; | |
1290 | waitpid $pid, 0; | |
1291 | ||
1292 | DBIx::SearchBuilder::Record::Cachable->FlushCache | |
1293 | if $args{'resolve'}; | |
1294 | ||
1295 | return ($?, $result); | |
1296 | } | |
1297 | ||
1298 | sub db_is_valid { | |
1299 | local $Test::Builder::Level = $Test::Builder::Level + 1; | |
1300 | ||
1301 | my $self = shift; | |
1302 | my ($ecode, $res) = $self->run_validator; | |
1303 | Test::More::is( $ecode, 0, 'no invalid records' ) | |
1304 | or Test::More::diag "errors:\n$res"; | |
1305 | } | |
1306 | ||
1307 | =head2 object_scrips_are | |
1308 | ||
1309 | Takes an L<RT::Scrip> object or ID as the first argument and an arrayref of | |
1310 | L<RT::Queue> objects and/or Queue IDs as the second argument. | |
1311 | ||
1312 | The scrip's applications (L<RT::ObjectScrip> records) are tested to ensure they | |
1313 | exactly match the arrayref. | |
1314 | ||
1315 | An optional third arrayref may be passed to enumerate and test the queues the | |
1316 | scrip is B<not> added to. This is most useful for testing the API returns the | |
1317 | correct results. | |
1318 | ||
1319 | =cut | |
1320 | ||
1321 | sub object_scrips_are { | |
1322 | local $Test::Builder::Level = $Test::Builder::Level + 1; | |
1323 | my $self = shift; | |
1324 | my $scrip = shift; | |
1325 | my $to = shift || []; | |
1326 | my $not_to = shift; | |
1327 | ||
1328 | unless (blessed($scrip)) { | |
1329 | my $id = $scrip; | |
1330 | $scrip = RT::Scrip->new( RT->SystemUser ); | |
1331 | $scrip->Load($id); | |
1332 | } | |
1333 | ||
1334 | $to = [ map { blessed($_) ? $_->id : $_ } @$to ]; | |
1335 | Test::More::ok($scrip->IsAdded($_), "added to queue $_" ) foreach @$to; | |
1336 | Test::More::is_deeply( | |
1337 | [sort map $_->id, @{ $scrip->AddedTo->ItemsArrayRef }], | |
1338 | [sort grep $_, @$to ], | |
1339 | 'correct list of added to queues', | |
1340 | ); | |
1341 | ||
1342 | if ($not_to) { | |
1343 | $not_to = [ map { blessed($_) ? $_->id : $_ } @$not_to ]; | |
1344 | Test::More::ok(!$scrip->IsAdded($_), "not added to queue $_" ) foreach @$not_to; | |
1345 | Test::More::is_deeply( | |
1346 | [sort map $_->id, @{ $scrip->NotAddedTo->ItemsArrayRef }], | |
1347 | [sort grep $_, @$not_to ], | |
1348 | 'correct list of not added to queues', | |
1349 | ); | |
1350 | } | |
1351 | } | |
84fb5b46 MKG |
1352 | |
1353 | =head2 get_relocatable_dir | |
1354 | ||
1355 | Takes a path relative to the location of the test file that is being | |
1356 | run and returns a path that takes the invocation path into account. | |
1357 | ||
403d7b0b MKG |
1358 | e.g. C<RT::Test::get_relocatable_dir(File::Spec->updir(), 'data', 'emails')> |
1359 | ||
1360 | Parent directory traversals (C<..> or File::Spec->updir()) are naively | |
1361 | canonicalized based on the test file path (C<$0>) so that symlinks aren't | |
1362 | followed. This is the exact opposite behaviour of most filesystems and is | |
1363 | considered "wrong", however it is necessary for some subsets of tests which are | |
1364 | symlinked into the testing tree. | |
84fb5b46 MKG |
1365 | |
1366 | =cut | |
1367 | ||
1368 | sub get_relocatable_dir { | |
403d7b0b MKG |
1369 | my @directories = File::Spec->splitdir( |
1370 | File::Spec->rel2abs((File::Spec->splitpath($0))[1]) | |
1371 | ); | |
1372 | push @directories, File::Spec->splitdir($_) for @_; | |
1373 | ||
1374 | my @clean; | |
1375 | for (@directories) { | |
1376 | if ($_ eq "..") { pop @clean } | |
1377 | elsif ($_ ne ".") { push @clean, $_ } | |
84fb5b46 | 1378 | } |
403d7b0b | 1379 | return File::Spec->catdir(@clean); |
84fb5b46 MKG |
1380 | } |
1381 | ||
1382 | =head2 get_relocatable_file | |
1383 | ||
1384 | Same as get_relocatable_dir, but takes a file and a path instead | |
1385 | of just a path. | |
1386 | ||
1387 | e.g. RT::Test::get_relocatable_file('test-email', | |
1388 | (File::Spec->updir(), 'data', 'emails')) | |
1389 | ||
1390 | =cut | |
1391 | ||
1392 | sub get_relocatable_file { | |
1393 | my $file = shift; | |
1394 | return File::Spec->catfile(get_relocatable_dir(@_), $file); | |
1395 | } | |
1396 | ||
3ffc5f4f MKG |
1397 | sub find_relocatable_path { |
1398 | my @path = @_; | |
1399 | ||
1400 | # A simple strategy to find e.g., t/data/gnupg/keys, from the dir | |
1401 | # where test file lives. We try up to 3 directories up | |
1402 | my $path = File::Spec->catfile( @path ); | |
1403 | for my $up ( 0 .. 2 ) { | |
1404 | my $p = get_relocatable_dir($path); | |
1405 | return $p if -e $p; | |
1406 | ||
1407 | $path = File::Spec->catfile( File::Spec->updir(), $path ); | |
1408 | } | |
1409 | return undef; | |
1410 | } | |
1411 | ||
84fb5b46 MKG |
1412 | sub get_abs_relocatable_dir { |
1413 | (my $volume, my $directories, my $file) = File::Spec->splitpath($0); | |
1414 | if (File::Spec->file_name_is_absolute($directories)) { | |
1415 | return File::Spec->catdir($directories, @_); | |
1416 | } else { | |
1417 | return File::Spec->catdir(Cwd->getcwd(), $directories, @_); | |
1418 | } | |
1419 | } | |
1420 | ||
1421 | sub gnupg_homedir { | |
1422 | my $self = shift; | |
1423 | File::Temp->newdir( | |
1424 | DIR => $tmp{directory}, | |
1425 | CLEANUP => 0, | |
1426 | ); | |
1427 | } | |
1428 | ||
1429 | sub import_gnupg_key { | |
1430 | my $self = shift; | |
1431 | my $key = shift; | |
1432 | my $type = shift || 'secret'; | |
1433 | ||
1434 | $key =~ s/\@/-at-/g; | |
1435 | $key .= ".$type.key"; | |
1436 | ||
3ffc5f4f | 1437 | my $path = find_relocatable_path( 'data', 'gnupg', 'keys' ); |
84fb5b46 MKG |
1438 | |
1439 | die "can't find the dir where gnupg keys are stored" | |
3ffc5f4f | 1440 | unless $path; |
84fb5b46 | 1441 | |
3ffc5f4f MKG |
1442 | return RT::Crypt::GnuPG->ImportKey( |
1443 | RT::Test->file_content( [ $path, $key ] ) ); | |
84fb5b46 MKG |
1444 | } |
1445 | ||
84fb5b46 MKG |
1446 | sub lsign_gnupg_key { |
1447 | my $self = shift; | |
1448 | my $key = shift; | |
1449 | ||
3ffc5f4f MKG |
1450 | return RT::Crypt::GnuPG->CallGnuPG( |
1451 | Command => '--lsign-key', | |
1452 | CommandArgs => [$key], | |
1453 | Callback => sub { | |
1454 | my %handle = @_; | |
1455 | while ( my $str = readline $handle{'status'} ) { | |
1456 | if ( $str =~ /^\[GNUPG:\]\s*GET_BOOL sign_uid\..*/ ) { | |
1457 | print { $handle{'command'} } "y\n"; | |
1458 | } | |
84fb5b46 | 1459 | } |
3ffc5f4f MKG |
1460 | }, |
1461 | ); | |
84fb5b46 MKG |
1462 | } |
1463 | ||
1464 | sub trust_gnupg_key { | |
1465 | my $self = shift; | |
1466 | my $key = shift; | |
1467 | ||
3ffc5f4f MKG |
1468 | return RT::Crypt::GnuPG->CallGnuPG( |
1469 | Command => '--edit-key', | |
1470 | CommandArgs => [$key], | |
1471 | Callback => sub { | |
1472 | my %handle = @_; | |
1473 | my $done = 0; | |
1474 | while ( my $str = readline $handle{'status'} ) { | |
1475 | if ( $str =~ /^\[GNUPG:\]\s*\QGET_LINE keyedit.prompt/ ) { | |
1476 | if ( $done ) { | |
1477 | print { $handle{'command'} } "quit\n"; | |
1478 | } else { | |
1479 | print { $handle{'command'} } "trust\n"; | |
1480 | } | |
1481 | } elsif ( $str =~ /^\[GNUPG:\]\s*\QGET_LINE edit_ownertrust.value/ ) { | |
1482 | print { $handle{'command'} } "5\n"; | |
1483 | } elsif ( $str =~ /^\[GNUPG:\]\s*\QGET_BOOL edit_ownertrust.set_ultimate.okay/ ) { | |
1484 | print { $handle{'command'} } "y\n"; | |
1485 | $done = 1; | |
84fb5b46 | 1486 | } |
84fb5b46 | 1487 | } |
3ffc5f4f MKG |
1488 | }, |
1489 | ); | |
84fb5b46 MKG |
1490 | } |
1491 | ||
1492 | sub started_ok { | |
1493 | my $self = shift; | |
1494 | ||
1495 | require RT::Test::Web; | |
1496 | ||
b5747ff2 MKG |
1497 | if ($rttest_opt{nodb} and not $rttest_opt{server_ok}) { |
1498 | die "You are trying to use a test web server without a database. " | |
1499 | ."You may want noinitialdata => 1 instead. " | |
1500 | ."Pass server_ok => 1 if you know what you're doing."; | |
84fb5b46 MKG |
1501 | } |
1502 | ||
1503 | ||
1504 | $ENV{'RT_TEST_WEB_HANDLER'} = undef | |
1505 | if $rttest_opt{actual_server} && ($ENV{'RT_TEST_WEB_HANDLER'}||'') eq 'inline'; | |
1506 | $ENV{'RT_TEST_WEB_HANDLER'} ||= 'plack'; | |
1507 | my $which = $ENV{'RT_TEST_WEB_HANDLER'}; | |
1508 | my ($server, $variant) = split /\+/, $which, 2; | |
1509 | ||
1510 | my $function = 'start_'. $server .'_server'; | |
1511 | unless ( $self->can($function) ) { | |
1512 | die "Don't know how to start server '$server'"; | |
1513 | } | |
1514 | return $self->$function( variant => $variant, @_ ); | |
1515 | } | |
1516 | ||
1517 | sub test_app { | |
1518 | my $self = shift; | |
1519 | my %server_opt = @_; | |
1520 | ||
b5747ff2 MKG |
1521 | my $app; |
1522 | ||
1523 | my $warnings = ""; | |
1524 | open( my $warn_fh, ">", \$warnings ); | |
1525 | local *STDERR = $warn_fh; | |
1526 | ||
1527 | if ($server_opt{variant} and $server_opt{variant} eq 'rt-server') { | |
1528 | $app = do { | |
1529 | my $file = "$RT::SbinPath/rt-server"; | |
1530 | my $psgi = do $file; | |
1531 | unless ($psgi) { | |
1532 | die "Couldn't parse $file: $@" if $@; | |
1533 | die "Couldn't do $file: $!" unless defined $psgi; | |
1534 | die "Couldn't run $file" unless $psgi; | |
1535 | } | |
1536 | $psgi; | |
1537 | }; | |
1538 | } else { | |
1539 | require RT::Interface::Web::Handler; | |
1540 | $app = RT::Interface::Web::Handler->PSGIApp; | |
1541 | } | |
84fb5b46 MKG |
1542 | |
1543 | require Plack::Middleware::Test::StashWarnings; | |
3ffc5f4f MKG |
1544 | my $stashwarnings = Plack::Middleware::Test::StashWarnings->new( |
1545 | $ENV{'RT_TEST_WEB_HANDLER'} && $ENV{'RT_TEST_WEB_HANDLER'} eq 'inline' ? ( verbose => 0 ) : () ); | |
b5747ff2 | 1546 | $app = $stashwarnings->wrap($app); |
84fb5b46 MKG |
1547 | |
1548 | if ($server_opt{basic_auth}) { | |
1549 | require Plack::Middleware::Auth::Basic; | |
1550 | $app = Plack::Middleware::Auth::Basic->wrap( | |
1551 | $app, | |
3ffc5f4f | 1552 | authenticator => $server_opt{basic_auth} eq 'anon' ? sub { 1 } : sub { |
84fb5b46 MKG |
1553 | my ($username, $password) = @_; |
1554 | return $username eq 'root' && $password eq 'password'; | |
1555 | } | |
1556 | ); | |
1557 | } | |
b5747ff2 MKG |
1558 | |
1559 | close $warn_fh; | |
1560 | $stashwarnings->add_warning( $warnings ) if $warnings; | |
1561 | ||
84fb5b46 MKG |
1562 | return $app; |
1563 | } | |
1564 | ||
1565 | sub start_plack_server { | |
3ffc5f4f | 1566 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
84fb5b46 MKG |
1567 | my $self = shift; |
1568 | ||
1569 | require Plack::Loader; | |
1570 | my $plack_server = Plack::Loader->load | |
1571 | ('Standalone', | |
1572 | port => $port, | |
1573 | server_ready => sub { | |
1574 | kill 'USR1' => getppid(); | |
1575 | }); | |
1576 | ||
1577 | # We are expecting a USR1 from the child process after it's ready | |
1578 | # to listen. We set this up _before_ we fork to avoid race | |
1579 | # conditions. | |
1580 | my $handled; | |
1581 | local $SIG{USR1} = sub { $handled = 1}; | |
1582 | ||
1583 | __disconnect_rt(); | |
1584 | my $pid = fork(); | |
1585 | die "failed to fork" unless defined $pid; | |
1586 | ||
1587 | if ($pid) { | |
1588 | sleep 15 unless $handled; | |
1589 | Test::More::diag "did not get expected USR1 for test server readiness" | |
1590 | unless $handled; | |
1591 | push @SERVERS, $pid; | |
1592 | my $Tester = Test::Builder->new; | |
1593 | $Tester->ok(1, "started plack server ok"); | |
1594 | ||
b5747ff2 MKG |
1595 | __reconnect_rt() |
1596 | unless $rttest_opt{nodb}; | |
84fb5b46 MKG |
1597 | return ("http://localhost:$port", RT::Test::Web->new); |
1598 | } | |
1599 | ||
1600 | require POSIX; | |
3ffc5f4f MKG |
1601 | POSIX::setsid() |
1602 | or die "Can't start a new session: $!"; | |
84fb5b46 MKG |
1603 | |
1604 | # stick this in a scope so that when $app is garbage collected, | |
1605 | # StashWarnings can complain about unhandled warnings | |
1606 | do { | |
1607 | $plack_server->run($self->test_app(@_)); | |
1608 | }; | |
1609 | ||
1610 | exit; | |
1611 | } | |
1612 | ||
1613 | our $TEST_APP; | |
1614 | sub start_inline_server { | |
3ffc5f4f | 1615 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
84fb5b46 MKG |
1616 | my $self = shift; |
1617 | ||
1618 | require Test::WWW::Mechanize::PSGI; | |
1619 | unshift @RT::Test::Web::ISA, 'Test::WWW::Mechanize::PSGI'; | |
1620 | ||
1621 | # Clear out squished CSS and JS cache, since it's retained across | |
1622 | # servers, since it's in-process | |
1623 | RT::Interface::Web->ClearSquished; | |
403d7b0b MKG |
1624 | require RT::Interface::Web::Request; |
1625 | RT::Interface::Web::Request->clear_callback_cache; | |
84fb5b46 MKG |
1626 | |
1627 | Test::More::ok(1, "psgi test server ok"); | |
1628 | $TEST_APP = $self->test_app(@_); | |
1629 | return ("http://localhost:$port", RT::Test::Web->new); | |
1630 | } | |
1631 | ||
1632 | sub start_apache_server { | |
3ffc5f4f | 1633 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
84fb5b46 MKG |
1634 | my $self = shift; |
1635 | my %server_opt = @_; | |
1636 | $server_opt{variant} ||= 'mod_perl'; | |
1637 | $ENV{RT_TEST_WEB_HANDLER} = "apache+$server_opt{variant}"; | |
1638 | ||
1639 | require RT::Test::Apache; | |
1640 | my $pid = RT::Test::Apache->start_server( | |
1641 | %server_opt, | |
1642 | port => $port, | |
1643 | tmp => \%tmp | |
1644 | ); | |
1645 | push @SERVERS, $pid; | |
1646 | ||
1647 | my $url = RT->Config->Get('WebURL'); | |
1648 | $url =~ s!/$!!; | |
1649 | return ($url, RT::Test::Web->new); | |
1650 | } | |
1651 | ||
1652 | sub stop_server { | |
1653 | my $self = shift; | |
1654 | my $in_end = shift; | |
1655 | return unless @SERVERS; | |
1656 | ||
3ffc5f4f | 1657 | kill 'TERM', @SERVERS; |
84fb5b46 MKG |
1658 | foreach my $pid (@SERVERS) { |
1659 | if ($ENV{RT_TEST_WEB_HANDLER} =~ /^apache/) { | |
1660 | sleep 1 while kill 0, $pid; | |
1661 | } else { | |
1662 | waitpid $pid, 0; | |
1663 | } | |
1664 | } | |
1665 | ||
1666 | @SERVERS = (); | |
1667 | } | |
1668 | ||
1669 | sub temp_directory { | |
1670 | return $tmp{'directory'}; | |
1671 | } | |
1672 | ||
1673 | sub file_content { | |
1674 | my $self = shift; | |
1675 | my $path = shift; | |
1676 | my %args = @_; | |
1677 | ||
1678 | $path = File::Spec->catfile( @$path ) if ref $path eq 'ARRAY'; | |
1679 | ||
84fb5b46 MKG |
1680 | open( my $fh, "<:raw", $path ) |
1681 | or do { | |
1682 | warn "couldn't open file '$path': $!" unless $args{noexist}; | |
1683 | return '' | |
1684 | }; | |
1685 | my $content = do { local $/; <$fh> }; | |
1686 | close $fh; | |
1687 | ||
1688 | unlink $path if $args{'unlink'}; | |
1689 | ||
1690 | return $content; | |
1691 | } | |
1692 | ||
1693 | sub find_executable { | |
1694 | my $self = shift; | |
84fb5b46 | 1695 | |
3ffc5f4f | 1696 | return File::Which::which( @_ ); |
84fb5b46 MKG |
1697 | } |
1698 | ||
1699 | sub diag { | |
1700 | return unless $ENV{RT_TEST_VERBOSE} || $ENV{TEST_VERBOSE}; | |
1701 | goto \&Test::More::diag; | |
1702 | } | |
1703 | ||
1704 | sub parse_mail { | |
1705 | my $mail = shift; | |
1706 | require RT::EmailParser; | |
1707 | my $parser = RT::EmailParser->new; | |
1708 | $parser->ParseMIMEEntityFromScalar( $mail ); | |
1709 | return $parser->Entity; | |
1710 | } | |
1711 | ||
1712 | sub works { | |
1713 | Test::More::ok($_[0], $_[1] || 'This works'); | |
1714 | } | |
1715 | ||
1716 | sub fails { | |
1717 | Test::More::ok(!$_[0], $_[1] || 'This should fail'); | |
1718 | } | |
1719 | ||
403d7b0b MKG |
1720 | sub plan { |
1721 | my ($cmd, @args) = @_; | |
1722 | my $builder = RT::Test->builder; | |
1723 | ||
1724 | if ($cmd eq "skip_all") { | |
1725 | $check_warnings_in_end = 0; | |
1726 | } elsif ($cmd eq "tests") { | |
1727 | # Increment the test count for the warnings check | |
1728 | $args[0]++; | |
1729 | } | |
1730 | $builder->plan($cmd, @args); | |
1731 | } | |
1732 | ||
1733 | sub done_testing { | |
1734 | my $builder = RT::Test->builder; | |
1735 | ||
1736 | Test::NoWarnings::had_no_warnings(); | |
1737 | $check_warnings_in_end = 0; | |
1738 | ||
1739 | $builder->done_testing(@_); | |
1740 | } | |
1741 | ||
84fb5b46 MKG |
1742 | END { |
1743 | my $Test = RT::Test->builder; | |
1744 | return if $Test->{Original_Pid} != $$; | |
1745 | ||
84fb5b46 MKG |
1746 | # we are in END block and should protect our exit code |
1747 | # so calls below may call system or kill that clobbers $? | |
1748 | local $?; | |
1749 | ||
403d7b0b MKG |
1750 | Test::NoWarnings::had_no_warnings() if $check_warnings_in_end; |
1751 | ||
84fb5b46 MKG |
1752 | RT::Test->stop_server(1); |
1753 | ||
1754 | # not success | |
1755 | if ( !$Test->is_passing ) { | |
1756 | $tmp{'directory'}->unlink_on_destroy(0); | |
1757 | ||
1758 | Test::More::diag( | |
1759 | "Some tests failed or we bailed out, tmp directory" | |
1760 | ." '$tmp{directory}' is not cleaned" | |
1761 | ); | |
1762 | } | |
1763 | ||
1764 | if ( $ENV{RT_TEST_PARALLEL} && $created_new_db ) { | |
1765 | __drop_database(); | |
1766 | } | |
1767 | ||
1768 | # Drop our port from t/tmp/ports; do this after dropping the | |
1769 | # database, as our port lock is also a lock on the database name. | |
1770 | if ($port) { | |
1771 | my %ports; | |
1772 | my $portfile = "$tmp{'directory'}/../ports"; | |
1773 | sysopen(PORTS, $portfile, O_RDWR|O_CREAT) | |
1774 | or die "Can't write to ports file $portfile: $!"; | |
1775 | flock(PORTS, LOCK_EX) | |
1776 | or die "Can't write-lock ports file $portfile: $!"; | |
1777 | $ports{$_}++ for split ' ', join("",<PORTS>); | |
1778 | delete $ports{$port}; | |
1779 | seek(PORTS, 0, 0); | |
1780 | truncate(PORTS, 0); | |
1781 | print PORTS "$_\n" for sort {$a <=> $b} keys %ports; | |
1782 | close(PORTS) or die "Can't close ports file: $!"; | |
1783 | } | |
1784 | } | |
1785 | ||
1786 | { | |
1787 | # ease the used only once warning | |
1788 | no warnings; | |
1789 | no strict 'refs'; | |
1790 | %{'RT::I18N::en_us::Lexicon'}; | |
1791 | %{'Win32::Locale::Lexicon'}; | |
1792 | } | |
1793 | ||
1794 | 1; |