rt/lib/RT/Test.pm

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