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