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 =head2 load_or_create_queue
 713
 714 =cut
 715
 716 sub load_or_create_queue {
 717     my $self = shift;
 718     my %args = ( Disabled => 0, @_ );
 719     my $obj = RT::Queue->new( RT->SystemUser );
 720     if ( $args{'Name'} ) {
 721         $obj->LoadByCols( Name => $args{'Name'} );
 722     } else {
 723         die "Name is required";
 724     }
 725     unless ( $obj->id ) {
 726         my ($val, $msg) = $obj->Create( %args );
 727         die "$msg" unless $val;
 728     } else {
 729         my @fields = qw(CorrespondAddress CommentAddress);
 730         foreach my $field ( @fields ) {
 731             next unless exists $args{ $field };
 732             next if $args{ $field } eq ($obj->$field || '');
 733
 734             no warnings 'uninitialized';
 735             my $method = 'Set'. $field;
 736             my ($val, $msg) = $obj->$method( $args{ $field } );
 737             die "$msg" unless $val;
 738         }
 739     }
 740
 741     return $obj;
 742 }
 743
 744 sub delete_queue_watchers {
 745     my $self = shift;
 746     my @queues = @_;
 747
 748     foreach my $q ( @queues ) {
 749         foreach my $t (qw(Cc AdminCc) ) {
 750             $q->DeleteWatcher( Type => $t, PrincipalId => $_->MemberId )
 751                 foreach @{ $q->$t()->MembersObj->ItemsArrayRef };
 752         }
 753     }
 754 }
 755
 756 sub create_tickets {
 757     local $Test::Builder::Level = $Test::Builder::Level + 1;
 758
 759     my $self = shift;
 760     my $defaults = shift;
 761     my @data = @_;
 762     @data = sort { rand(100) <=> rand(100) } @data
 763         if delete $defaults->{'RandomOrder'};
 764
 765     $defaults->{'Queue'} ||= 'General';
 766
 767     my @res = ();
 768     while ( @data ) {
 769         my %args = %{ shift @data };
 770         $args{$_} = $res[ $args{$_} ]->id foreach
 771             grep $args{ $_ }, keys %RT::Ticket::LINKTYPEMAP;
 772         push @res, $self->create_ticket( %$defaults, %args );
 773     }
 774     return @res;
 775 }
 776
 777 sub create_ticket {
 778     local $Test::Builder::Level = $Test::Builder::Level + 1;
 779
 780     my $self = shift;
 781     my %args = @_;
 782
 783     if ($args{Queue} && $args{Queue} =~ /\D/) {
 784         my $queue = RT::Queue->new(RT->SystemUser);
 785         if (my $id = $queue->Load($args{Queue}) ) {
 786             $args{Queue} = $id;
 787         } else {
 788             die ("Error: Invalid queue $args{Queue}");
 789         }
 790     }
 791
 792     if ( my $content = delete $args{'Content'} ) {
 793         $args{'MIMEObj'} = MIME::Entity->build(
 794             From    => $args{'Requestor'},
 795             Subject => $args{'Subject'},
 796             Data    => $content,
 797         );
 798     }
 799
 800     my $ticket = RT::Ticket->new( RT->SystemUser );
 801     my ( $id, undef, $msg ) = $ticket->Create( %args );
 802     Test::More::ok( $id, "ticket created" )
 803         or Test::More::diag("error: $msg");
 804
 805     # hackish, but simpler
 806     if ( $args{'LastUpdatedBy'} ) {
 807         $ticket->__Set( Field => 'LastUpdatedBy', Value => $args{'LastUpdatedBy'} );
 808     }
 809
 810
 811     for my $field ( keys %args ) {
 812         #TODO check links and watchers
 813
 814         if ( $field =~ /CustomField-(\d+)/ ) {
 815             my $cf = $1;
 816             my $got = join ',', sort map $_->Content,
 817                 @{ $ticket->CustomFieldValues($cf)->ItemsArrayRef };
 818             my $expected = ref $args{$field}
 819                 ? join( ',', sort @{ $args{$field} } )
 820                 : $args{$field};
 821             Test::More::is( $got, $expected, 'correct CF values' );
 822         }
 823         else {
 824             next if ref $args{$field};
 825             next unless $ticket->can($field) or $ticket->_Accessible($field,"read");
 826             next if ref $ticket->$field();
 827             Test::More::is( $ticket->$field(), $args{$field}, "$field is correct" );
 828         }
 829     }
 830
 831     return $ticket;
 832 }
 833
 834 sub delete_tickets {
 835     my $self = shift;
 836     my $query = shift;
 837     my $tickets = RT::Tickets->new( RT->SystemUser );
 838     if ( $query ) {
 839         $tickets->FromSQL( $query );
 840     }
 841     else {
 842         $tickets->UnLimit;
 843     }
 844     while ( my $ticket = $tickets->Next ) {
 845         $ticket->Delete;
 846     }
 847 }
 848
 849 =head2 load_or_create_custom_field
 850
 851 =cut
 852
 853 sub load_or_create_custom_field {
 854     my $self = shift;
 855     my %args = ( Disabled => 0, @_ );
 856     my $obj = RT::CustomField->new( RT->SystemUser );
 857     if ( $args{'Name'} ) {
 858         $obj->LoadByName( Name => $args{'Name'}, Queue => $args{'Queue'} );
 859     } else {
 860         die "Name is required";
 861     }
 862     unless ( $obj->id ) {
 863         my ($val, $msg) = $obj->Create( %args );
 864         die "$msg" unless $val;
 865     }
 866
 867     return $obj;
 868 }
 869
 870 sub last_ticket {
 871     my $self = shift;
 872     my $current = shift;
 873     $current = $current ? RT::CurrentUser->new($current) : RT->SystemUser;
 874     my $tickets = RT::Tickets->new( $current );
 875     $tickets->OrderBy( FIELD => 'id', ORDER => 'DESC' );
 876     $tickets->Limit( FIELD => 'id', OPERATOR => '>', VALUE => '0' );
 877     $tickets->RowsPerPage( 1 );
 878     return $tickets->First;
 879 }
 880
 881 sub store_rights {
 882     my $self = shift;
 883
 884     require RT::ACE;
 885     # fake construction
 886     RT::ACE->new( RT->SystemUser );
 887     my @fields = keys %{ RT::ACE->_ClassAccessible };
 888
 889     require RT::ACL;
 890     my $acl = RT::ACL->new( RT->SystemUser );
 891     $acl->Limit( FIELD => 'RightName', OPERATOR => '!=', VALUE => 'SuperUser' );
 892
 893     my @res;
 894     while ( my $ace = $acl->Next ) {
 895         my $obj = $ace->PrincipalObj->Object;
 896         if ( $obj->isa('RT::Group') && $obj->Type eq 'UserEquiv' && $obj->Instance == RT->Nobody->id ) {
 897             next;
 898         }
 899
 900         my %tmp = ();
 901         foreach my $field( @fields ) {
 902             $tmp{ $field } = $ace->__Value( $field );
 903         }
 904         push @res, \%tmp;
 905     }
 906     return @res;
 907 }
 908
 909 sub restore_rights {
 910     my $self = shift;
 911     my @entries = @_;
 912     foreach my $entry ( @entries ) {
 913         my $ace = RT::ACE->new( RT->SystemUser );
 914         my ($status, $msg) = $ace->RT::Record::Create( %$entry );
 915         unless ( $status ) {
 916             Test::More::diag "couldn't create a record: $msg";
 917         }
 918     }
 919 }
 920
 921 sub set_rights {
 922     my $self = shift;
 923
 924     require RT::ACL;
 925     my $acl = RT::ACL->new( RT->SystemUser );
 926     $acl->Limit( FIELD => 'RightName', OPERATOR => '!=', VALUE => 'SuperUser' );
 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         $ace->Delete;
 933     }
 934     return $self->add_rights( @_ );
 935 }
 936
 937 sub add_rights {
 938     my $self = shift;
 939     my @list = ref $_[0]? @_: @_? { @_ }: ();
 940
 941     require RT::ACL;
 942     foreach my $e (@list) {
 943         my $principal = delete $e->{'Principal'};
 944         unless ( ref $principal ) {
 945             if ( $principal =~ /^(everyone|(?:un)?privileged)$/i ) {
 946                 $principal = RT::Group->new( RT->SystemUser );
 947                 $principal->LoadSystemInternalGroup($1);
 948             } elsif ( $principal =~ /^(Owner|Requestor|(?:Admin)?Cc)$/i ) {
 949                 $principal = RT::Group->new( RT->SystemUser );
 950                 $principal->LoadByCols(
 951                     Domain => (ref($e->{'Object'})||'RT::System').'-Role',
 952                     Type => $1,
 953                     ref($e->{'Object'})? (Instance => $e->{'Object'}->id): (),
 954                 );
 955             } else {
 956                 die "principal is not an object, but also is not name of a system group";
 957             }
 958         }
 959         unless ( $principal->isa('RT::Principal') ) {
 960             if ( $principal->can('PrincipalObj') ) {
 961                 $principal = $principal->PrincipalObj;
 962             }
 963         }
 964         my @rights = ref $e->{'Right'}? @{ $e->{'Right'} }: ($e->{'Right'});
 965         foreach my $right ( @rights ) {
 966             my ($status, $msg) = $principal->GrantRight( %$e, Right => $right );
 967             $RT::Logger->debug($msg);
 968         }
 969     }
 970     return 1;
 971 }
 972
 973 sub run_mailgate {
 974     my $self = shift;
 975
 976     require RT::Test::Web;
 977     my %args = (
 978         url     => RT::Test::Web->rt_base_url,
 979         message => '',
 980         action  => 'correspond',
 981         queue   => 'General',
 982         debug   => 1,
 983         command => $RT::BinPath .'/rt-mailgate',
 984         @_
 985     );
 986     my $message = delete $args{'message'};
 987
 988     $args{after_open} = sub {
 989         my $child_in = shift;
 990         if ( UNIVERSAL::isa($message, 'MIME::Entity') ) {
 991             $message->print( $child_in );
 992         } else {
 993             print $child_in $message;
 994         }
 995     };
 996
 997     $self->run_and_capture(%args);
 998 }
 999
