rt/lib/RT/Test.pm

   1 # BEGIN BPS TAGGED BLOCK {{{
   2 #
   3 # COPYRIGHT:
   4 #
   5 # This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC
   6 #                                          <jesse@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 use base 'Test::More';
  55
  56 use Socket;
  57 use File::Temp qw(tempfile);
  58 use File::Path qw(mkpath);
  59 use File::Spec;
  60
  61 our $SKIP_REQUEST_WORK_AROUND = 0;
  62
  63 use HTTP::Request::Common ();
  64 use Hook::LexWrap;
  65 wrap 'HTTP::Request::Common::form_data',
  66    post => sub {
  67        return if $SKIP_REQUEST_WORK_AROUND;
  68        my $data = $_[-1];
  69        if (ref $data) {
  70        $data->[0] = Encode::encode_utf8($data->[0]);
  71        }
  72        else {
  73        $_[-1] = Encode::encode_utf8($_[-1]);
  74        }
  75    };
  76
  77
  78 our @EXPORT = qw(is_empty);
  79 our ($port, $dbname);
  80 our @SERVERS;
  81
  82 my %tmp = (
  83     directory => undef,
  84     config    => {
  85         RT => undef,
  86         apache => undef,
  87     },
  88     mailbox   => undef,
  89 );
  90
  91 =head1 NAME
  92
  93 RT::Test - RT Testing
  94
  95 =head1 NOTES
  96
  97 =head2 COVERAGE
  98
  99 To run the rt test suite with coverage support, install L<Devel::Cover> and run:
 100
 101     make test RT_DBA_USER=.. RT_DBA_PASSWORD=.. HARNESS_PERL_SWITCHES=-MDevel::Cover
 102     cover -ignore_re '^var/mason_data/' -ignore_re '^t/'
 103
 104 The coverage tests have DevelMode turned off, and have
 105 C<named_component_subs> enabled for L<HTML::Mason> to avoid an optimizer
 106 problem in Perl that hides the top-level optree from L<Devel::Cover>.
 107
 108 =cut
 109
 110 sub generate_port {
 111     my $self = shift;
 112     my $port = 1024 + int rand(10000) + $$ % 1024;
 113
 114     my $paddr = sockaddr_in( $port, inet_aton('localhost') );
 115     socket( SOCK, PF_INET, SOCK_STREAM, getprotobyname('tcp') )
 116       or die "socket: $!";
 117     if ( connect( SOCK, $paddr ) ) {
 118         close(SOCK);
 119         return generate_port();
 120     }
 121     close(SOCK);
 122
 123     return $port;
 124 }
 125
 126 BEGIN {
 127     $port   = generate_port();
 128     $dbname = $ENV{RT_TEST_PARALLEL}? "rt3test_$port" : "rt3test";
 129 };
 130
 131 sub import {
 132     my $class = shift;
 133     my %args = @_;
 134
 135     # Spit out a plan (if we got one) *before* we load modules
 136     if ( $args{'tests'} ) {
 137         $class->builder->plan( tests => $args{'tests'} )
 138           unless $args{'tests'} eq 'no_declare';
 139     }
 140     else {
 141         $class->builder->no_plan unless $class->builder->has_plan;
 142     }
 143
 144     $class->bootstrap_tempdir;
 145
 146     $class->bootstrap_config( %args );
 147
 148     use RT;
 149     RT::LoadConfig;
 150
 151     if (RT->Config->Get('DevelMode')) { require Module::Refresh; }
 152
 153     $class->bootstrap_db( %args );
 154
 155     RT->Init;
 156
 157     $class->bootstrap_plugins( %args );
 158
 159     $class->set_config_wrapper;
 160
 161     my $screen_logger = $RT::Logger->remove( 'screen' );
 162     require Log::Dispatch::Perl;
 163     $RT::Logger->add( Log::Dispatch::Perl->new
 164                       ( name      => 'rttest',
 165                         min_level => $screen_logger->min_level,
 166                         action => { error     => 'warn',
 167                                     critical  => 'warn' } ) );
 168
 169     # XXX: this should really be totally isolated environment so we
 170     # can parallelize and be sane
 171     mkpath [ $RT::MasonSessionDir ]
 172         if RT->Config->Get('DatabaseType');
 173
 174     my $level = 1;
 175     while ( my ($package) = caller($level-1) ) {
 176         last unless $package =~ /Test/;
 177         $level++;
 178     }
 179
 180     Test::More->export_to_level($level);
 181     __PACKAGE__->export_to_level($level);
 182 }
 183
 184 sub is_empty($;$) {
 185     my ($v, $d) = shift;
 186     local $Test::Builder::Level = $Test::Builder::Level + 1;
 187     return Test::More::ok(1, $d) unless defined $v;
 188     return Test::More::ok(1, $d) unless length $v;
 189     return Test::More::is($v, '', $d);
 190 }
 191
 192 my $created_new_db;    # have we created new db? mainly for parallel testing
 193
 194 sub db_requires_no_dba {
 195     my $self = shift;
 196     my $db_type = RT->Config->Get('DatabaseType');
 197     return 1 if $db_type eq 'SQLite';
 198 }
 199
 200 sub bootstrap_tempdir {
 201     my $self = shift;
 202     my $test_file = (
 203         File::Spec->rel2abs((caller)[1])
 204             =~ m{(?:^|[\\/])t[/\\](.*)}
 205     );
 206     my $dir_name = File::Spec->rel2abs('t/tmp/'. $test_file);
 207     mkpath( $dir_name );
 208     return $tmp{'directory'} = File::Temp->newdir(
 209         DIR => $dir_name
 210     );
 211 }
 212
 213 sub bootstrap_config {
 214     my $self = shift;
 215     my %args = @_;
 216
 217     $tmp{'config'}{'RT'} = File::Spec->catfile(
 218         "$tmp{'directory'}", 'RT_SiteConfig.pm'
 219     );
 220     open my $config, '>', $tmp{'config'}{'RT'}
 221         or die "Couldn't open $tmp{'config'}{'RT'}: $!";
 222
 223     print $config qq{
 224 Set( \$WebPort , $port);
 225 Set( \$WebBaseURL , "http://localhost:\$WebPort");
 226 Set( \$LogToSyslog , undef);
 227 Set( \$LogToScreen , "warning");
 228 Set( \$MailCommand, 'testfile');
 229 };
 230     if ( $ENV{'RT_TEST_DB_SID'} ) { # oracle case
 231         print $config "Set( \$DatabaseName , '$ENV{'RT_TEST_DB_SID'}' );\n";
 232         print $config "Set( \$DatabaseUser , '$dbname');\n";
 233     } else {
 234         print $config "Set( \$DatabaseName , '$dbname');\n";
 235         print $config "Set( \$DatabaseUser , 'u${dbname}');\n";
 236     }
 237     print $config "Set( \$DevelMode, 0 );\n"
 238         if $INC{'Devel/Cover.pm'};
 239
 240     # set mail catcher
 241     my $mail_catcher = $tmp{'mailbox'} = File::Spec->catfile(
 242         $tmp{'directory'}->dirname, 'mailbox.eml'
 243     );
 244     print $config <<END;
 245 Set( \$MailCommand, sub {
 246     my \$MIME = shift;
 247
 248     open my \$handle, '>>', '$mail_catcher'
 249         or die "Unable to open '$mail_catcher' for appending: \$!";
 250
 251     \$MIME->print(\$handle);
 252     print \$handle "%% split me! %%\n";
 253     close \$handle;
 254 } );
 255 END
 256
 257     print $config $args{'config'} if $args{'config'};
 258
 259     print $config "\n1;\n";
 260     $ENV{'RT_SITE_CONFIG'} = $tmp{'config'}{'RT'};
 261     close $config;
 262
 263     return $config;
 264 }
 265
 266 sub set_config_wrapper {
 267     my $self = shift;
 268
 269     my $old_sub = \&RT::Config::Set;
 270     no warnings 'redefine';
 271     *RT::Config::Set = sub {
 272         my @caller = caller;
 273         if ( ($caller[1]||'') =~ /\.t$/ ) {
 274             my ($self, $name) = @_;
 275             my $type = $RT::Config::META{$name}->{'Type'} || 'SCALAR';
 276             my %sigils = (
 277                 HASH   => '%',
 278                 ARRAY  => '@',
 279                 SCALAR => '$',
 280             );
 281             my $sigil = $sigils{$type} || $sigils{'SCALAR'};
 282             open my $fh, '>>', $tmp{'config'}{'RT'}
 283                 or die "Couldn't open config file: $!";
 284             require Data::Dumper;
 285             print $fh
 286                 "\nSet(${sigil}${name}, \@{"
 287                     . Data::Dumper::Dumper([@_[2 .. $#_]])
 288                 ."}); 1;\n";
 289             close $fh;
 290
 291             if ( @SERVERS ) {
 292                 warn "you're changing config option in a test file"
 293                     ." when server is active";
 294             }
 295         }
 296         return $old_sub->(@_);
 297     };
 298 }
 299
 300 sub bootstrap_db {
 301     my $self = shift;
 302     my %args = @_;
 303
 304     unless (defined $ENV{'RT_DBA_USER'} && defined $ENV{'RT_DBA_PASSWORD'}) {
 305         Test::More::BAIL_OUT(
 306             "RT_DBA_USER and RT_DBA_PASSWORD environment variables need"
 307             ." to be set in order to run 'make test'"
 308         ) unless $self->db_requires_no_dba;
 309     }
 310
 311     require RT::Handle;
 312     # bootstrap with dba cred
 313     my $dbh = _get_dbh(RT::Handle->SystemDSN,
 314                $ENV{RT_DBA_USER}, $ENV{RT_DBA_PASSWORD});
 315
 316     unless ( $ENV{RT_TEST_PARALLEL} ) {
 317         # already dropped db in parallel tests, need to do so for other cases.
 318         RT::Handle->DropDatabase( $dbh, Force => 1 );
 319     }
 320
 321     RT::Handle->CreateDatabase( $dbh );
 322     $dbh->disconnect;
 323     $created_new_db++;
 324
 325     $dbh = _get_dbh(RT::Handle->DSN,
 326             $ENV{RT_DBA_USER}, $ENV{RT_DBA_PASSWORD});
 327
 328     $RT::Handle = new RT::Handle;
 329     $RT::Handle->dbh( $dbh );
 330     $RT::Handle->InsertSchema( $dbh );
 331
 332     my $db_type = RT->Config->Get('DatabaseType');
 333     $RT::Handle->InsertACL( $dbh ) unless $db_type eq 'Oracle';
 334
 335     $RT::Handle = new RT::Handle;
 336     $RT::Handle->dbh( undef );
 337     RT->ConnectToDatabase;
 338     RT->InitLogging;
 339     RT->InitSystemObjects;
 340     $RT::Handle->InsertInitialData;
 341
 342     DBIx::SearchBuilder::Record::Cachable->FlushCache;
 343     $RT::Handle = new RT::Handle;
 344     $RT::Handle->dbh( undef );
 345     RT->Init;
 346
 347     $RT::Handle->PrintError;
 348     $RT::Handle->dbh->{PrintError} = 1;
 349
 350     unless ( $args{'nodata'} ) {
 351         $RT::Handle->InsertData( $RT::EtcPath . "/initialdata" );
 352     }
 353     DBIx::SearchBuilder::Record::Cachable->FlushCache;
 354 }
 355
 356 sub bootstrap_plugins {
 357     my $self = shift;
 358     my %args = @_;
 359
 360     return unless $args{'requires'};
 361
 362     my @plugins = @{ $args{'requires'} };
 363     push @plugins, $args{'testing'}
 364         if $args{'testing'};
 365
 366     require RT::Plugin;
 367     my $cwd;
 368     if ( $args{'testing'} ) {
 369         require Cwd;
 370         $cwd = Cwd::getcwd();
 371     }
 372
 373     my $old_func = \&RT::Plugin::_BasePath;
 374     no warnings 'redefine';
 375     *RT::Plugin::_BasePath = sub {
 376         my $name = $_[0]->{'name'};
 377
 378         return $cwd if $args{'testing'} && $name eq $args{'testing'};
 379
 380         if ( grep $name eq $_, @plugins ) {
 381             my $variants = join "(?:|::|-|_)", map "\Q$_\E", split /::/, $name;
 382             my ($path) = map $ENV{$_}, grep /^CHIMPS_(?:$variants).*_ROOT$/i, keys %ENV;
 383             return $path if $path;
 384         }
 385         return $old_func->(@_);
 386     };
 387
 388     RT->Config->Set( Plugins => @plugins );
 389     RT->InitPluginPaths;
 390
 391     require File::Spec;
 392     foreach my $name ( @plugins ) {
 393         my $plugin = RT::Plugin->new( name => $name );
 394         Test::More::diag( "Initializing DB for the $name plugin" )
 395             if $ENV{'TEST_VERBOSE'};
 396
 397         my $etc_path = $plugin->Path('etc');
 398         Test::More::diag( "etc path of the plugin is '$etc_path'" )
 399             if $ENV{'TEST_VERBOSE'};
 400
 401         if ( -e $etc_path ) {
 402             my ($ret, $msg) = $RT::Handle->InsertSchema( undef, $etc_path );
 403             Test::More::ok($ret || $msg =~ /^Couldn't find schema/, "Created schema: ".($msg||''));
 404
 405             ($ret, $msg) = $RT::Handle->InsertACL( undef, $etc_path );
 406             Test::More::ok($ret || $msg =~ /^Couldn't find ACLs/, "Created ACL: ".($msg||''));
 407
 408             my $data_file = File::Spec->catfile( $etc_path, 'initialdata' );
 409             if ( -e $data_file ) {
 410                 ($ret, $msg) = $RT::Handle->InsertData( $data_file );;
 411                 Test::More::ok($ret, "Inserted data".($msg||''));
 412             } else {
 413                 Test::More::ok(1, "There is no data file" );
 414             }
 415         }
 416         else {
 417 # we can not say if plugin has no data or we screwed with etc path
 418             Test::More::ok(1, "There is no etc dir: no schema" );
 419             Test::More::ok(1, "There is no etc dir: no ACLs" );
 420             Test::More::ok(1, "There is no etc dir: no data" );
 421         }
 422
 423         $RT::Handle->Connect; # XXX: strange but mysql can loose connection
 424     }
 425 }
 426
 427 sub _get_dbh {
 428     my ($dsn, $user, $pass) = @_;
 429     if ( $dsn =~ /Oracle/i ) {
 430         $ENV{'NLS_LANG'} = "AMERICAN_AMERICA.AL32UTF8";
 431         $ENV{'NLS_NCHAR'} = "AL32UTF8";
 432     }
 433     my $dbh = DBI->connect(
 434         $dsn, $user, $pass,
 435         { RaiseError => 0, PrintError => 1 },
 436     );
 437     unless ( $dbh ) {
 438         my $msg = "Failed to connect to $dsn as user '$user': ". $DBI::errstr;
 439         print STDERR $msg; exit -1;
 440     }
 441     return $dbh;
 442 }
 443
 444 =head1 UTILITIES
 445
 446 =head2 load_or_create_user
 447
 448 =cut
 449
 450 sub load_or_create_user {
 451     my $self = shift;
 452     my %args = ( Privileged => 1, Disabled => 0, @_ );
 453
 454     my $MemberOf = delete $args{'MemberOf'};
 455     $MemberOf = [ $MemberOf ] if defined $MemberOf && !ref $MemberOf;
 456     $MemberOf ||= [];
 457
 458     my $obj = RT::User->new( $RT::SystemUser );
 459     if ( $args{'Name'} ) {
 460         $obj->LoadByCols( Name => $args{'Name'} );
 461     } elsif ( $args{'EmailAddress'} ) {
 462         $obj->LoadByCols( EmailAddress => $args{'EmailAddress'} );
 463     } else {
 464         die "Name or EmailAddress is required";
 465     }
 466     if ( $obj->id ) {
 467         # cool
 468         $obj->SetPrivileged( $args{'Privileged'} || 0 )
 469             if ($args{'Privileged'}||0) != ($obj->Privileged||0);
 470         $obj->SetDisabled( $args{'Disabled'} || 0 )
 471             if ($args{'Disabled'}||0) != ($obj->Disabled||0);
 472     } else {
 473         my ($val, $msg) = $obj->Create( %args );
 474         die "$msg" unless $val;
 475     }
 476
 477     # clean group membership
 478     {
 479         require RT::GroupMembers;
 480         my $gms = RT::GroupMembers->new( $RT::SystemUser );
 481         my $groups_alias = $gms->Join(
 482             FIELD1 => 'GroupId', TABLE2 => 'Groups', FIELD2 => 'id',
 483         );
 484         $gms->Limit( ALIAS => $groups_alias, FIELD => 'Domain', VALUE => 'UserDefined' );
 485         $gms->Limit( FIELD => 'MemberId', VALUE => $obj->id );
 486         while ( my $group_member_record = $gms->Next ) {
 487             $group_member_record->Delete;
 488         }
 489     }
 490
 491     # add new user to groups
 492     foreach ( @$MemberOf ) {
 493         my $group = RT::Group->new( RT::SystemUser() );
 494         $group->LoadUserDefinedGroup( $_ );
 495         die "couldn't load group '$_'" unless $group->id;
 496         $group->AddMember( $obj->id );
 497     }
 498
 499     return $obj;
 500 }
 501
 502 =head2 load_or_create_queue
 503
 504 =cut
 505
 506 sub load_or_create_queue {
 507     my $self = shift;
 508     my %args = ( Disabled => 0, @_ );
 509     my $obj = RT::Queue->new( $RT::SystemUser );
 510     if ( $args{'Name'} ) {
 511         $obj->LoadByCols( Name => $args{'Name'} );
 512     } else {
 513         die "Name is required";
 514     }
 515     unless ( $obj->id ) {
 516         my ($val, $msg) = $obj->Create( %args );
 517         die "$msg" unless $val;
 518     } else {
 519         my @fields = qw(CorrespondAddress CommentAddress);
 520         foreach my $field ( @fields ) {
 521             next unless exists $args{ $field };
 522             next if $args{ $field } eq $obj->$field;
 523
 524             no warnings 'uninitialized';
 525             my $method = 'Set'. $field;
 526             my ($val, $msg) = $obj->$method( $args{ $field } );
 527             die "$msg" unless $val;
 528         }
 529     }
 530
 531     return $obj;
 532 }
 533
 534 =head2 load_or_create_custom_field
 535
 536 =cut
 537
 538 sub load_or_create_custom_field {
 539     my $self = shift;
 540     my %args = ( Disabled => 0, @_ );
 541     my $obj = RT::CustomField->new( $RT::SystemUser );
 542     if ( $args{'Name'} ) {
 543         $obj->LoadByName( Name => $args{'Name'}, Queue => $args{'Queue'} );
 544     } else {
 545         die "Name is required";
 546     }
 547     unless ( $obj->id ) {
 548         my ($val, $msg) = $obj->Create( %args );
 549         die "$msg" unless $val;
 550     }
 551
 552     return $obj;
 553 }
 554
 555 sub last_ticket {
 556     my $self = shift;
 557     my $current = shift;
 558     $current = $current ? RT::CurrentUser->new($current) : $RT::SystemUser;
 559     my $tickets = RT::Tickets->new( $current );
 560     $tickets->OrderBy( FIELD => 'id', ORDER => 'DESC' );
 561     $tickets->Limit( FIELD => 'id', OPERATOR => '>', VALUE => '0' );
 562     $tickets->RowsPerPage( 1 );
 563     return $tickets->First;
 564 }
 565
 566 sub store_rights {
 567     my $self = shift;
 568
 569     require RT::ACE;
 570     # fake construction
 571     RT::ACE->new( $RT::SystemUser );
 572     my @fields = keys %{ RT::ACE->_ClassAccessible };
 573
 574     require RT::ACL;
 575     my $acl = RT::ACL->new( $RT::SystemUser );
 576     $acl->Limit( FIELD => 'RightName', OPERATOR => '!=', VALUE => 'SuperUser' );
 577
 578     my @res;
 579     while ( my $ace = $acl->Next ) {
 580         my $obj = $ace->PrincipalObj->Object;
 581         if ( $obj->isa('RT::Group') && $obj->Type eq 'UserEquiv' && $obj->Instance == $RT::Nobody->id ) {
 582             next;
 583         }
 584
 585         my %tmp = ();
 586         foreach my $field( @fields ) {
 587             $tmp{ $field } = $ace->__Value( $field );
 588         }
 589         push @res, \%tmp;
 590     }
 591     return @res;
 592 }
 593
 594 sub restore_rights {
 595     my $self = shift;
 596     my @entries = @_;
 597     foreach my $entry ( @entries ) {
 598         my $ace = RT::ACE->new( $RT::SystemUser );
 599         my ($status, $msg) = $ace->RT::Record::Create( %$entry );
 600         unless ( $status ) {
 601             Test::More::diag "couldn't create a record: $msg";
 602         }
 603     }
 604 }
 605
 606 sub set_rights {
 607     my $self = shift;
 608
 609     require RT::ACL;
 610     my $acl = RT::ACL->new( $RT::SystemUser );
 611     $acl->Limit( FIELD => 'RightName', OPERATOR => '!=', VALUE => 'SuperUser' );
 612     while ( my $ace = $acl->Next ) {
 613         my $obj = $ace->PrincipalObj->Object;
 614         if ( $obj->isa('RT::Group') && $obj->Type eq 'UserEquiv' && $obj->Instance == $RT::Nobody->id ) {
 615             next;
 616         }
 617         $ace->Delete;
 618     }
 619     return $self->add_rights( @_ );
 620 }
 621
 622 sub add_rights {
 623     my $self = shift;
 624     my @list = ref $_[0]? @_: @_? { @_ }: ();
 625
 626     require RT::ACL;
 627     foreach my $e (@list) {
 628         my $principal = delete $e->{'Principal'};
 629         unless ( ref $principal ) {
 630             if ( $principal =~ /^(everyone|(?:un)?privileged)$/i ) {
 631                 $principal = RT::Group->new( $RT::SystemUser );
 632                 $principal->LoadSystemInternalGroup($1);
 633             } else {
 634                 die "principal is not an object, but also is not name of a system group";
 635             }
 636         }
 637         unless ( $principal->isa('RT::Principal') ) {
 638             if ( $principal->can('PrincipalObj') ) {
 639                 $principal = $principal->PrincipalObj;
 640             }
 641         }
 642         my @rights = ref $e->{'Right'}? @{ $e->{'Right'} }: ($e->{'Right'});
 643         foreach my $right ( @rights ) {
 644             my ($status, $msg) = $principal->GrantRight( %$e, Right => $right );
 645             $RT::Logger->debug($msg);
 646         }
 647     }
 648     return 1;
 649 }
 650
 651 sub run_mailgate {
 652     my $self = shift;
 653
 654     require RT::Test::Web;
 655     my %args = (
 656         url     => RT::Test::Web->rt_base_url,
 657         message => '',
 658         action  => 'correspond',
 659         queue   => 'General',
 660         debug   => 1,
 661         command => $RT::BinPath .'/rt-mailgate',
 662         @_
 663     );
 664     my $message = delete $args{'message'};
 665
 666     $args{after_open} = sub {
 667         my $child_in = shift;
 668         if ( UNIVERSAL::isa($message, 'MIME::Entity') ) {
 669             $message->print( $child_in );
 670         } else {
 671             print $child_in $message;
 672         }
 673     };
 674
 675     $self->run_and_capture(%args);
 676 }
 677
 678 sub run_and_capture {
 679     my $self = shift;
 680     my %args = @_;
 681
 682     my $cmd = delete $args{'command'};
 683     die "Couldn't find command ($cmd)" unless -f $cmd;
 684
 685     $cmd .= ' --debug' if delete $args{'debug'};
 686
 687     while( my ($k,$v) = each %args ) {
 688         next unless $v;
 689         $cmd .= " --$k '$v'";
 690     }
 691     $cmd .= ' 2>&1';
 692
 693     DBIx::SearchBuilder::Record::Cachable->FlushCache;
 694
 695     require IPC::Open2;
 696     my ($child_out, $child_in);
 697     my $pid = IPC::Open2::open2($child_out, $child_in, $cmd);
 698
 699     $args{after_open}->($child_in, $child_out) if $args{after_open};
 700
 701     close $child_in;
 702
 703     my $result = do { local $/; <$child_out> };
 704     close $child_out;
 705     waitpid $pid, 0;
 706     return ($?, $result);
 707 }
 708
 709 sub send_via_mailgate {
 710     my $self = shift;
 711     my $message = shift;
 712     my %args = (@_);
 713
 714     my ($status, $gate_result) = $self->run_mailgate(
 715         message => $message, %args
 716     );
 717
 718     my $id;
 719     unless ( $status >> 8 ) {
 720         ($id) = ($gate_result =~ /Ticket:\s*(\d+)/i);
 721         unless ( $id ) {
 722             Test::More::diag "Couldn't find ticket id in text:\n$gate_result"
 723                 if $ENV{'TEST_VERBOSE'};
 724         }
 725     } else {
 726         Test::More::diag "Mailgate output:\n$gate_result"
 727             if $ENV{'TEST_VERBOSE'};
 728     }
 729     return ($status, $id);
 730 }
 731
 732 sub open_mailgate_ok {
 733     my $class   = shift;
 734     my $baseurl = shift;
 735     my $queue   = shift || 'general';
 736     my $action  = shift || 'correspond';
 737     Test::More::ok(open(my $mail, "|$RT::BinPath/rt-mailgate --url $baseurl --queue $queue --action $action"), "Opened the mailgate - $!");
 738     return $mail;
 739 }
 740
 741
 742 sub close_mailgate_ok {
 743     my $class = shift;
 744     my $mail  = shift;
 745     close $mail;
 746     Test::More::is ($? >> 8, 0, "The mail gateway exited normally. yay");
 747 }
 748
 749 sub mailsent_ok {
 750     my $class = shift;
 751     my $expected  = shift;
 752
 753     my $mailsent = scalar grep /\S/, split /%% split me! %%\n/,
 754         RT::Test->file_content(
 755             $tmp{'mailbox'},
 756             'unlink' => 0,
 757             noexist => 1
 758         );
 759
 760     Test::More::is(
 761         $mailsent, $expected,
 762         "The number of mail sent ($expected) matches. yay"
 763     );
 764 }
 765
 766 sub set_mail_catcher {
 767     my $self = shift;
 768     return 1;
 769 }
 770
 771 sub fetch_caught_mails {
 772     my $self = shift;
 773     return grep /\S/, split /%% split me! %%\n/,
 774         RT::Test->file_content(
 775             $tmp{'mailbox'},
 776             'unlink' => 1,
 777             noexist => 1
 778         );
 779 }
 780
 781 sub clean_caught_mails {
 782     unlink $tmp{'mailbox'};
 783 }
 784
 785 =head2 get_relocatable_dir
 786
 787 Takes a path relative to the location of the test file that is being
 788 run and returns a path that takes the invocation path into account.
 789
 790 e.g. RT::Test::get_relocatable_dir(File::Spec->updir(), 'data', 'emails')
 791
 792 =cut
 793
 794 sub get_relocatable_dir {
 795     (my $volume, my $directories, my $file) = File::Spec->splitpath($0);
 796     if (File::Spec->file_name_is_absolute($directories)) {
 797         return File::Spec->catdir($directories, @_);
 798     } else {
 799         return File::Spec->catdir(File::Spec->curdir(), $directories, @_);
 800     }
 801 }
 802
 803 =head2 get_relocatable_file
 804
 805 Same as get_relocatable_dir, but takes a file and a path instead
 806 of just a path.
 807
 808 e.g. RT::Test::get_relocatable_file('test-email',
 809         (File::Spec->updir(), 'data', 'emails'))
 810
 811 =cut
 812
 813 sub get_relocatable_file {
 814     my $file = shift;
 815     return File::Spec->catfile(get_relocatable_dir(@_), $file);
 816 }
 817
 818 sub get_abs_relocatable_dir {
 819     (my $volume, my $directories, my $file) = File::Spec->splitpath($0);
 820     if (File::Spec->file_name_is_absolute($directories)) {
 821         return File::Spec->catdir($directories, @_);
 822     } else {
 823         return File::Spec->catdir(Cwd->getcwd(), $directories, @_);
 824     }
 825 }
 826
 827 sub import_gnupg_key {
 828     my $self = shift;
 829     my $key  = shift;
 830     my $type = shift || 'secret';
 831
 832     $key =~ s/\@/-at-/g;
 833     $key .= ".$type.key";
 834
 835     require RT::Crypt::GnuPG;
 836
 837     # simple strategy find data/gnupg/keys, from the dir where test file lives
 838     # to updirs, try 3 times in total
 839     my $path = File::Spec->catfile( 'data', 'gnupg', 'keys' );
 840     my $abs_path;
 841     for my $up ( 0 .. 2 ) {
 842         my $p = get_relocatable_dir($path);
 843         if ( -e $p ) {
 844             $abs_path = $p;
 845             last;
 846         }
 847         else {
 848             $path = File::Spec->catfile( File::Spec->updir(), $path );
 849         }
 850     }
 851
 852     die "can't find the dir where gnupg keys are stored"
 853       unless $abs_path;
 854
 855     return RT::Crypt::GnuPG::ImportKey(
 856         RT::Test->file_content( [ $abs_path, $key ] ) );
 857 }
 858
 859
 860 sub lsign_gnupg_key {
 861     my $self = shift;
 862     my $key = shift;
 863
 864     require RT::Crypt::GnuPG; require GnuPG::Interface;
 865     my $gnupg = new GnuPG::Interface;
 866     my %opt = RT->Config->Get('GnuPGOptions');
 867     $gnupg->options->hash_init(
 868         RT::Crypt::GnuPG::_PrepareGnuPGOptions( %opt ),
 869         meta_interactive => 0,
 870     );
 871
 872     my %handle;
 873     my $handles = GnuPG::Handles->new(
 874         stdin   => ($handle{'input'}   = new IO::Handle),
 875         stdout  => ($handle{'output'}  = new IO::Handle),
 876         stderr  => ($handle{'error'}   = new IO::Handle),
 877         logger  => ($handle{'logger'}  = new IO::Handle),
 878         status  => ($handle{'status'}  = new IO::Handle),
 879         command => ($handle{'command'} = new IO::Handle),
 880     );
 881
 882     eval {
 883         local $SIG{'CHLD'} = 'DEFAULT';
 884         local @ENV{'LANG', 'LC_ALL'} = ('C', 'C');
 885         my $pid = $gnupg->wrap_call(
 886             handles => $handles,
 887             commands => ['--lsign-key'],
 888             command_args => [$key],
 889         );
 890         close $handle{'input'};
 891         while ( my $str = readline $handle{'status'} ) {
 892             if ( $str =~ /^\[GNUPG:\]\s*GET_BOOL sign_uid\..*/ ) {
 893                 print { $handle{'command'} } "y\n";
 894             }
 895         }
 896         waitpid $pid, 0;
 897     };
 898     my $err = $@;
 899     close $handle{'output'};
 900
 901     my %res;
 902     $res{'exit_code'} = $?;
 903     foreach ( qw(error logger status) ) {
 904         $res{$_} = do { local $/; readline $handle{$_} };
 905         delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
 906         close $handle{$_};
 907     }
 908     $RT::Logger->debug( $res{'status'} ) if $res{'status'};
 909     $RT::Logger->warning( $res{'error'} ) if $res{'error'};
 910     $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
 911     if ( $err || $res{'exit_code'} ) {
 912         $res{'message'} = $err? $err : "gpg exitted with error code ". ($res{'exit_code'} >> 8);
 913     }
 914     return %res;
 915 }
 916
 917 sub trust_gnupg_key {
 918     my $self = shift;
 919     my $key = shift;
 920
 921     require RT::Crypt::GnuPG; require GnuPG::Interface;
 922     my $gnupg = new GnuPG::Interface;
 923     my %opt = RT->Config->Get('GnuPGOptions');
 924     $gnupg->options->hash_init(
 925         RT::Crypt::GnuPG::_PrepareGnuPGOptions( %opt ),
 926         meta_interactive => 0,
 927     );
 928
 929     my %handle;
 930     my $handles = GnuPG::Handles->new(
 931         stdin   => ($handle{'input'}   = new IO::Handle),
 932         stdout  => ($handle{'output'}  = new IO::Handle),
 933         stderr  => ($handle{'error'}   = new IO::Handle),
 934         logger  => ($handle{'logger'}  = new IO::Handle),
 935         status  => ($handle{'status'}  = new IO::Handle),
 936         command => ($handle{'command'} = new IO::Handle),
 937     );
 938
 939     eval {
 940         local $SIG{'CHLD'} = 'DEFAULT';
 941         local @ENV{'LANG', 'LC_ALL'} = ('C', 'C');
 942         my $pid = $gnupg->wrap_call(
 943             handles => $handles,
 944             commands => ['--edit-key'],
 945             command_args => [$key],
 946         );
 947         close $handle{'input'};
 948
 949         my $done = 0;
 950         while ( my $str = readline $handle{'status'} ) {
 951             if ( $str =~ /^\[GNUPG:\]\s*\QGET_LINE keyedit.prompt/ ) {
 952                 if ( $done ) {
 953                     print { $handle{'command'} } "quit\n";
 954                 } else {
 955                     print { $handle{'command'} } "trust\n";
 956                 }
 957             } elsif ( $str =~ /^\[GNUPG:\]\s*\QGET_LINE edit_ownertrust.value/ ) {
 958                 print { $handle{'command'} } "5\n";
 959             } elsif ( $str =~ /^\[GNUPG:\]\s*\QGET_BOOL edit_ownertrust.set_ultimate.okay/ ) {
 960                 print { $handle{'command'} } "y\n";
 961                 $done = 1;
 962             }
 963         }
 964         waitpid $pid, 0;
 965     };
 966     my $err = $@;
 967     close $handle{'output'};
 968
 969     my %res;
 970     $res{'exit_code'} = $?;
 971     foreach ( qw(error logger status) ) {
 972         $res{$_} = do { local $/; readline $handle{$_} };
 973         delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
 974         close $handle{$_};
 975     }
 976     $RT::Logger->debug( $res{'status'} ) if $res{'status'};
 977     $RT::Logger->warning( $res{'error'} ) if $res{'error'};
 978     $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
 979     if ( $err || $res{'exit_code'} ) {
 980         $res{'message'} = $err? $err : "gpg exitted with error code ". ($res{'exit_code'} >> 8);
 981     }
 982     return %res;
 983 }
 984
 985 sub started_ok {
 986     my $self = shift;
 987
 988     require RT::Test::Web;
 989
 990     my $which = $ENV{'RT_TEST_WEB_HANDLER'} || 'standalone';
 991     my ($server, $variant) = split /\+/, $which, 2;
 992
 993     my $function = 'start_'. $server .'_server';
 994     unless ( $self->can($function) ) {
 995         die "Don't know how to start server '$server'";
 996     }
 997     return $self->$function( $variant, @_ );
 998 }
 999
1000 sub start_standalone_server {
1001     my $self = shift;
1002
1003
1004     require RT::Interface::Web::Standalone;
1005
1006     require Test::HTTP::Server::Simple::StashWarnings;
1007     unshift @RT::Interface::Web::Standalone::ISA,
1008         'Test::HTTP::Server::Simple::StashWarnings';
1009     *RT::Interface::Web::Standalone::test_warning_path = sub {
1010         "/__test_warnings";
1011     };
1012
1013     my $s = RT::Interface::Web::Standalone->new($port);
1014
1015     my $ret = $s->started_ok;
1016     push @SERVERS, $s->pids;
1017
1018     $RT::Handle = new RT::Handle;
1019     $RT::Handle->dbh( undef );
1020     RT->ConnectToDatabase;
1021
1022     return ($ret, RT::Test::Web->new);
1023 }
1024
1025 sub start_apache_server {
1026     my $self = shift;
1027     my $variant = shift || 'mod_perl';
1028
1029     my %info = $self->apache_server_info( variant => $variant );
1030
1031     Test::More::diag(do {
1032         open my $fh, '<', $tmp{'config'}{'RT'};
1033         local $/;
1034         <$fh>
1035     });
1036
1037     my $log_fn = File::Spec->catfile(
1038         "$tmp{'directory'}", 'apache.log'
1039     );
1040     my $pid_fn = File::Spec->catfile(
1041         "$tmp{'directory'}", "apache.pid"
1042     );
1043     my $tmpl = File::Spec->rel2abs( File::Spec->catfile(
1044         't', 'data', 'configs',
1045         'apache'. $info{'version'} .'+'. $variant .'.conf'
1046     ) );
1047     my %opt = (
1048         listen        => $port,
1049         server_root   => $info{'HTTPD_ROOT'} || $ENV{'HTTPD_ROOT'}
1050             || Test::More::BAIL_OUT("Couldn't figure out server root"),
1051         pid_file      => $pid_fn,
1052         document_root => $RT::MasonComponentRoot,
1053         rt_bin_path   => $RT::BinPath,
1054         log_file      => $log_fn,
1055         rt_site_config => $ENV{'RT_SITE_CONFIG'},
1056     );
1057     {
1058         my $method = 'apache_'.$variant.'_server_options';
1059         $self->$method( \%info, \%opt );
1060     }
1061     $tmp{'config'}{'apache'} = File::Spec->catfile(
1062         "$tmp{'directory'}", "apache.conf"
1063     );
1064     $self->process_in_file(
1065         in      => $tmpl,
1066         out     => $tmp{'config'}{'apache'},
1067         options => \%opt,
1068     );
1069
1070     $self->fork_exec($info{'executable'}, '-f', $tmp{'config'}{'apache'});
1071     my $pid = do {
1072         my $tries = 60;
1073         while ( !-e $pid_fn ) {
1074             $tries--;
1075             last unless $tries;
1076             sleep 1;
1077         }
1078         Test::More::BAIL_OUT("Couldn't start apache server, no pid file")
1079             unless -e $pid_fn;
1080         open my $pid_fh, '<', $pid_fn
1081             or Test::More::BAIL_OUT("Couldn't open pid file: $!");
1082         my $pid = <$pid_fh>;
1083         chomp $pid;
1084         $pid;
1085     };
1086
1087     Test::More::ok($pid, "Started apache server #$pid");
1088
1089     push @SERVERS, $pid;
1090
1091     return (RT->Config->Get('WebURL'), RT::Test::Web->new);
1092 }
1093
1094 sub apache_server_info {
1095     my $self = shift;
1096     my %res = @_;
1097
1098     my $bin = $res{'executable'} = $ENV{'RT_TEST_APACHE'}
1099         || $self->find_apache_server
1100         || Test::More::BAIL_OUT("Couldn't find apache server, use RT_TEST_APACHE");
1101
1102     Test::More::diag("Using '$bin' apache executable for testing")
1103         if $ENV{'TEST_VERBOSE'};
1104
1105     my $info = `$bin -V`;
1106     ($res{'version'}) = ($info =~ m{Server\s+version:\s+Apache/(\d+\.\d+)\.});
1107     Test::More::BAIL_OUT(
1108         "Couldn't figure out version of the server"
1109     ) unless $res{'version'};
1110
1111     my %opts = ($info =~ m/^\s*-D\s+([A-Z_]+?)(?:="(.*)")$/mg);
1112     %res = (%res, %opts);
1113
1114     $res{'modules'} = [
1115         map {s/^\s+//; s/\s+$//; $_}
1116         grep $_ !~ /Compiled in modules/i,
1117         split /\r*\n/, `$bin -l`
1118     ];
1119
1120     return %res;
1121 }
1122
1123 sub apache_mod_perl_server_options {
1124     my $self = shift;
1125     my %info = %{ shift() };
1126     my $current = shift;
1127
1128     my %required_modules = (
1129         '2.2' => [qw(authz_host log_config env alias perl)],
1130     );
1131     my @mlist = @{ $required_modules{ $info{'version'} } };
1132
1133     $current->{'load_modules'} = '';
1134     foreach my $mod ( @mlist ) {
1135         next if grep $_ =~ /^(mod_|)$mod\.c$/, @{ $info{'modules'} };
1136
1137         $current->{'load_modules'} .=
1138             "LoadModule ${mod}_module modules/mod_${mod}.so\n";
1139     }
1140     return;
1141 }
1142
1143 sub apache_fastcgi_server_options {
1144     my $self = shift;
1145     my %info = %{ shift() };
1146     my $current = shift;
1147
1148     my %required_modules = (
1149         '2.2' => [qw(authz_host log_config env alias mime fastcgi)],
1150     );
1151     my @mlist = @{ $required_modules{ $info{'version'} } };
1152
1153     $current->{'load_modules'} = '';
1154     foreach my $mod ( @mlist ) {
1155         next if grep $_ =~ /^(mod_|)$mod\.c$/, @{ $info{'modules'} };
1156
1157         $current->{'load_modules'} .=
1158             "LoadModule ${mod}_module modules/mod_${mod}.so\n";
1159     }
1160     return;
1161 }
1162
1163 sub find_apache_server {
1164     my $self = shift;
1165     return $_ foreach grep defined,
1166         map $self->find_executable($_),
1167         qw(httpd apache apache2 apache1);
1168     return undef;
1169 }
1170
1171 sub stop_server {
1172     my $self = shift;
1173
1174     my $sig = 'TERM';
1175     $sig = 'INT' if !$ENV{'RT_TEST_WEB_HANDLER'}
1176                     || $ENV{'RT_TEST_WEB_HANDLER'} =~/^standalone(?:\+|\z)/;
1177     kill $sig, @SERVERS;
1178     foreach my $pid (@SERVERS) {
1179         waitpid $pid, 0;
1180     }
1181 }
1182
1183 sub file_content {
1184     my $self = shift;
1185     my $path = shift;
1186     my %args = @_;
1187
1188     $path = File::Spec->catfile( @$path ) if ref $path eq 'ARRAY';
1189
1190     Test::More::diag "reading content of '$path'" if $ENV{'TEST_VERBOSE'};
1191
1192     open my $fh, "<:raw", $path
1193         or do {
1194             warn "couldn't open file '$path': $!" unless $args{noexist};
1195             return ''
1196         };
1197     my $content = do { local $/; <$fh> };
1198     close $fh;
1199
1200     unlink $path if $args{'unlink'};
1201
1202     return $content;
1203 }
1204
1205 sub find_executable {
1206     my $self = shift;
1207     my $name = shift;
1208
1209     require File::Spec;
1210     foreach my $dir ( split /:/, $ENV{'PATH'} ) {
1211         my $fpath = File::Spec->catpath(
1212             (File::Spec->splitpath( $dir, 'no file' ))[0..1], $name
1213         );
1214         next unless -e $fpath && -r _ && -x _;
1215         return $fpath;
1216     }
1217     return undef;
1218 }
1219
1220 sub fork_exec {
1221     my $self = shift;
1222
1223     my $pid = fork;
1224     unless ( defined $pid ) {
1225         die "cannot fork: $!";
1226     } elsif ( !$pid ) {
1227         exec @_;
1228         die "can't exec `". join(' ', @_) ."` program: $!";
1229     } else {
1230         return $pid;
1231     }
1232 }
1233
1234 sub process_in_file {
1235     my $self = shift;
1236     my %args = ( in => undef, options => undef, @_ );
1237
1238     my $text = $self->file_content( $args{'in'} );
1239     while ( my ($opt) = ($text =~ /\%\%(.+?)\%\%/) ) {
1240         my $value = $args{'options'}{ lc $opt };
1241         die "no value for $opt" unless defined $value;
1242
1243         $text =~ s/\%\%\Q$opt\E\%\%/$value/g;
1244     }
1245
1246     my ($out_fh, $out_conf);
1247     unless ( $args{'out'} ) {
1248         ($out_fh, $out_conf) = tempfile();
1249     } else {
1250         $out_conf = $args{'out'};
1251         open $out_fh, '>', $out_conf
1252             or die "couldn't open '$out_conf': $!";
1253     }
1254     print $out_fh $text;
1255     seek $out_fh, 0, 0;
1256
1257     return ($out_fh, $out_conf);
1258 }
1259
1260 END {
1261     my $Test = RT::Test->builder;
1262     return if $Test->{Original_Pid} != $$;
1263
1264
1265     # we are in END block and should protect our exit code
1266     # so calls below may call system or kill that clobbers $?
1267     local $?;
1268
1269     RT::Test->stop_server;
1270
1271     # not success
1272     if ( grep !$_, $Test->summary ) {
1273         $tmp{'directory'}->unlink_on_destroy(0);
1274
1275         Test::More::diag(
1276             "Some tests failed, tmp directory"
1277             ." '$tmp{directory}' is not cleaned"
1278         );
1279     }
1280
1281     if ( $ENV{RT_TEST_PARALLEL} && $created_new_db ) {
1282
1283         # Pg doesn't like if you issue a DROP DATABASE while still connected
1284         my $dbh = $RT::Handle->dbh;
1285         $dbh->disconnect if $dbh;
1286
1287         $dbh = _get_dbh( RT::Handle->SystemDSN, $ENV{RT_DBA_USER}, $ENV{RT_DBA_PASSWORD} );
1288         RT::Handle->DropDatabase( $dbh, Force => 1 );
1289         $dbh->disconnect;
1290     }
1291 }
1292
1293 1;