# BEGIN BPS TAGGED BLOCK {{{ # # COPYRIGHT: # # This software is Copyright (c) 1996-2014 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; BEGIN { $^W = 1 }; use base 'Test::More'; BEGIN { # Warn about role consumers overriding role methods so we catch it in tests. $ENV{PERL_ROLE_OVERRIDE_WARN} = 1; } # We use the Test::NoWarnings catching and reporting functionality, but need to # wrap it in our own special handler because of the warn handler installed via # RT->InitLogging(). require Test::NoWarnings; my $Test_NoWarnings_Catcher = $SIG{__WARN__}; my $check_warnings_in_end = 1; use Socket; use File::Temp qw(tempfile); use File::Path qw(mkpath); use File::Spec; use File::Which qw(); use Scalar::Util qw(blessed); our @EXPORT = qw(is_empty diag parse_mail works fails plan done_testing); 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; BEGIN { delete $ENV{$_} for qw/LANGUAGE LC_ALL LC_MESSAGES LANG/; $ENV{LANG} = "C"; }; sub import { my $class = shift; my %args = %rttest_opt = @_; $rttest_opt{'nodb'} = $args{'nodb'} = 1 if $^C; # Spit out a plan (if we got one) *before* we load modules if ( $args{'tests'} ) { 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'} ) { 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'}; push @{ $args{'plugins'} ||= [] }, split " ", $ENV{RT_TEST_PLUGINS} if $ENV{RT_TEST_PLUGINS}; $class->bootstrap_tempdir; $class->bootstrap_port; $class->bootstrap_plugins_paths( %args ); $class->bootstrap_config( %args ); use RT; RT::LoadConfig; RT::InitPluginPaths(); RT::InitClasses(); RT::I18N->Init(); $class->bootstrap_db( %args ); __reconnect_rt() unless $args{nodb}; __init_logging(); RT->Plugins; 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++; } # By default we test HTML templates, but text templates are # available on request if ( $args{'text_templates'} ) { $class->switch_templates_ok('text'); } Test::More->export_to_level($level); Test::NoWarnings->export_to_level($level); # Blow away symbols we redefine to avoid warnings. # better than "no warnings 'redefine'" because we might accidentally # suppress a mistaken redefinition no strict 'refs'; delete ${ caller($level) . '::' }{diag}; delete ${ caller($level) . '::' }{plan}; delete ${ caller($level) . '::' }{done_testing}; __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 zh_CN fr ja)); Set( \$RTAddressRegexp , qr/^bad_re_that_doesnt_match\$/i); Set( \$ShowHistory, "always"); }; 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 ( $ENV{'RT_TEST_DB_HOST'} ) { print $config "Set( \$DatabaseHost , '$ENV{'RT_TEST_DB_HOST'}');\n"; } if ( $args{'plugins'} ) { print $config "Set( \@Plugins, qw(". join( ' ', @{ $args{'plugins'} } ) .") );\n"; my $plugin_data = File::Spec->rel2abs("t/data/plugins"); print $config qq[\$RT::PluginPath = "$plugin_data";\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: $!"; my @lines; while (<$fh>) { if (not @lines or /^Set\(/) { push @lines, $_; } else { $lines[-1] .= $_; } } close $fh; # Traim trailing newlines and "1;" $lines[-1] =~ s/(^1;\n|^\n)*\Z//m; # Remove any previous definitions of this var @lines = grep {not /^Set\(\s*\Q$sigil$name\E\b/} @lines; # Format the new value for output require Data::Dumper; local $Data::Dumper::Terse = 1; my $dump = Data::Dumper::Dumper([@_[2 .. $#_]]); $dump =~ s/;?\s+\Z//; push @lines, "Set( ${sigil}${name}, \@{". $dump ."});\n"; push @lines, "\n1;\n"; # Re-write the configuration file open( $fh, '>', $tmp{'config'}{'RT'} ) or die "Couldn't open config file: $!"; print $fh $_ for @lines; 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'; __init_logging(); __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 /^RT_TEST_PLUGIN_(?:$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"); } sub __init_logging { my $filter; { # We use local to ensure that the $filter we grab is from InitLogging # and not the handler generated by a previous call to this function # itself. local $SIG{__WARN__}; RT::InitLogging(); $filter = $SIG{__WARN__}; } $SIG{__WARN__} = sub { if ($filter) { my $status = $filter->(@_); if ($status and $status eq 'IGNORE') { return; # pretend the bad dream never happened } } # Avoid reporting this anonymous call frame as the source of the warning. goto &$Test_NoWarnings_Catcher; }; } =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', CASESENSITIVE => 0, ); $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::Link::TYPEMAP; 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 ( blessed $args{'Queue'} ) { $args{Queue} = $args{'Queue'}->id; } elsif ($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, ); } if ( my $cfs = delete $args{'CustomFields'} ) { my $q = RT::Queue->new( RT->SystemUser ); $q->Load( $args{'Queue'} ); while ( my ($k, $v) = each %$cfs ) { my $cf = $q->CustomField( $k ); unless ($cf->id) { RT->Logger->error("Couldn't load custom field $k"); next; } $args{'CustomField-'. $cf->id} = $v; } } 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->Domain eq 'ACLEquivalence' && $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->Domain eq 'ACLEquivalence' && $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); } else { my $type = $principal; $principal = RT::Group->new( RT->SystemUser ); $principal->LoadRoleGroup( Object => ($e->{'Object'} || RT->System), Name => $type ); } die "Principal is not an object nor the name of a system or role group" unless $principal->id; } 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; } =head2 switch_templates_to TYPE This runs etc/upgrade/switch-templates-to in order to change the templates from HTML to text or vice versa. TYPE is the type to switch to, either C or C. =cut sub switch_templates_to { my $self = shift; my $type = shift; return $self->run_and_capture( command => "$RT::EtcPath/upgrade/switch-templates-to", args => $type, ); } =head2 switch_templates_ok TYPE Calls L and tests the return values. =cut sub switch_templates_ok { my $self = shift; my $type = shift; my ($exit, $output) = $self->switch_templates_to($type); if ($exit >> 8) { Test::More::fail("Switched templates to $type cleanly"); diag("**** etc/upgrade/switch-templates-to exited with ".($exit >> 8).":\n$output"); } else { Test::More::pass("Switched templates to $type cleanly"); } return ($exit, $output); } 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'}; my $args = delete $args{'args'}; while( my ($k,$v) = each %args ) { next unless $v; $cmd .= " --$k '$v'"; } $cmd .= " $args" if defined $args; $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 { local $Test::Builder::Level = $Test::Builder::Level + 1; 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 { local $Test::Builder::Level = $Test::Builder::Level + 1; my $class = shift; my $mail = shift; close $mail; Test::More::is ($? >> 8, 0, "The mail gateway exited normally. yay"); } sub mailsent_ok { local $Test::Builder::Level = $Test::Builder::Level + 1; 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'}; } my $validator_path = "$RT::SbinPath/rt-validator"; sub run_validator { my $self = shift; my %args = (check => 1, resolve => 0, force => 1, @_ ); my $cmd = $validator_path; die "Couldn't find $cmd command" unless -f $cmd; while( my ($k,$v) = each %args ) { next unless $v; $cmd .= " --$k '$v'"; } $cmd .= ' 2>&1'; require IPC::Open2; my ($child_out, $child_in); my $pid = IPC::Open2::open2($child_out, $child_in, $cmd); close $child_in; my $result = do { local $/; <$child_out> }; close $child_out; waitpid $pid, 0; DBIx::SearchBuilder::Record::Cachable->FlushCache if $args{'resolve'}; return ($?, $result); } sub db_is_valid { local $Test::Builder::Level = $Test::Builder::Level + 1; my $self = shift; my ($ecode, $res) = $self->run_validator; Test::More::is( $ecode, 0, 'no invalid records' ) or Test::More::diag "errors:\n$res"; } =head2 object_scrips_are Takes an L object or ID as the first argument and an arrayref of L objects and/or Queue IDs as the second argument. The scrip's applications (L records) are tested to ensure they exactly match the arrayref. An optional third arrayref may be passed to enumerate and test the queues the scrip is B added to. This is most useful for testing the API returns the correct results. =cut sub object_scrips_are { local $Test::Builder::Level = $Test::Builder::Level + 1; my $self = shift; my $scrip = shift; my $to = shift || []; my $not_to = shift; unless (blessed($scrip)) { my $id = $scrip; $scrip = RT::Scrip->new( RT->SystemUser ); $scrip->Load($id); } $to = [ map { blessed($_) ? $_->id : $_ } @$to ]; Test::More::ok($scrip->IsAdded($_), "added to queue $_" ) foreach @$to; Test::More::is_deeply( [sort map $_->id, @{ $scrip->AddedTo->ItemsArrayRef }], [sort grep $_, @$to ], 'correct list of added to queues', ); if ($not_to) { $not_to = [ map { blessed($_) ? $_->id : $_ } @$not_to ]; Test::More::ok(!$scrip->IsAdded($_), "not added to queue $_" ) foreach @$not_to; Test::More::is_deeply( [sort map $_->id, @{ $scrip->NotAddedTo->ItemsArrayRef }], [sort grep $_, @$not_to ], 'correct list of not added to queues', ); } } =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. Cupdir(), 'data', 'emails')> Parent directory traversals (C<..> or File::Spec->updir()) are naively canonicalized based on the test file path (C<$0>) so that symlinks aren't followed. This is the exact opposite behaviour of most filesystems and is considered "wrong", however it is necessary for some subsets of tests which are symlinked into the testing tree. =cut sub get_relocatable_dir { my @directories = File::Spec->splitdir( File::Spec->rel2abs((File::Spec->splitpath($0))[1]) ); push @directories, File::Spec->splitdir($_) for @_; my @clean; for (@directories) { if ($_ eq "..") { pop @clean } elsif ($_ ne ".") { push @clean, $_ } } return File::Spec->catdir(@clean); } =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 find_relocatable_path { my @path = @_; # A simple strategy to find e.g., t/data/gnupg/keys, from the dir # where test file lives. We try up to 3 directories up my $path = File::Spec->catfile( @path ); for my $up ( 0 .. 2 ) { my $p = get_relocatable_dir($path); return $p if -e $p; $path = File::Spec->catfile( File::Spec->updir(), $path ); } return undef; } 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"; my $path = find_relocatable_path( 'data', 'gnupg', 'keys' ); die "can't find the dir where gnupg keys are stored" unless $path; return RT::Crypt::GnuPG->ImportKey( RT::Test->file_content( [ $path, $key ] ) ); } sub lsign_gnupg_key { my $self = shift; my $key = shift; return RT::Crypt::GnuPG->CallGnuPG( Command => '--lsign-key', CommandArgs => [$key], Callback => sub { my %handle = @_; while ( my $str = readline $handle{'status'} ) { if ( $str =~ /^\[GNUPG:\]\s*GET_BOOL sign_uid\..*/ ) { print { $handle{'command'} } "y\n"; } } }, ); } sub trust_gnupg_key { my $self = shift; my $key = shift; return RT::Crypt::GnuPG->CallGnuPG( Command => '--edit-key', CommandArgs => [$key], Callback => sub { my %handle = @_; 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; } } }, ); } 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 => $server_opt{basic_auth} eq 'anon' ? sub { 1 } : 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 { local $Test::Builder::Level = $Test::Builder::Level + 1; 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 { local $Test::Builder::Level = $Test::Builder::Level + 1; 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; require RT::Interface::Web::Request; RT::Interface::Web::Request->clear_callback_cache; 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 { local $Test::Builder::Level = $Test::Builder::Level + 1; 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; kill 'TERM', @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; return File::Which::which( @_ ); } 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'); } sub plan { my ($cmd, @args) = @_; my $builder = RT::Test->builder; if ($cmd eq "skip_all") { $check_warnings_in_end = 0; } elsif ($cmd eq "tests") { # Increment the test count for the warnings check $args[0]++; } $builder->plan($cmd, @args); } sub done_testing { my $builder = RT::Test->builder; Test::NoWarnings::had_no_warnings(); $check_warnings_in_end = 0; $builder->done_testing(@_); } 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 $?; Test::NoWarnings::had_no_warnings() if $check_warnings_in_end; 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;