rt/lib/RT/Test.pm

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