rt/lib/RT/Test.pm

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