1000 sub run_and_capture {
1001     my $self = shift;
1002     my %args = @_;
1003
1004     my $after_open = delete $args{after_open};
1005
1006     my $cmd = delete $args{'command'};
1007     die "Couldn't find command ($cmd)" unless -f $cmd;
1008
1009     $cmd .= ' --debug' if delete $args{'debug'};
1010
1011     while( my ($k,$v) = each %args ) {
1012         next unless $v;
1013         $cmd .= " --$k '$v'";
1014     }
1015     $cmd .= ' 2>&1';
1016
1017     DBIx::SearchBuilder::Record::Cachable->FlushCache;
1018
1019     require IPC::Open2;
1020     my ($child_out, $child_in);
1021     my $pid = IPC::Open2::open2($child_out, $child_in, $cmd);
1022
1023     $after_open->($child_in, $child_out) if $after_open;
1024
1025     close $child_in;
1026
1027     my $result = do { local $/; <$child_out> };
1028     close $child_out;
1029     waitpid $pid, 0;
1030     return ($?, $result);
1031 }
1032
1033 sub send_via_mailgate_and_http {
1034     my $self = shift;
1035     my $message = shift;
1036     my %args = (@_);
1037
1038     my ($status, $gate_result) = $self->run_mailgate(
1039         message => $message, %args
1040     );
1041
1042     my $id;
1043     unless ( $status >> 8 ) {
1044         ($id) = ($gate_result =~ /Ticket:\s*(\d+)/i);
1045         unless ( $id ) {
1046             Test::More::diag "Couldn't find ticket id in text:\n$gate_result"
1047                 if $ENV{'TEST_VERBOSE'};
1048         }
1049     } else {
1050         Test::More::diag "Mailgate output:\n$gate_result"
1051             if $ENV{'TEST_VERBOSE'};
1052     }
1053     return ($status, $id);
1054 }
1055
1056
1057 sub send_via_mailgate {
1058     my $self    = shift;
1059     my $message = shift;
1060     my %args = ( action => 'correspond',
1061                  queue  => 'General',
1062                  @_
1063                );
1064
1065     if ( UNIVERSAL::isa( $message, 'MIME::Entity' ) ) {
1066         $message = $message->as_string;
1067     }
1068
1069     my ( $status, $error_message, $ticket )
1070         = RT::Interface::Email::Gateway( {%args, message => $message} );
1071     return ( $status, $ticket ? $ticket->id : 0 );
1072
1073 }
1074
1075
1076 sub open_mailgate_ok {
1077     my $class   = shift;
1078     my $baseurl = shift;
1079     my $queue   = shift || 'general';
1080     my $action  = shift || 'correspond';
1081     Test::More::ok(open(my $mail, '|-', "$RT::BinPath/rt-mailgate --url $baseurl --queue $queue --action $action"), "Opened the mailgate - $!");
1082     return $mail;
1083 }
1084
1085
1086 sub close_mailgate_ok {
1087     my $class = shift;
1088     my $mail  = shift;
1089     close $mail;
1090     Test::More::is ($? >> 8, 0, "The mail gateway exited normally. yay");
1091 }
1092
1093 sub mailsent_ok {
1094     my $class = shift;
1095     my $expected  = shift;
1096
1097     my $mailsent = scalar grep /\S/, split /%% split me! %%\n/,
1098         RT::Test->file_content(
1099             $tmp{'mailbox'},
1100             'unlink' => 0,
1101             noexist => 1
1102         );
1103
1104     Test::More::is(
1105         $mailsent, $expected,
1106         "The number of mail sent ($expected) matches. yay"
1107     );
1108 }
1109
1110 sub fetch_caught_mails {
1111     my $self = shift;
1112     return grep /\S/, split /%% split me! %%\n/,
1113         RT::Test->file_content(
1114             $tmp{'mailbox'},
1115             'unlink' => 1,
1116             noexist => 1
1117         );
1118 }
1119
1120 sub clean_caught_mails {
1121     unlink $tmp{'mailbox'};
1122 }
1123
1124 =head2 get_relocatable_dir
1125
1126 Takes a path relative to the location of the test file that is being
1127 run and returns a path that takes the invocation path into account.
1128
1129 e.g. C<RT::Test::get_relocatable_dir(File::Spec->updir(), 'data', 'emails')>
1130
1131 Parent directory traversals (C<..> or File::Spec->updir()) are naively
1132 canonicalized based on the test file path (C<$0>) so that symlinks aren't
1133 followed.  This is the exact opposite behaviour of most filesystems and is
1134 considered "wrong", however it is necessary for some subsets of tests which are
1135 symlinked into the testing tree.
1136
1137 =cut
1138
1139 sub get_relocatable_dir {
1140     my @directories = File::Spec->splitdir(
1141         File::Spec->rel2abs((File::Spec->splitpath($0))[1])
1142     );
1143     push @directories, File::Spec->splitdir($_) for @_;
1144
1145     my @clean;
1146     for (@directories) {
1147         if    ($_ eq "..") { pop @clean      }
1148         elsif ($_ ne ".")  { push @clean, $_ }
1149     }
1150     return File::Spec->catdir(@clean);
1151 }
1152
1153 =head2 get_relocatable_file
1154
1155 Same as get_relocatable_dir, but takes a file and a path instead
1156 of just a path.
1157
1158 e.g. RT::Test::get_relocatable_file('test-email',
1159         (File::Spec->updir(), 'data', 'emails'))
1160
1161 =cut
1162
1163 sub get_relocatable_file {
1164     my $file = shift;
1165     return File::Spec->catfile(get_relocatable_dir(@_), $file);
1166 }
1167
1168 sub get_abs_relocatable_dir {
1169     (my $volume, my $directories, my $file) = File::Spec->splitpath($0);
1170     if (File::Spec->file_name_is_absolute($directories)) {
1171         return File::Spec->catdir($directories, @_);
1172     } else {
1173         return File::Spec->catdir(Cwd->getcwd(), $directories, @_);
1174     }
1175 }
1176
1177 sub gnupg_homedir {
1178     my $self = shift;
1179     File::Temp->newdir(
1180         DIR => $tmp{directory},
1181         CLEANUP => 0,
1182     );
1183 }
1184
1185 sub import_gnupg_key {
1186     my $self = shift;
1187     my $key  = shift;
1188     my $type = shift || 'secret';
1189
1190     $key =~ s/\@/-at-/g;
1191     $key .= ".$type.key";
1192
1193     require RT::Crypt::GnuPG;
1194
1195     # simple strategy find data/gnupg/keys, from the dir where test file lives
1196     # to updirs, try 3 times in total
1197     my $path = File::Spec->catfile( 'data', 'gnupg', 'keys' );
1198     my $abs_path;
1199     for my $up ( 0 .. 2 ) {
1200         my $p = get_relocatable_dir($path);
1201         if ( -e $p ) {
1202             $abs_path = $p;
1203             last;
1204         }
1205         else {
1206             $path = File::Spec->catfile( File::Spec->updir(), $path );
1207         }
1208     }
1209
1210     die "can't find the dir where gnupg keys are stored"
1211       unless $abs_path;
1212
1213     return RT::Crypt::GnuPG::ImportKey(
1214         RT::Test->file_content( [ $abs_path, $key ] ) );
1215 }
1216
1217
1218 sub lsign_gnupg_key {
1219     my $self = shift;
1220     my $key = shift;
1221
1222     require RT::Crypt::GnuPG; require GnuPG::Interface;
1223     my $gnupg = GnuPG::Interface->new();
1224     my %opt = RT->Config->Get('GnuPGOptions');
1225     $gnupg->options->hash_init(
1226         RT::Crypt::GnuPG::_PrepareGnuPGOptions( %opt ),
1227         meta_interactive => 0,
1228     );
1229
1230     my %handle;
1231     my $handles = GnuPG::Handles->new(
1232         stdin   => ($handle{'input'}   = IO::Handle->new()),
1233         stdout  => ($handle{'output'}  = IO::Handle->new()),
1234         stderr  => ($handle{'error'}   = IO::Handle->new()),
1235         logger  => ($handle{'logger'}  = IO::Handle->new()),
1236         status  => ($handle{'status'}  = IO::Handle->new()),
1237         command => ($handle{'command'} = IO::Handle->new()),
1238     );
1239
1240     eval {
1241         local $SIG{'CHLD'} = 'DEFAULT';
1242         local @ENV{'LANG', 'LC_ALL'} = ('C', 'C');
1243         my $pid = $gnupg->wrap_call(
1244             handles => $handles,
1245             commands => ['--lsign-key'],
1246             command_args => [$key],
1247         );
1248         close $handle{'input'};
1249         while ( my $str = readline $handle{'status'} ) {
1250             if ( $str =~ /^\[GNUPG:\]\s*GET_BOOL sign_uid\..*/ ) {
1251                 print { $handle{'command'} } "y\n";
1252             }
1253         }
1254         waitpid $pid, 0;
1255     };
1256     my $err = $@;
1257     close $handle{'output'};
1258
1259     my %res;
1260     $res{'exit_code'} = $?;
1261     foreach ( qw(error logger status) ) {
1262         $res{$_} = do { local $/; readline $handle{$_} };
1263         delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
1264         close $handle{$_};
1265     }
1266     $RT::Logger->debug( $res{'status'} ) if $res{'status'};
1267     $RT::Logger->warning( $res{'error'} ) if $res{'error'};
1268     $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
1269     if ( $err || $res{'exit_code'} ) {
1270         $res{'message'} = $err? $err : "gpg exitted with error code ". ($res{'exit_code'} >> 8);
1271     }
1272     return %res;
1273 }
1274
1275 sub trust_gnupg_key {
1276     my $self = shift;
1277     my $key = shift;
1278
1279     require RT::Crypt::GnuPG; require GnuPG::Interface;
1280     my $gnupg = GnuPG::Interface->new();
1281     my %opt = RT->Config->Get('GnuPGOptions');
1282     $gnupg->options->hash_init(
1283         RT::Crypt::GnuPG::_PrepareGnuPGOptions( %opt ),
1284         meta_interactive => 0,
1285     );
1286
1287     my %handle;
1288     my $handles = GnuPG::Handles->new(
1289         stdin   => ($handle{'input'}   = IO::Handle->new()),
1290         stdout  => ($handle{'output'}  = IO::Handle->new()),
1291         stderr  => ($handle{'error'}   = IO::Handle->new()),
1292         logger  => ($handle{'logger'}  = IO::Handle->new()),
1293         status  => ($handle{'status'}  = IO::Handle->new()),
1294         command => ($handle{'command'} = IO::Handle->new()),
1295     );
1296
1297     eval {
1298         local $SIG{'CHLD'} = 'DEFAULT';
1299         local @ENV{'LANG', 'LC_ALL'} = ('C', 'C');
1300         my $pid = $gnupg->wrap_call(
1301             handles => $handles,
1302             commands => ['--edit-key'],
1303             command_args => [$key],
1304         );
1305         close $handle{'input'};
1306
1307         my $done = 0;
1308         while ( my $str = readline $handle{'status'} ) {
1309             if ( $str =~ /^\[GNUPG:\]\s*\QGET_LINE keyedit.prompt/ ) {
1310                 if ( $done ) {
1311                     print { $handle{'command'} } "quit\n";
1312                 } else {
1313                     print { $handle{'command'} } "trust\n";
1314                 }
1315             } elsif ( $str =~ /^\[GNUPG:\]\s*\QGET_LINE edit_ownertrust.value/ ) {
1316                 print { $handle{'command'} } "5\n";
1317             } elsif ( $str =~ /^\[GNUPG:\]\s*\QGET_BOOL edit_ownertrust.set_ultimate.okay/ ) {
1318                 print { $handle{'command'} } "y\n";
1319                 $done = 1;
1320             }
1321         }
1322         waitpid $pid, 0;
1323     };
1324     my $err = $@;
1325     close $handle{'output'};
1326
1327     my %res;
1328     $res{'exit_code'} = $?;
1329     foreach ( qw(error logger status) ) {
1330         $res{$_} = do { local $/; readline $handle{$_} };
1331         delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
1332         close $handle{$_};
1333     }
1334     $RT::Logger->debug( $res{'status'} ) if $res{'status'};
1335     $RT::Logger->warning( $res{'error'} ) if $res{'error'};
1336     $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
1337     if ( $err || $res{'exit_code'} ) {
1338         $res{'message'} = $err? $err : "gpg exitted with error code ". ($res{'exit_code'} >> 8);
1339     }
1340     return %res;
1341 }
1342
1343 sub started_ok {
1344     my $self = shift;
1345
1346     require RT::Test::Web;
1347
1348     if ($rttest_opt{nodb} and not $rttest_opt{server_ok}) {
1349         die "You are trying to use a test web server without a database. "
1350            ."You may want noinitialdata => 1 instead. "
1351            ."Pass server_ok => 1 if you know what you're doing.";
1352     }
1353
1354
1355     $ENV{'RT_TEST_WEB_HANDLER'} = undef
1356         if $rttest_opt{actual_server} && ($ENV{'RT_TEST_WEB_HANDLER'}||'') eq 'inline';
1357     $ENV{'RT_TEST_WEB_HANDLER'} ||= 'plack';
1358     my $which = $ENV{'RT_TEST_WEB_HANDLER'};
1359     my ($server, $variant) = split /\+/, $which, 2;
1360
1361     my $function = 'start_'. $server .'_server';
1362     unless ( $self->can($function) ) {
1363         die "Don't know how to start server '$server'";
1364     }
1365     return $self->$function( variant => $variant, @_ );
1366 }
1367
1368 sub test_app {
1369     my $self = shift;
1370     my %server_opt = @_;
1371
1372     my $app;
1373
1374     my $warnings = "";
1375     open( my $warn_fh, ">", \$warnings );
1376     local *STDERR = $warn_fh;
1377
1378     if ($server_opt{variant} and $server_opt{variant} eq 'rt-server') {
1379         $app = do {
1380             my $file = "$RT::SbinPath/rt-server";
1381             my $psgi = do $file;
1382             unless ($psgi) {
1383                 die "Couldn't parse $file: $@" if $@;
1384                 die "Couldn't do $file: $!"    unless defined $psgi;
1385                 die "Couldn't run $file"       unless $psgi;
1386             }
1387             $psgi;
1388         };
1389     } else {
1390         require RT::Interface::Web::Handler;
1391         $app = RT::Interface::Web::Handler->PSGIApp;
1392     }
1393
1394     require Plack::Middleware::Test::StashWarnings;
1395     my $stashwarnings = Plack::Middleware::Test::StashWarnings->new;
1396     $app = $stashwarnings->wrap($app);
1397
1398     if ($server_opt{basic_auth}) {
1399         require Plack::Middleware::Auth::Basic;
1400         $app = Plack::Middleware::Auth::Basic->wrap(
1401             $app,
1402             authenticator => sub {
1403                 my ($username, $password) = @_;
1404                 return $username eq 'root' && $password eq 'password';
1405             }
1406         );
1407     }
1408
1409     close $warn_fh;
1410     $stashwarnings->add_warning( $warnings ) if $warnings;
1411
1412     return $app;
1413 }
1414
1415 sub start_plack_server {
1416     my $self = shift;
1417
1418     require Plack::Loader;
1419     my $plack_server = Plack::Loader->load
1420         ('Standalone',
1421          port => $port,
1422          server_ready => sub {
1423              kill 'USR1' => getppid();
1424          });
1425
1426     # We are expecting a USR1 from the child process after it's ready
1427     # to listen.  We set this up _before_ we fork to avoid race
1428     # conditions.
1429     my $handled;
1430     local $SIG{USR1} = sub { $handled = 1};
1431
1432     __disconnect_rt();
1433     my $pid = fork();
1434     die "failed to fork" unless defined $pid;
1435
1436     if ($pid) {
1437         sleep 15 unless $handled;
1438         Test::More::diag "did not get expected USR1 for test server readiness"
1439             unless $handled;
1440         push @SERVERS, $pid;
1441         my $Tester = Test::Builder->new;
1442         $Tester->ok(1, "started plack server ok");
1443
1444         __reconnect_rt()
1445             unless $rttest_opt{nodb};
1446         return ("http://localhost:$port", RT::Test::Web->new);
1447     }
1448
1449     require POSIX;
1450     if ( $^O !~ /MSWin32/ ) {
1451         POSIX::setsid()
1452             or die "Can't start a new session: $!";
1453     }
1454
1455     # stick this in a scope so that when $app is garbage collected,
1456     # StashWarnings can complain about unhandled warnings
1457     do {
1458         $plack_server->run($self->test_app(@_));
1459     };
1460
1461     exit;
1462 }
1463
1464 our $TEST_APP;
1465 sub start_inline_server {
1466     my $self = shift;
1467
1468     require Test::WWW::Mechanize::PSGI;
1469     unshift @RT::Test::Web::ISA, 'Test::WWW::Mechanize::PSGI';
1470
1471     # Clear out squished CSS and JS cache, since it's retained across
1472     # servers, since it's in-process
1473     RT::Interface::Web->ClearSquished;
1474     require RT::Interface::Web::Request;
1475     RT::Interface::Web::Request->clear_callback_cache;
1476
1477     Test::More::ok(1, "psgi test server ok");
1478     $TEST_APP = $self->test_app(@_);
1479     return ("http://localhost:$port", RT::Test::Web->new);
1480 }
1481
1482 sub start_apache_server {
1483     my $self = shift;
1484     my %server_opt = @_;
1485     $server_opt{variant} ||= 'mod_perl';
1486     $ENV{RT_TEST_WEB_HANDLER} = "apache+$server_opt{variant}";
1487
1488     require RT::Test::Apache;
1489     my $pid = RT::Test::Apache->start_server(
1490         %server_opt,
1491         port => $port,
1492         tmp => \%tmp
1493     );
1494     push @SERVERS, $pid;
1495
1496     my $url = RT->Config->Get('WebURL');
1497     $url =~ s!/$!!;
1498     return ($url, RT::Test::Web->new);
1499 }
1500
1501 sub stop_server {
1502     my $self = shift;
1503     my $in_end = shift;
1504     return unless @SERVERS;
1505
1506     kill 'TERM', @SERVERS;
1507     foreach my $pid (@SERVERS) {
1508         if ($ENV{RT_TEST_WEB_HANDLER} =~ /^apache/) {
1509             sleep 1 while kill 0, $pid;
1510         } else {
1511             waitpid $pid, 0;
1512         }
1513     }
1514
1515     @SERVERS = ();
1516 }
1517
1518 sub temp_directory {
1519     return $tmp{'directory'};
1520 }
1521
1522 sub file_content {
1523     my $self = shift;
1524     my $path = shift;
1525     my %args = @_;
1526
1527     $path = File::Spec->catfile( @$path ) if ref $path eq 'ARRAY';
1528
1529     Test::More::diag "reading content of '$path'" if $ENV{'TEST_VERBOSE'};
1530
1531     open( my $fh, "<:raw", $path )
1532         or do {
1533             warn "couldn't open file '$path': $!" unless $args{noexist};
1534             return ''
1535         };
1536     my $content = do { local $/; <$fh> };
1537     close $fh;
1538
1539     unlink $path if $args{'unlink'};
1540
1541     return $content;
1542 }
1543
1544 sub find_executable {
1545     my $self = shift;
1546     my $name = shift;
1547
1548     require File::Spec;
1549     foreach my $dir ( split /:/, $ENV{'PATH'} ) {
1550         my $fpath = File::Spec->catpath(
1551             (File::Spec->splitpath( $dir, 'no file' ))[0..1], $name
1552         );
1553         next unless -e $fpath && -r _ && -x _;
1554         return $fpath;
1555     }
1556     return undef;
1557 }
1558
1559 sub diag {
1560     return unless $ENV{RT_TEST_VERBOSE} || $ENV{TEST_VERBOSE};
1561     goto \&Test::More::diag;
1562 }
1563
1564 sub parse_mail {
1565     my $mail = shift;
1566     require RT::EmailParser;
1567     my $parser = RT::EmailParser->new;
1568     $parser->ParseMIMEEntityFromScalar( $mail );
1569     return $parser->Entity;
1570 }
1571
1572 sub works {
1573     Test::More::ok($_[0], $_[1] || 'This works');
1574 }
1575
1576 sub fails {
1577     Test::More::ok(!$_[0], $_[1] || 'This should fail');
1578 }
1579
1580 sub plan {
1581     my ($cmd, @args) = @_;
1582     my $builder = RT::Test->builder;
1583
1584     if ($cmd eq "skip_all") {
1585         $check_warnings_in_end = 0;
1586     } elsif ($cmd eq "tests") {
1587         # Increment the test count for the warnings check
1588         $args[0]++;
1589     }
1590     $builder->plan($cmd, @args);
1591 }
1592
1593 sub done_testing {
1594     my $builder = RT::Test->builder;
1595
1596     Test::NoWarnings::had_no_warnings();
1597     $check_warnings_in_end = 0;
1598
1599     $builder->done_testing(@_);
1600 }
1601
1602 END {
1603     my $Test = RT::Test->builder;
1604     return if $Test->{Original_Pid} != $$;
1605
1606     # we are in END block and should protect our exit code
1607     # so calls below may call system or kill that clobbers $?
1608     local $?;
1609
1610     Test::NoWarnings::had_no_warnings() if $check_warnings_in_end;
1611
1612     RT::Test->stop_server(1);
1613
1614     # not success
1615     if ( !$Test->is_passing ) {
1616         $tmp{'directory'}->unlink_on_destroy(0);
1617
1618         Test::More::diag(
1619             "Some tests failed or we bailed out, tmp directory"
1620             ." '$tmp{directory}' is not cleaned"
1621         );
1622     }
1623
1624     if ( $ENV{RT_TEST_PARALLEL} && $created_new_db ) {
1625         __drop_database();
1626     }
1627
1628     # Drop our port from t/tmp/ports; do this after dropping the
1629     # database, as our port lock is also a lock on the database name.
1630     if ($port) {
1631         my %ports;
1632         my $portfile = "$tmp{'directory'}/../ports";
1633         sysopen(PORTS, $portfile, O_RDWR|O_CREAT)
1634             or die "Can't write to ports file $portfile: $!";
1635         flock(PORTS, LOCK_EX)
1636             or die "Can't write-lock ports file $portfile: $!";
1637         $ports{$_}++ for split ' ', join("",<PORTS>);
1638         delete $ports{$port};
1639         seek(PORTS, 0, 0);
1640         truncate(PORTS, 0);
1641         print PORTS "$_\n" for sort {$a <=> $b} keys %ports;
1642         close(PORTS) or die "Can't close ports file: $!";
1643     }
1644 }
1645
1646 {
1647     # ease the used only once warning
1648     no warnings;
1649     no strict 'refs';
1650     %{'RT::I18N::en_us::Lexicon'};
1651     %{'Win32::Locale::Lexicon'};
1652 }
1653
1654 1;