lib/RT/Test.pm

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