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