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