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