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