rt/lib/RT/Test.pm

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