lib/RT/Test.pm

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