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