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