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