# BEGIN BPS TAGGED BLOCK {{{ # # COPYRIGHT: # # This software is Copyright (c) 1996-2012 Best Practical Solutions, LLC # # # (Except where explicitly superseded by other copyright notices) # # # LICENSE: # # This work is made available to you under the terms of Version 2 of # the GNU General Public License. A copy of that license should have # been provided with this software, but in any event can be snarfed # from www.gnu.org. # # This work is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA # 02110-1301 or visit their web page on the internet at # http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. # # # CONTRIBUTION SUBMISSION POLICY: # # (The following paragraph is not intended to limit the rights granted # to you to modify and distribute this software under the terms of # the GNU General Public License and is only of importance to you if # you choose to contribute your changes and enhancements to the # community by submitting them to Best Practical Solutions, LLC.) # # By intentionally submitting any modifications, corrections or # derivatives to this work, or any other work intended for use with # Request Tracker, to Best Practical Solutions, LLC, you confirm that # you are the copyright holder for those contributions and you grant # Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, # royalty-free, perpetual, license to use, copy, create derivative # works based on those contributions, and sublicense and distribute # those contributions and any derivatives thereof. # # END BPS TAGGED BLOCK }}} package RT::Test; use strict; use warnings; use base 'Test::More'; use Socket; use File::Temp qw(tempfile); use File::Path qw(mkpath); use File::Spec; our @EXPORT = qw(is_empty diag parse_mail works fails); my %tmp = ( directory => undef, config => { RT => undef, apache => undef, }, mailbox => undef, ); my %rttest_opt; =head1 NAME RT::Test - RT Testing =head1 NOTES =head2 COVERAGE To run the rt test suite with coverage support, install L and run: make test RT_DBA_USER=.. RT_DBA_PASSWORD=.. HARNESS_PERL_SWITCHES=-MDevel::Cover cover -ignore_re '^var/mason_data/' -ignore_re '^t/' The coverage tests have DevelMode turned off, and have C enabled for L to avoid an optimizer problem in Perl that hides the top-level optree from L. =cut our $port; our @SERVERS; sub import { my $class = shift; my %args = %rttest_opt = @_; # Spit out a plan (if we got one) *before* we load modules if ( $args{'tests'} ) { $class->builder->plan( tests => $args{'tests'} ) unless $args{'tests'} eq 'no_declare'; } elsif ( exists $args{'tests'} ) { # do nothing if they say "tests => undef" - let them make the plan } elsif ( $args{'skip_all'} ) { $class->builder->plan(skip_all => $args{'skip_all'}); } else { $class->builder->no_plan unless $class->builder->has_plan; } push @{ $args{'plugins'} ||= [] }, @{ $args{'requires'} } if $args{'requires'}; push @{ $args{'plugins'} ||= [] }, $args{'testing'} if $args{'testing'}; $class->bootstrap_tempdir; $class->bootstrap_port; $class->bootstrap_plugins_paths( %args ); $class->bootstrap_config( %args ); use RT; RT::LoadConfig; if (RT->Config->Get('DevelMode')) { require Module::Refresh; } $class->bootstrap_db( %args ); RT::InitPluginPaths(); __reconnect_rt() unless $args{nodb}; RT::InitClasses(); RT::InitLogging(); RT->Plugins; RT::I18N->Init(); RT->Config->PostLoadCheck; $class->set_config_wrapper; my $screen_logger = $RT::Logger->remove( 'screen' ); require Log::Dispatch::Perl; $RT::Logger->add( Log::Dispatch::Perl->new ( name => 'rttest', min_level => $screen_logger->min_level, action => { error => 'warn', critical => 'warn' } ) ); # XXX: this should really be totally isolated environment so we # can parallelize and be sane mkpath [ $RT::MasonSessionDir ] if RT->Config->Get('DatabaseType'); my $level = 1; while ( my ($package) = caller($level-1) ) { last unless $package =~ /Test/; $level++; } Test::More->export_to_level($level); # blow away their diag so we can redefine it without warning # better than "no warnings 'redefine'" because we might accidentally # suppress a mistaken redefinition no strict 'refs'; delete ${ caller($level) . '::' }{diag}; __PACKAGE__->export_to_level($level); } sub is_empty($;$) { my ($v, $d) = shift; local $Test::Builder::Level = $Test::Builder::Level + 1; return Test::More::ok(1, $d) unless defined $v; return Test::More::ok(1, $d) unless length $v; return Test::More::is($v, '', $d); } my $created_new_db; # have we created new db? mainly for parallel testing sub db_requires_no_dba { my $self = shift; my $db_type = RT->Config->Get('DatabaseType'); return 1 if $db_type eq 'SQLite'; } sub bootstrap_port { my $class = shift; my %ports; # Determine which ports are in use use Fcntl qw(:DEFAULT :flock); my $portfile = "$tmp{'directory'}/../ports"; sysopen(PORTS, $portfile, O_RDWR|O_CREAT) or die "Can't write to ports file $portfile: $!"; flock(PORTS, LOCK_EX) or die "Can't write-lock ports file $portfile: $!"; $ports{$_}++ for split ' ', join("",); # Pick a random port, checking that the port isn't in our in-use # list, and that something isn't already listening there. { $port = 1024 + int rand(10_000) + $$ % 1024; redo if $ports{$port}; # There is a race condition in here, where some non-RT::Test # process claims the port after we check here but before our # server binds. However, since we mostly care about race # conditions with ourselves under high concurrency, this is # generally good enough. my $paddr = sockaddr_in( $port, inet_aton('localhost') ); socket( SOCK, PF_INET, SOCK_STREAM, getprotobyname('tcp') ) or die "socket: $!"; if ( connect( SOCK, $paddr ) ) { close(SOCK); redo; } close(SOCK); } $ports{$port}++; # Write back out the in-use ports seek(PORTS, 0, 0); truncate(PORTS, 0); print PORTS "$_\n" for sort {$a <=> $b} keys %ports; close(PORTS) or die "Can't close ports file: $!"; } sub bootstrap_tempdir { my $self = shift; my ($test_dir, $test_file) = ('t', ''); if (File::Spec->rel2abs($0) =~ m{(?:^|[\\/])(x?t)[/\\](.*)}) { $test_dir = $1; $test_file = "$2-"; $test_file =~ s{[/\\]}{-}g; } my $dir_name = File::Spec->rel2abs("$test_dir/tmp"); mkpath( $dir_name ); return $tmp{'directory'} = File::Temp->newdir( "${test_file}XXXXXXXX", DIR => $dir_name ); } sub bootstrap_config { my $self = shift; my %args = @_; $tmp{'config'}{'RT'} = File::Spec->catfile( "$tmp{'directory'}", 'RT_SiteConfig.pm' ); open( my $config, '>', $tmp{'config'}{'RT'} ) or die "Couldn't open $tmp{'config'}{'RT'}: $!"; my $dbname = $ENV{RT_TEST_PARALLEL}? "rt4test_$port" : "rt4test"; print $config qq{ Set( \$WebDomain, "localhost"); Set( \$WebPort, $port); Set( \$WebPath, ""); Set( \@LexiconLanguages, qw(en zh_TW fr ja)); Set( \$RTAddressRegexp , qr/^bad_re_that_doesnt_match\$/i); }; if ( $ENV{'RT_TEST_DB_SID'} ) { # oracle case print $config "Set( \$DatabaseName , '$ENV{'RT_TEST_DB_SID'}' );\n"; print $config "Set( \$DatabaseUser , '$dbname');\n"; } else { print $config "Set( \$DatabaseName , '$dbname');\n"; print $config "Set( \$DatabaseUser , 'u${dbname}');\n"; } if ( $args{'plugins'} ) { print $config "Set( \@Plugins, qw(". join( ' ', @{ $args{'plugins'} } ) .") );\n"; } if ( $INC{'Devel/Cover.pm'} ) { print $config "Set( \$DevelMode, 0 );\n"; } elsif ( $ENV{RT_TEST_DEVEL} ) { print $config "Set( \$DevelMode, 1 );\n"; } else { print $config "Set( \$DevelMode, 0 );\n"; } $self->bootstrap_logging( $config ); # set mail catcher my $mail_catcher = $tmp{'mailbox'} = File::Spec->catfile( $tmp{'directory'}->dirname, 'mailbox.eml' ); print $config <>', '$mail_catcher' ) or die "Unable to open '$mail_catcher' for appending: \$!"; \$MIME->print(\$handle); print \$handle "%% split me! %%\n"; close \$handle; } ); END $self->bootstrap_more_config($config, \%args); print $config $args{'config'} if $args{'config'}; print $config "\n1;\n"; $ENV{'RT_SITE_CONFIG'} = $tmp{'config'}{'RT'}; close $config; return $config; } sub bootstrap_more_config { } sub bootstrap_logging { my $self = shift; my $config = shift; # prepare file for logging $tmp{'log'}{'RT'} = File::Spec->catfile( "$tmp{'directory'}", 'rt.debug.log' ); open( my $fh, '>', $tmp{'log'}{'RT'} ) or die "Couldn't open $tmp{'config'}{'RT'}: $!"; # make world writable so apache under different user # can write into it chmod 0666, $tmp{'log'}{'RT'}; print $config <{'Type'} || 'SCALAR'; my %sigils = ( HASH => '%', ARRAY => '@', SCALAR => '$', ); my $sigil = $sigils{$type} || $sigils{'SCALAR'}; open( my $fh, '>>', $tmp{'config'}{'RT'} ) or die "Couldn't open config file: $!"; require Data::Dumper; local $Data::Dumper::Terse = 1; my $dump = Data::Dumper::Dumper([@_[2 .. $#_]]); $dump =~ s/;\s+$//; print $fh "\nSet(${sigil}${name}, \@{". $dump ."});\n1;\n"; close $fh; if ( @SERVERS ) { warn "you're changing config option in a test file" ." when server is active"; } } return $old_sub->(@_); }; } sub bootstrap_db { my $self = shift; my %args = @_; unless (defined $ENV{'RT_DBA_USER'} && defined $ENV{'RT_DBA_PASSWORD'}) { Test::More::BAIL_OUT( "RT_DBA_USER and RT_DBA_PASSWORD environment variables need" ." to be set in order to run 'make test'" ) unless $self->db_requires_no_dba; } require RT::Handle; if (my $forceopt = $ENV{RT_TEST_FORCE_OPT}) { Test::More::diag "forcing $forceopt"; $args{$forceopt}=1; } # Short-circuit the rest of ourselves if we don't want a db if ($args{nodb}) { __drop_database(); return; } my $db_type = RT->Config->Get('DatabaseType'); __create_database(); __reconnect_rt('as dba'); $RT::Handle->InsertSchema; $RT::Handle->InsertACL unless $db_type eq 'Oracle'; RT->InitLogging; __reconnect_rt(); $RT::Handle->InsertInitialData unless $args{noinitialdata}; $RT::Handle->InsertData( $RT::EtcPath . "/initialdata" ) unless $args{noinitialdata} or $args{nodata}; $self->bootstrap_plugins_db( %args ); } sub bootstrap_plugins_paths { my $self = shift; my %args = @_; return unless $args{'plugins'}; my @plugins = @{ $args{'plugins'} }; my $cwd; if ( $args{'testing'} ) { require Cwd; $cwd = Cwd::getcwd(); } require RT::Plugin; my $old_func = \&RT::Plugin::_BasePath; no warnings 'redefine'; *RT::Plugin::_BasePath = sub { my $name = $_[0]->{'name'}; return $cwd if $args{'testing'} && $name eq $args{'testing'}; if ( grep $name eq $_, @plugins ) { my $variants = join "(?:|::|-|_)", map "\Q$_\E", split /::/, $name; my ($path) = map $ENV{$_}, grep /^CHIMPS_(?:$variants).*_ROOT$/i, keys %ENV; return $path if $path; } return $old_func->(@_); }; } sub bootstrap_plugins_db { my $self = shift; my %args = @_; return unless $args{'plugins'}; require File::Spec; my @plugins = @{ $args{'plugins'} }; foreach my $name ( @plugins ) { my $plugin = RT::Plugin->new( name => $name ); Test::More::diag( "Initializing DB for the $name plugin" ) if $ENV{'TEST_VERBOSE'}; my $etc_path = $plugin->Path('etc'); Test::More::diag( "etc path of the plugin is '$etc_path'" ) if $ENV{'TEST_VERBOSE'}; unless ( -e $etc_path ) { # We can't tell if the plugin has no data, or we screwed up the etc/ path Test::More::ok(1, "There is no etc dir: no schema" ); Test::More::ok(1, "There is no etc dir: no ACLs" ); Test::More::ok(1, "There is no etc dir: no data" ); next; } __reconnect_rt('as dba'); { # schema my ($ret, $msg) = $RT::Handle->InsertSchema( undef, $etc_path ); Test::More::ok($ret || $msg =~ /^Couldn't find schema/, "Created schema: ".($msg||'')); } { # ACLs my ($ret, $msg) = $RT::Handle->InsertACL( undef, $etc_path ); Test::More::ok($ret || $msg =~ /^Couldn't find ACLs/, "Created ACL: ".($msg||'')); } # data my $data_file = File::Spec->catfile( $etc_path, 'initialdata' ); if ( -e $data_file ) { __reconnect_rt(); my ($ret, $msg) = $RT::Handle->InsertData( $data_file );; Test::More::ok($ret, "Inserted data".($msg||'')); } else { Test::More::ok(1, "There is no data file" ); } } __reconnect_rt(); } sub _get_dbh { my ($dsn, $user, $pass) = @_; if ( $dsn =~ /Oracle/i ) { $ENV{'NLS_LANG'} = "AMERICAN_AMERICA.AL32UTF8"; $ENV{'NLS_NCHAR'} = "AL32UTF8"; } my $dbh = DBI->connect( $dsn, $user, $pass, { RaiseError => 0, PrintError => 1 }, ); unless ( $dbh ) { my $msg = "Failed to connect to $dsn as user '$user': ". $DBI::errstr; print STDERR $msg; exit -1; } return $dbh; } sub __create_database { # bootstrap with dba cred my $dbh = _get_dbh( RT::Handle->SystemDSN, $ENV{RT_DBA_USER}, $ENV{RT_DBA_PASSWORD} ); unless ( $ENV{RT_TEST_PARALLEL} ) { # already dropped db in parallel tests, need to do so for other cases. __drop_database( $dbh ); } RT::Handle->CreateDatabase( $dbh ); $dbh->disconnect; $created_new_db++; } sub __drop_database { my $dbh = shift; # Pg doesn't like if you issue a DROP DATABASE while still connected # it's still may fail if web-server is out there and holding a connection __disconnect_rt(); my $my_dbh = $dbh? 0 : 1; $dbh ||= _get_dbh( RT::Handle->SystemDSN, $ENV{RT_DBA_USER}, $ENV{RT_DBA_PASSWORD} ); # We ignore errors intentionally by not checking the return value of # DropDatabase below, so let's also suppress DBI's printing of errors when # we overzealously drop. local $dbh->{PrintError} = 0; local $dbh->{PrintWarn} = 0; RT::Handle->DropDatabase( $dbh ); $dbh->disconnect if $my_dbh; } sub __reconnect_rt { my $as_dba = shift; __disconnect_rt(); # look at %DBIHandle and $PrevHandle in DBIx::SB::Handle for explanation $RT::Handle = RT::Handle->new; $RT::Handle->dbh( undef ); $RT::Handle->Connect( $as_dba ? (User => $ENV{RT_DBA_USER}, Password => $ENV{RT_DBA_PASSWORD}) : () ); $RT::Handle->PrintError; $RT::Handle->dbh->{PrintError} = 1; return $RT::Handle->dbh; } sub __disconnect_rt { # look at %DBIHandle and $PrevHandle in DBIx::SB::Handle for explanation $RT::Handle->dbh->disconnect if $RT::Handle and $RT::Handle->dbh; %DBIx::SearchBuilder::Handle::DBIHandle = (); $DBIx::SearchBuilder::Handle::PrevHandle = undef; $RT::Handle = undef; delete $RT::System->{attributes}; DBIx::SearchBuilder::Record::Cachable->FlushCache if DBIx::SearchBuilder::Record::Cachable->can("FlushCache"); } =head1 UTILITIES =head2 load_or_create_user =cut sub load_or_create_user { my $self = shift; my %args = ( Privileged => 1, Disabled => 0, @_ ); my $MemberOf = delete $args{'MemberOf'}; $MemberOf = [ $MemberOf ] if defined $MemberOf && !ref $MemberOf; $MemberOf ||= []; my $obj = RT::User->new( RT->SystemUser ); if ( $args{'Name'} ) { $obj->LoadByCols( Name => $args{'Name'} ); } elsif ( $args{'EmailAddress'} ) { $obj->LoadByCols( EmailAddress => $args{'EmailAddress'} ); } else { die "Name or EmailAddress is required"; } if ( $obj->id ) { # cool $obj->SetPrivileged( $args{'Privileged'} || 0 ) if ($args{'Privileged'}||0) != ($obj->Privileged||0); $obj->SetDisabled( $args{'Disabled'} || 0 ) if ($args{'Disabled'}||0) != ($obj->Disabled||0); } else { my ($val, $msg) = $obj->Create( %args ); die "$msg" unless $val; } # clean group membership { require RT::GroupMembers; my $gms = RT::GroupMembers->new( RT->SystemUser ); my $groups_alias = $gms->Join( FIELD1 => 'GroupId', TABLE2 => 'Groups', FIELD2 => 'id', ); $gms->Limit( ALIAS => $groups_alias, FIELD => 'Domain', VALUE => 'UserDefined' ); $gms->Limit( FIELD => 'MemberId', VALUE => $obj->id ); while ( my $group_member_record = $gms->Next ) { $group_member_record->Delete; } } # add new user to groups foreach ( @$MemberOf ) { my $group = RT::Group->new( RT::SystemUser() ); $group->LoadUserDefinedGroup( $_ ); die "couldn't load group '$_'" unless $group->id; $group->AddMember( $obj->id ); } return $obj; } =head2 load_or_create_queue =cut sub load_or_create_queue { my $self = shift; my %args = ( Disabled => 0, @_ ); my $obj = RT::Queue->new( RT->SystemUser ); if ( $args{'Name'} ) { $obj->LoadByCols( Name => $args{'Name'} ); } else { die "Name is required"; } unless ( $obj->id ) { my ($val, $msg) = $obj->Create( %args ); die "$msg" unless $val; } else { my @fields = qw(CorrespondAddress CommentAddress); foreach my $field ( @fields ) { next unless exists $args{ $field }; next if $args{ $field } eq ($obj->$field || ''); no warnings 'uninitialized'; my $method = 'Set'. $field; my ($val, $msg) = $obj->$method( $args{ $field } ); die "$msg" unless $val; } } return $obj; } sub delete_queue_watchers { my $self = shift; my @queues = @_; foreach my $q ( @queues ) { foreach my $t (qw(Cc AdminCc) ) { $q->DeleteWatcher( Type => $t, PrincipalId => $_->MemberId ) foreach @{ $q->$t()->MembersObj->ItemsArrayRef }; } } } sub create_tickets { local $Test::Builder::Level = $Test::Builder::Level + 1; my $self = shift; my $defaults = shift; my @data = @_; @data = sort { rand(100) <=> rand(100) } @data if delete $defaults->{'RandomOrder'}; $defaults->{'Queue'} ||= 'General'; my @res = (); while ( @data ) { my %args = %{ shift @data }; $args{$_} = $res[ $args{$_} ]->id foreach grep $args{ $_ }, keys %RT::Ticket::LINKTYPEMAP; push @res, $self->create_ticket( %$defaults, %args ); } return @res; } sub create_ticket { local $Test::Builder::Level = $Test::Builder::Level + 1; my $self = shift; my %args = @_; if ($args{Queue} && $args{Queue} =~ /\D/) { my $queue = RT::Queue->new(RT->SystemUser); if (my $id = $queue->Load($args{Queue}) ) { $args{Queue} = $id; } else { die ("Error: Invalid queue $args{Queue}"); } } if ( my $content = delete $args{'Content'} ) { $args{'MIMEObj'} = MIME::Entity->build( From => $args{'Requestor'}, Subject => $args{'Subject'}, Data => $content, ); } my $ticket = RT::Ticket->new( RT->SystemUser ); my ( $id, undef, $msg ) = $ticket->Create( %args ); Test::More::ok( $id, "ticket created" ) or Test::More::diag("error: $msg"); # hackish, but simpler if ( $args{'LastUpdatedBy'} ) { $ticket->__Set( Field => 'LastUpdatedBy', Value => $args{'LastUpdatedBy'} ); } for my $field ( keys %args ) { #TODO check links and watchers if ( $field =~ /CustomField-(\d+)/ ) { my $cf = $1; my $got = join ',', sort map $_->Content, @{ $ticket->CustomFieldValues($cf)->ItemsArrayRef }; my $expected = ref $args{$field} ? join( ',', sort @{ $args{$field} } ) : $args{$field}; Test::More::is( $got, $expected, 'correct CF values' ); } else { next if ref $args{$field}; next unless $ticket->can($field) or $ticket->_Accessible($field,"read"); next if ref $ticket->$field(); Test::More::is( $ticket->$field(), $args{$field}, "$field is correct" ); } } return $ticket; } sub delete_tickets { my $self = shift; my $query = shift; my $tickets = RT::Tickets->new( RT->SystemUser ); if ( $query ) { $tickets->FromSQL( $query ); } else { $tickets->UnLimit; } while ( my $ticket = $tickets->Next ) { $ticket->Delete; } } =head2 load_or_create_custom_field =cut sub load_or_create_custom_field { my $self = shift; my %args = ( Disabled => 0, @_ ); my $obj = RT::CustomField->new( RT->SystemUser ); if ( $args{'Name'} ) { $obj->LoadByName( Name => $args{'Name'}, Queue => $args{'Queue'} ); } else { die "Name is required"; } unless ( $obj->id ) { my ($val, $msg) = $obj->Create( %args ); die "$msg" unless $val; } return $obj; } sub last_ticket { my $self = shift; my $current = shift; $current = $current ? RT::CurrentUser->new($current) : RT->SystemUser; my $tickets = RT::Tickets->new( $current ); $tickets->OrderBy( FIELD => 'id', ORDER => 'DESC' ); $tickets->Limit( FIELD => 'id', OPERATOR => '>', VALUE => '0' ); $tickets->RowsPerPage( 1 ); return $tickets->First; } sub store_rights { my $self = shift; require RT::ACE; # fake construction RT::ACE->new( RT->SystemUser ); my @fields = keys %{ RT::ACE->_ClassAccessible }; require RT::ACL; my $acl = RT::ACL->new( RT->SystemUser ); $acl->Limit( FIELD => 'RightName', OPERATOR => '!=', VALUE => 'SuperUser' ); my @res; while ( my $ace = $acl->Next ) { my $obj = $ace->PrincipalObj->Object; if ( $obj->isa('RT::Group') && $obj->Type eq 'UserEquiv' && $obj->Instance == RT->Nobody->id ) { next; } my %tmp = (); foreach my $field( @fields ) { $tmp{ $field } = $ace->__Value( $field ); } push @res, \%tmp; } return @res; } sub restore_rights { my $self = shift; my @entries = @_; foreach my $entry ( @entries ) { my $ace = RT::ACE->new( RT->SystemUser ); my ($status, $msg) = $ace->RT::Record::Create( %$entry ); unless ( $status ) { Test::More::diag "couldn't create a record: $msg"; } } } sub set_rights { my $self = shift; require RT::ACL; my $acl = RT::ACL->new( RT->SystemUser ); $acl->Limit( FIELD => 'RightName', OPERATOR => '!=', VALUE => 'SuperUser' ); while ( my $ace = $acl->Next ) { my $obj = $ace->PrincipalObj->Object; if ( $obj->isa('RT::Group') && $obj->Type eq 'UserEquiv' && $obj->Instance == RT->Nobody->id ) { next; } $ace->Delete; } return $self->add_rights( @_ ); } sub add_rights { my $self = shift; my @list = ref $_[0]? @_: @_? { @_ }: (); require RT::ACL; foreach my $e (@list) { my $principal = delete $e->{'Principal'}; unless ( ref $principal ) { if ( $principal =~ /^(everyone|(?:un)?privileged)$/i ) { $principal = RT::Group->new( RT->SystemUser ); $principal->LoadSystemInternalGroup($1); } elsif ( $principal =~ /^(Owner|Requestor|(?:Admin)?Cc)$/i ) { $principal = RT::Group->new( RT->SystemUser ); $principal->LoadByCols( Domain => (ref($e->{'Object'})||'RT::System').'-Role', Type => $1, ref($e->{'Object'})? (Instance => $e->{'Object'}->id): (), ); } else { die "principal is not an object, but also is not name of a system group"; } } unless ( $principal->isa('RT::Principal') ) { if ( $principal->can('PrincipalObj') ) { $principal = $principal->PrincipalObj; } } my @rights = ref $e->{'Right'}? @{ $e->{'Right'} }: ($e->{'Right'}); foreach my $right ( @rights ) { my ($status, $msg) = $principal->GrantRight( %$e, Right => $right ); $RT::Logger->debug($msg); } } return 1; } sub run_mailgate { my $self = shift; require RT::Test::Web; my %args = ( url => RT::Test::Web->rt_base_url, message => '', action => 'correspond', queue => 'General', debug => 1, command => $RT::BinPath .'/rt-mailgate', @_ ); my $message = delete $args{'message'}; $args{after_open} = sub { my $child_in = shift; if ( UNIVERSAL::isa($message, 'MIME::Entity') ) { $message->print( $child_in ); } else { print $child_in $message; } }; $self->run_and_capture(%args); } sub run_and_capture { my $self = shift; my %args = @_; my $after_open = delete $args{after_open}; my $cmd = delete $args{'command'}; die "Couldn't find command ($cmd)" unless -f $cmd; $cmd .= ' --debug' if delete $args{'debug'}; while( my ($k,$v) = each %args ) { next unless $v; $cmd .= " --$k '$v'"; } $cmd .= ' 2>&1'; DBIx::SearchBuilder::Record::Cachable->FlushCache; require IPC::Open2; my ($child_out, $child_in); my $pid = IPC::Open2::open2($child_out, $child_in, $cmd); $after_open->($child_in, $child_out) if $after_open; close $child_in; my $result = do { local $/; <$child_out> }; close $child_out; waitpid $pid, 0; return ($?, $result); } sub send_via_mailgate_and_http { my $self = shift; my $message = shift; my %args = (@_); my ($status, $gate_result) = $self->run_mailgate( message => $message, %args ); my $id; unless ( $status >> 8 ) { ($id) = ($gate_result =~ /Ticket:\s*(\d+)/i); unless ( $id ) { Test::More::diag "Couldn't find ticket id in text:\n$gate_result" if $ENV{'TEST_VERBOSE'}; } } else { Test::More::diag "Mailgate output:\n$gate_result" if $ENV{'TEST_VERBOSE'}; } return ($status, $id); } sub send_via_mailgate { my $self = shift; my $message = shift; my %args = ( action => 'correspond', queue => 'General', @_ ); if ( UNIVERSAL::isa( $message, 'MIME::Entity' ) ) { $message = $message->as_string; } my ( $status, $error_message, $ticket ) = RT::Interface::Email::Gateway( {%args, message => $message} ); return ( $status, $ticket ? $ticket->id : 0 ); } sub open_mailgate_ok { my $class = shift; my $baseurl = shift; my $queue = shift || 'general'; my $action = shift || 'correspond'; Test::More::ok(open(my $mail, '|-', "$RT::BinPath/rt-mailgate --url $baseurl --queue $queue --action $action"), "Opened the mailgate - $!"); return $mail; } sub close_mailgate_ok { my $class = shift; my $mail = shift; close $mail; Test::More::is ($? >> 8, 0, "The mail gateway exited normally. yay"); } sub mailsent_ok { my $class = shift; my $expected = shift; my $mailsent = scalar grep /\S/, split /%% split me! %%\n/, RT::Test->file_content( $tmp{'mailbox'}, 'unlink' => 0, noexist => 1 ); Test::More::is( $mailsent, $expected, "The number of mail sent ($expected) matches. yay" ); } sub fetch_caught_mails { my $self = shift; return grep /\S/, split /%% split me! %%\n/, RT::Test->file_content( $tmp{'mailbox'}, 'unlink' => 1, noexist => 1 ); } sub clean_caught_mails { unlink $tmp{'mailbox'}; } =head2 get_relocatable_dir Takes a path relative to the location of the test file that is being run and returns a path that takes the invocation path into account. e.g. RT::Test::get_relocatable_dir(File::Spec->updir(), 'data', 'emails') =cut sub get_relocatable_dir { (my $volume, my $directories, my $file) = File::Spec->splitpath($0); if (File::Spec->file_name_is_absolute($directories)) { return File::Spec->catdir($directories, @_); } else { return File::Spec->catdir(File::Spec->curdir(), $directories, @_); } } =head2 get_relocatable_file Same as get_relocatable_dir, but takes a file and a path instead of just a path. e.g. RT::Test::get_relocatable_file('test-email', (File::Spec->updir(), 'data', 'emails')) =cut sub get_relocatable_file { my $file = shift; return File::Spec->catfile(get_relocatable_dir(@_), $file); } sub get_abs_relocatable_dir { (my $volume, my $directories, my $file) = File::Spec->splitpath($0); if (File::Spec->file_name_is_absolute($directories)) { return File::Spec->catdir($directories, @_); } else { return File::Spec->catdir(Cwd->getcwd(), $directories, @_); } } sub gnupg_homedir { my $self = shift; File::Temp->newdir( DIR => $tmp{directory}, CLEANUP => 0, ); } sub import_gnupg_key { my $self = shift; my $key = shift; my $type = shift || 'secret'; $key =~ s/\@/-at-/g; $key .= ".$type.key"; require RT::Crypt::GnuPG; # simple strategy find data/gnupg/keys, from the dir where test file lives # to updirs, try 3 times in total my $path = File::Spec->catfile( 'data', 'gnupg', 'keys' ); my $abs_path; for my $up ( 0 .. 2 ) { my $p = get_relocatable_dir($path); if ( -e $p ) { $abs_path = $p; last; } else { $path = File::Spec->catfile( File::Spec->updir(), $path ); } } die "can't find the dir where gnupg keys are stored" unless $abs_path; return RT::Crypt::GnuPG::ImportKey( RT::Test->file_content( [ $abs_path, $key ] ) ); } sub lsign_gnupg_key { my $self = shift; my $key = shift; require RT::Crypt::GnuPG; require GnuPG::Interface; my $gnupg = GnuPG::Interface->new(); my %opt = RT->Config->Get('GnuPGOptions'); $gnupg->options->hash_init( RT::Crypt::GnuPG::_PrepareGnuPGOptions( %opt ), meta_interactive => 0, ); my %handle; my $handles = GnuPG::Handles->new( stdin => ($handle{'input'} = IO::Handle->new()), stdout => ($handle{'output'} = IO::Handle->new()), stderr => ($handle{'error'} = IO::Handle->new()), logger => ($handle{'logger'} = IO::Handle->new()), status => ($handle{'status'} = IO::Handle->new()), command => ($handle{'command'} = IO::Handle->new()), ); eval { local $SIG{'CHLD'} = 'DEFAULT'; local @ENV{'LANG', 'LC_ALL'} = ('C', 'C'); my $pid = $gnupg->wrap_call( handles => $handles, commands => ['--lsign-key'], command_args => [$key], ); close $handle{'input'}; while ( my $str = readline $handle{'status'} ) { if ( $str =~ /^\[GNUPG:\]\s*GET_BOOL sign_uid\..*/ ) { print { $handle{'command'} } "y\n"; } } waitpid $pid, 0; }; my $err = $@; close $handle{'output'}; my %res; $res{'exit_code'} = $?; foreach ( qw(error logger status) ) { $res{$_} = do { local $/; readline $handle{$_} }; delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s; close $handle{$_}; } $RT::Logger->debug( $res{'status'} ) if $res{'status'}; $RT::Logger->warning( $res{'error'} ) if $res{'error'}; $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?; if ( $err || $res{'exit_code'} ) { $res{'message'} = $err? $err : "gpg exitted with error code ". ($res{'exit_code'} >> 8); } return %res; } sub trust_gnupg_key { my $self = shift; my $key = shift; require RT::Crypt::GnuPG; require GnuPG::Interface; my $gnupg = GnuPG::Interface->new(); my %opt = RT->Config->Get('GnuPGOptions'); $gnupg->options->hash_init( RT::Crypt::GnuPG::_PrepareGnuPGOptions( %opt ), meta_interactive => 0, ); my %handle; my $handles = GnuPG::Handles->new( stdin => ($handle{'input'} = IO::Handle->new()), stdout => ($handle{'output'} = IO::Handle->new()), stderr => ($handle{'error'} = IO::Handle->new()), logger => ($handle{'logger'} = IO::Handle->new()), status => ($handle{'status'} = IO::Handle->new()), command => ($handle{'command'} = IO::Handle->new()), ); eval { local $SIG{'CHLD'} = 'DEFAULT'; local @ENV{'LANG', 'LC_ALL'} = ('C', 'C'); my $pid = $gnupg->wrap_call( handles => $handles, commands => ['--edit-key'], command_args => [$key], ); close $handle{'input'}; my $done = 0; while ( my $str = readline $handle{'status'} ) { if ( $str =~ /^\[GNUPG:\]\s*\QGET_LINE keyedit.prompt/ ) { if ( $done ) { print { $handle{'command'} } "quit\n"; } else { print { $handle{'command'} } "trust\n"; } } elsif ( $str =~ /^\[GNUPG:\]\s*\QGET_LINE edit_ownertrust.value/ ) { print { $handle{'command'} } "5\n"; } elsif ( $str =~ /^\[GNUPG:\]\s*\QGET_BOOL edit_ownertrust.set_ultimate.okay/ ) { print { $handle{'command'} } "y\n"; $done = 1; } } waitpid $pid, 0; }; my $err = $@; close $handle{'output'}; my %res; $res{'exit_code'} = $?; foreach ( qw(error logger status) ) { $res{$_} = do { local $/; readline $handle{$_} }; delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s; close $handle{$_}; } $RT::Logger->debug( $res{'status'} ) if $res{'status'}; $RT::Logger->warning( $res{'error'} ) if $res{'error'}; $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?; if ( $err || $res{'exit_code'} ) { $res{'message'} = $err? $err : "gpg exitted with error code ". ($res{'exit_code'} >> 8); } return %res; } sub started_ok { my $self = shift; require RT::Test::Web; if ($rttest_opt{nodb} and not $rttest_opt{server_ok}) { die "You are trying to use a test web server without a database. " ."You may want noinitialdata => 1 instead. " ."Pass server_ok => 1 if you know what you're doing."; } $ENV{'RT_TEST_WEB_HANDLER'} = undef if $rttest_opt{actual_server} && ($ENV{'RT_TEST_WEB_HANDLER'}||'') eq 'inline'; $ENV{'RT_TEST_WEB_HANDLER'} ||= 'plack'; my $which = $ENV{'RT_TEST_WEB_HANDLER'}; my ($server, $variant) = split /\+/, $which, 2; my $function = 'start_'. $server .'_server'; unless ( $self->can($function) ) { die "Don't know how to start server '$server'"; } return $self->$function( variant => $variant, @_ ); } sub test_app { my $self = shift; my %server_opt = @_; my $app; my $warnings = ""; open( my $warn_fh, ">", \$warnings ); local *STDERR = $warn_fh; if ($server_opt{variant} and $server_opt{variant} eq 'rt-server') { $app = do { my $file = "$RT::SbinPath/rt-server"; my $psgi = do $file; unless ($psgi) { die "Couldn't parse $file: $@" if $@; die "Couldn't do $file: $!" unless defined $psgi; die "Couldn't run $file" unless $psgi; } $psgi; }; } else { require RT::Interface::Web::Handler; $app = RT::Interface::Web::Handler->PSGIApp; } require Plack::Middleware::Test::StashWarnings; my $stashwarnings = Plack::Middleware::Test::StashWarnings->new; $app = $stashwarnings->wrap($app); if ($server_opt{basic_auth}) { require Plack::Middleware::Auth::Basic; $app = Plack::Middleware::Auth::Basic->wrap( $app, authenticator => sub { my ($username, $password) = @_; return $username eq 'root' && $password eq 'password'; } ); } close $warn_fh; $stashwarnings->add_warning( $warnings ) if $warnings; return $app; } sub start_plack_server { my $self = shift; require Plack::Loader; my $plack_server = Plack::Loader->load ('Standalone', port => $port, server_ready => sub { kill 'USR1' => getppid(); }); # We are expecting a USR1 from the child process after it's ready # to listen. We set this up _before_ we fork to avoid race # conditions. my $handled; local $SIG{USR1} = sub { $handled = 1}; __disconnect_rt(); my $pid = fork(); die "failed to fork" unless defined $pid; if ($pid) { sleep 15 unless $handled; Test::More::diag "did not get expected USR1 for test server readiness" unless $handled; push @SERVERS, $pid; my $Tester = Test::Builder->new; $Tester->ok(1, "started plack server ok"); __reconnect_rt() unless $rttest_opt{nodb}; return ("http://localhost:$port", RT::Test::Web->new); } require POSIX; if ( $^O !~ /MSWin32/ ) { POSIX::setsid() or die "Can't start a new session: $!"; } # stick this in a scope so that when $app is garbage collected, # StashWarnings can complain about unhandled warnings do { $plack_server->run($self->test_app(@_)); }; exit; } our $TEST_APP; sub start_inline_server { my $self = shift; require Test::WWW::Mechanize::PSGI; unshift @RT::Test::Web::ISA, 'Test::WWW::Mechanize::PSGI'; # Clear out squished CSS and JS cache, since it's retained across # servers, since it's in-process RT::Interface::Web->ClearSquished; Test::More::ok(1, "psgi test server ok"); $TEST_APP = $self->test_app(@_); return ("http://localhost:$port", RT::Test::Web->new); } sub start_apache_server { my $self = shift; my %server_opt = @_; $server_opt{variant} ||= 'mod_perl'; $ENV{RT_TEST_WEB_HANDLER} = "apache+$server_opt{variant}"; require RT::Test::Apache; my $pid = RT::Test::Apache->start_server( %server_opt, port => $port, tmp => \%tmp ); push @SERVERS, $pid; my $url = RT->Config->Get('WebURL'); $url =~ s!/$!!; return ($url, RT::Test::Web->new); } sub stop_server { my $self = shift; my $in_end = shift; return unless @SERVERS; my $sig = 'TERM'; $sig = 'INT' if $ENV{'RT_TEST_WEB_HANDLER'} eq "plack"; kill $sig, @SERVERS; foreach my $pid (@SERVERS) { if ($ENV{RT_TEST_WEB_HANDLER} =~ /^apache/) { sleep 1 while kill 0, $pid; } else { waitpid $pid, 0; } } @SERVERS = (); } sub temp_directory { return $tmp{'directory'}; } sub file_content { my $self = shift; my $path = shift; my %args = @_; $path = File::Spec->catfile( @$path ) if ref $path eq 'ARRAY'; Test::More::diag "reading content of '$path'" if $ENV{'TEST_VERBOSE'}; open( my $fh, "<:raw", $path ) or do { warn "couldn't open file '$path': $!" unless $args{noexist}; return '' }; my $content = do { local $/; <$fh> }; close $fh; unlink $path if $args{'unlink'}; return $content; } sub find_executable { my $self = shift; my $name = shift; require File::Spec; foreach my $dir ( split /:/, $ENV{'PATH'} ) { my $fpath = File::Spec->catpath( (File::Spec->splitpath( $dir, 'no file' ))[0..1], $name ); next unless -e $fpath && -r _ && -x _; return $fpath; } return undef; } sub diag { return unless $ENV{RT_TEST_VERBOSE} || $ENV{TEST_VERBOSE}; goto \&Test::More::diag; } sub parse_mail { my $mail = shift; require RT::EmailParser; my $parser = RT::EmailParser->new; $parser->ParseMIMEEntityFromScalar( $mail ); return $parser->Entity; } sub works { Test::More::ok($_[0], $_[1] || 'This works'); } sub fails { Test::More::ok(!$_[0], $_[1] || 'This should fail'); } END { my $Test = RT::Test->builder; return if $Test->{Original_Pid} != $$; # we are in END block and should protect our exit code # so calls below may call system or kill that clobbers $? local $?; RT::Test->stop_server(1); # not success if ( !$Test->is_passing ) { $tmp{'directory'}->unlink_on_destroy(0); Test::More::diag( "Some tests failed or we bailed out, tmp directory" ." '$tmp{directory}' is not cleaned" ); } if ( $ENV{RT_TEST_PARALLEL} && $created_new_db ) { __drop_database(); } # Drop our port from t/tmp/ports; do this after dropping the # database, as our port lock is also a lock on the database name. if ($port) { my %ports; my $portfile = "$tmp{'directory'}/../ports"; sysopen(PORTS, $portfile, O_RDWR|O_CREAT) or die "Can't write to ports file $portfile: $!"; flock(PORTS, LOCK_EX) or die "Can't write-lock ports file $portfile: $!"; $ports{$_}++ for split ' ', join("",); delete $ports{$port}; seek(PORTS, 0, 0); truncate(PORTS, 0); print PORTS "$_\n" for sort {$a <=> $b} keys %ports; close(PORTS) or die "Can't close ports file: $!"; } } { # ease the used only once warning no warnings; no strict 'refs'; %{'RT::I18N::en_us::Lexicon'}; %{'Win32::Locale::Lexicon'}; } 1;