X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=blobdiff_plain;f=rt%2Flib%2FRT%2FTest.pm;h=6afb31192ccc408687d4670e73aacffef52733ee;hp=e1990d00d007c7b28ff429489ba6f58a684c7286;hb=9aee669886202be7035e6c6049fc71bc99dd3013;hpb=75162bb14b3e38d66617077843f4dfdcaf09d5c4 diff --git a/rt/lib/RT/Test.pm b/rt/lib/RT/Test.pm index e1990d00d..6afb31192 100644 --- a/rt/lib/RT/Test.pm +++ b/rt/lib/RT/Test.pm @@ -2,7 +2,7 @@ # # COPYRIGHT: # -# This software is Copyright (c) 1996-2011 Best Practical Solutions, LLC +# This software is Copyright (c) 1996-2015 Best Practical Solutions, LLC # # # (Except where explicitly superseded by other copyright notices) @@ -51,33 +51,31 @@ 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 $SKIP_REQUEST_WORK_AROUND = 0; - -use HTTP::Request::Common (); -use Hook::LexWrap; -wrap 'HTTP::Request::Common::form_data', - post => sub { - return if $SKIP_REQUEST_WORK_AROUND; - my $data = $_[-1]; - if (ref $data) { - $data->[0] = Encode::encode_utf8($data->[0]); - } - else { - $_[-1] = Encode::encode_utf8($_[-1]); - } - }; - - -our @EXPORT = qw(is_empty parse_mail); -our ($port, $dbname); -our @SERVERS; +our @EXPORT = qw(is_empty diag parse_mail works fails plan done_testing); my %tmp = ( directory => undef, @@ -88,6 +86,8 @@ my %tmp = ( mailbox => undef, ); +my %rttest_opt; + =head1 NAME RT::Test - RT Testing @@ -107,56 +107,73 @@ problem in Perl that hides the top-level optree from L. =cut -sub generate_port { - my $self = shift; - my $port = 1024 + int rand(10000) + $$ % 1024; - - 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); - return generate_port(); - } - close(SOCK); - - return $port; -} +our $port; +our @SERVERS; BEGIN { - $port = generate_port(); - $dbname = $ENV{RT_TEST_PARALLEL}? "rt3test_$port" : "rt3test"; + delete $ENV{$_} for qw/LANGUAGE LC_ALL LC_MESSAGES LANG/; + $ENV{LANG} = "C"; }; sub import { my $class = shift; my %args = @_; + %rttest_opt = %args; + + $rttest_opt{'nodb'} = $args{'nodb'} = 1 if $^C; # Spit out a plan (if we got one) *before* we load modules if ( $args{'tests'} ) { - $class->builder->plan( tests => $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; - if (RT->Config->Get('DevelMode')) { require Module::Refresh; } + RT::InitPluginPaths(); + RT::InitClasses(); + + RT::I18N->Init(); + $class->set_config_wrapper; $class->bootstrap_db( %args ); - RT->Init; + __reconnect_rt() + unless $args{nodb}; - $class->bootstrap_plugins( %args ); + __init_logging(); - $class->set_config_wrapper; + RT->Plugins; + + RT->Config->PostLoadCheck; + + $class->encode_output; my $screen_logger = $RT::Logger->remove( 'screen' ); require Log::Dispatch::Perl; @@ -177,7 +194,22 @@ sub import { $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); } @@ -197,15 +229,64 @@ sub db_requires_no_dba { 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_file = ( - File::Spec->rel2abs((caller)[1]) - =~ m{(?:^|[\\/])t[/\\](.*)} - ); - my $dir_name = File::Spec->rel2abs('t/tmp/'. $test_file); + 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 ); } @@ -220,11 +301,14 @@ sub bootstrap_config { 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( \$RTAddressRegexp , qr/^bad_re_that_doesnt_match\$/); +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"; @@ -233,8 +317,26 @@ Set( \$RTAddressRegexp , qr/^bad_re_that_doesnt_match\$/); print $config "Set( \$DatabaseName , '$dbname');\n"; print $config "Set( \$DatabaseUser , 'u${dbname}');\n"; } - print $config "Set( \$DevelMode, 0 );\n" - if $INC{'Devel/Cover.pm'}; + 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 ); @@ -254,7 +356,9 @@ Set( \$MailCommand, sub { close \$handle; } ); END - + + $self->bootstrap_more_config($config, \%args); + print $config $args{'config'} if $args{'config'}; print $config "\n1;\n"; @@ -264,6 +368,8 @@ END return $config; } +sub bootstrap_more_config { } + sub bootstrap_logging { my $self = shift; my $config = shift; @@ -280,7 +386,7 @@ sub bootstrap_logging { 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; - my $dump = Data::Dumper::Dumper([@_[2 .. $#_]]); - $dump =~ s/;\s+$//; - print $fh - "\nSet(${sigil}${name}, \@{". $dump ."}); 1;\n"; - close $fh; - - if ( @SERVERS ) { - warn "you're changing config option in a test file" - ." when server is active"; + + *RT::Config::WriteSet = sub { + my ($self, $name) = @_; + my $type = $RT::Config::META{$name}->{'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->(@_); + }; + + *RT::Config::Set = sub { + # Determine if the caller is either from a test script, or + # from helper functions called by test script to alter + # configuration that should be written. This is necessary + # because some extensions (RTIR, for example) temporarily swap + # configuration values out and back in Mason during requests. + my @caller = caller(1); # preserve list context + @caller = caller(0) unless @caller; + + return RT::Config::WriteSet(@_) + if ($caller[1]||'') =~ /\.t$/; + return $old_sub->(@_); }; } +sub encode_output { + my $builder = Test::More->builder; + binmode $builder->output, ":encoding(utf8)"; + binmode $builder->failure_output, ":encoding(utf8)"; + binmode $builder->todo_output, ":encoding(utf8)"; +} + sub bootstrap_db { my $self = shift; my %args = @_; @@ -333,67 +483,54 @@ sub bootstrap_db { } require RT::Handle; - # 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. - RT::Handle->DropDatabase( $dbh, Force => 1 ); + if (my $forceopt = $ENV{RT_TEST_FORCE_OPT}) { + Test::More::diag "forcing $forceopt"; + $args{$forceopt}=1; } - RT::Handle->CreateDatabase( $dbh ); - $dbh->disconnect; - $created_new_db++; + # Short-circuit the rest of ourselves if we don't want a db + if ($args{nodb}) { + __drop_database(); + return; + } - $dbh = _get_dbh(RT::Handle->DSN, - $ENV{RT_DBA_USER}, $ENV{RT_DBA_PASSWORD}); + my $db_type = RT->Config->Get('DatabaseType'); - $RT::Handle = new RT::Handle; - $RT::Handle->dbh( $dbh ); - $RT::Handle->InsertSchema( $dbh ); + if ($db_type eq "SQLite") { + RT->Config->WriteSet( DatabaseName => File::Spec->catfile( $self->temp_directory, "rt4test" ) ); + } - my $db_type = RT->Config->Get('DatabaseType'); - $RT::Handle->InsertACL( $dbh ) unless $db_type eq 'Oracle'; + __create_database(); + __reconnect_rt('as dba'); + $RT::Handle->InsertSchema; + $RT::Handle->InsertACL unless $db_type eq 'Oracle'; - $RT::Handle = new RT::Handle; - $RT::Handle->dbh( undef ); - RT->ConnectToDatabase; - RT->InitLogging; - RT->InitSystemObjects; - $RT::Handle->InsertInitialData; + __init_logging(); + __reconnect_rt(); - DBIx::SearchBuilder::Record::Cachable->FlushCache; - $RT::Handle = new RT::Handle; - $RT::Handle->dbh( undef ); - RT->Init; + $RT::Handle->InsertInitialData + unless $args{noinitialdata}; - $RT::Handle->PrintError; - $RT::Handle->dbh->{PrintError} = 1; + $RT::Handle->InsertData( $RT::EtcPath . "/initialdata" ) + unless $args{noinitialdata} or $args{nodata}; - unless ( $args{'nodata'} ) { - $RT::Handle->InsertData( $RT::EtcPath . "/initialdata" ); - } - DBIx::SearchBuilder::Record::Cachable->FlushCache; + $self->bootstrap_plugins_db( %args ); } -sub bootstrap_plugins { +sub bootstrap_plugins_paths { my $self = shift; my %args = @_; - return unless $args{'requires'}; + return unless $args{'plugins'}; + my @plugins = @{ $args{'plugins'} }; - my @plugins = @{ $args{'requires'} }; - push @plugins, $args{'testing'} - if $args{'testing'}; - - require RT::Plugin; 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 { @@ -403,22 +540,22 @@ sub bootstrap_plugins { if ( grep $name eq $_, @plugins ) { my $variants = join "(?:|::|-|_)", map "\Q$_\E", split /::/, $name; - my ($path) = map $ENV{$_}, grep /^CHIMPS_(?:$variants).*_ROOT$/i, keys %ENV; + my ($path) = map $ENV{$_}, grep /^RT_TEST_PLUGIN_(?:$variants).*_ROOT$/i, keys %ENV; return $path if $path; } return $old_func->(@_); }; +} - RT->Config->Set( Plugins => @plugins ); - RT->InitPluginPaths; +sub bootstrap_plugins_db { + my $self = shift; + my %args = @_; - my $dba_dbh; - $dba_dbh = _get_dbh( - RT::Handle->DSN, - $ENV{RT_DBA_USER}, $ENV{RT_DBA_PASSWORD}, - ) if @plugins; + 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" ) @@ -428,31 +565,37 @@ sub bootstrap_plugins { Test::More::diag( "etc path of the plugin is '$etc_path'" ) if $ENV{'TEST_VERBOSE'}; - if ( -e $etc_path ) { - my ($ret, $msg) = $RT::Handle->InsertSchema( $dba_dbh, $etc_path ); - Test::More::ok($ret || $msg =~ /^Couldn't find schema/, "Created schema: ".($msg||'')); - - ($ret, $msg) = $RT::Handle->InsertACL( $dba_dbh, $etc_path ); - Test::More::ok($ret || $msg =~ /^Couldn't find ACLs/, "Created ACL: ".($msg||'')); - - my $data_file = File::Spec->catfile( $etc_path, 'initialdata' ); - if ( -e $data_file ) { - ($ret, $msg) = $RT::Handle->InsertData( $data_file );; - Test::More::ok($ret, "Inserted data".($msg||'')); - } else { - Test::More::ok(1, "There is no data file" ); - } - } - else { -# we can not say if plugin has no data or we screwed with etc path + 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||'')); } - $RT::Handle->Connect; # XXX: strange but mysql can loose connection + { # 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" ); + } } - $dba_dbh->disconnect if $dba_dbh; + __reconnect_rt(); } sub _get_dbh { @@ -472,6 +615,96 @@ sub _get_dbh { 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 { + $filter->(@_) if $filter; + # Avoid reporting this anonymous call frame as the source of the warning. + goto &$Test_NoWarnings_Catcher; + }; +} + + =head1 UTILITIES =head2 load_or_create_user @@ -486,7 +719,7 @@ sub load_or_create_user { $MemberOf = [ $MemberOf ] if defined $MemberOf && !ref $MemberOf; $MemberOf ||= []; - my $obj = RT::User->new( $RT::SystemUser ); + my $obj = RT::User->new( RT->SystemUser ); if ( $args{'Name'} ) { $obj->LoadByCols( Name => $args{'Name'} ); } elsif ( $args{'EmailAddress'} ) { @@ -508,11 +741,14 @@ sub load_or_create_user { # clean group membership { require RT::GroupMembers; - my $gms = RT::GroupMembers->new( $RT::SystemUser ); + 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( + 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; @@ -530,6 +766,39 @@ sub load_or_create_user { return $obj; } + +sub load_or_create_group { + my $self = shift; + my $name = shift; + my %args = (@_); + + my $group = RT::Group->new( RT->SystemUser ); + $group->LoadUserDefinedGroup( $name ); + unless ( $group->id ) { + my ($id, $msg) = $group->CreateUserDefinedGroup( + Name => $name, + ); + die "$msg" unless $id; + } + + if ( $args{Members} ) { + my $cur = $group->MembersObj; + while ( my $entry = $cur->Next ) { + my ($status, $msg) = $entry->Delete; + die "$msg" unless $status; + } + + foreach my $new ( @{ $args{Members} } ) { + my ($status, $msg) = $group->AddMember( + ref($new)? $new->id : $new, + ); + die "$msg" unless $status; + } + } + + return $group; +} + =head2 load_or_create_queue =cut @@ -537,7 +806,7 @@ sub load_or_create_user { sub load_or_create_queue { my $self = shift; my %args = ( Disabled => 0, @_ ); - my $obj = RT::Queue->new( $RT::SystemUser ); + my $obj = RT::Queue->new( RT->SystemUser ); if ( $args{'Name'} ) { $obj->LoadByCols( Name => $args{'Name'} ); } else { @@ -550,7 +819,7 @@ sub load_or_create_queue { my @fields = qw(CorrespondAddress CommentAddress); foreach my $field ( @fields ) { next unless exists $args{ $field }; - next if $args{ $field } eq $obj->$field; + next if $args{ $field } eq ($obj->$field || ''); no warnings 'uninitialized'; my $method = 'Set'. $field; @@ -562,6 +831,130 @@ sub load_or_create_queue { 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 => Encode::encode( "UTF-8", $args{'Requestor'} ), + Subject => RT::Interface::Email::EncodeToMIME( String => $args{'Subject'} ), + Type => $args{ContentType} // "text/plain", + Charset => "UTF-8", + Data => Encode::encode( "UTF-8", $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 @@ -569,9 +962,13 @@ sub load_or_create_queue { sub load_or_create_custom_field { my $self = shift; my %args = ( Disabled => 0, @_ ); - my $obj = RT::CustomField->new( $RT::SystemUser ); + my $obj = RT::CustomField->new( RT->SystemUser ); if ( $args{'Name'} ) { - $obj->LoadByName( Name => $args{'Name'}, Queue => $args{'Queue'} ); + $obj->LoadByName( + Name => $args{'Name'}, + LookupType => RT::Ticket->CustomFieldLookupType, + ObjectId => $args{'Queue'}, + ); } else { die "Name is required"; } @@ -586,7 +983,7 @@ sub load_or_create_custom_field { sub last_ticket { my $self = shift; my $current = shift; - $current = $current ? RT::CurrentUser->new($current) : $RT::SystemUser; + $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' ); @@ -599,17 +996,17 @@ sub store_rights { require RT::ACE; # fake construction - RT::ACE->new( $RT::SystemUser ); + RT::ACE->new( RT->SystemUser ); my @fields = keys %{ RT::ACE->_ClassAccessible }; require RT::ACL; - my $acl = RT::ACL->new( $RT::SystemUser ); + 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 ) { + if ( $obj->isa('RT::Group') && $obj->Domain eq 'ACLEquivalence' && $obj->Instance == RT->Nobody->id ) { next; } @@ -626,7 +1023,7 @@ sub restore_rights { my $self = shift; my @entries = @_; foreach my $entry ( @entries ) { - my $ace = RT::ACE->new( $RT::SystemUser ); + 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"; @@ -638,11 +1035,11 @@ sub set_rights { my $self = shift; require RT::ACL; - my $acl = RT::ACL->new( $RT::SystemUser ); + 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 ) { + if ( $obj->isa('RT::Group') && $obj->Domain eq 'ACLEquivalence' && $obj->Instance == RT->Nobody->id ) { next; } $ace->Delete; @@ -659,18 +1056,18 @@ sub add_rights { my $principal = delete $e->{'Principal'}; unless ( ref $principal ) { if ( $principal =~ /^(everyone|(?:un)?privileged)$/i ) { - $principal = RT::Group->new( $RT::SystemUser ); + $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"; + 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') ) { @@ -686,6 +1083,46 @@ sub add_rights { return 1; } +=head2 switch_templates_to TYPE + +This runs /opt/rt4/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("**** $RT::EtcPath/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; @@ -724,10 +1161,13 @@ sub run_and_capture { $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; @@ -746,7 +1186,7 @@ sub run_and_capture { return ($?, $result); } -sub send_via_mailgate { +sub send_via_mailgate_and_http { my $self = shift; my $message = shift; my %args = (@_); @@ -769,7 +1209,35 @@ sub send_via_mailgate { 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} ); + + # Invert the status to act like a syscall; failing return code is 1, + # and it will be right-shifted before being examined. + $status = ($status == 1) ? 0 + : ($status == -75) ? (-75 << 8) + : (1 << 8); + + 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'; @@ -780,6 +1248,7 @@ sub open_mailgate_ok { sub close_mailgate_ok { + local $Test::Builder::Level = $Test::Builder::Level + 1; my $class = shift; my $mail = shift; close $mail; @@ -787,6 +1256,7 @@ sub close_mailgate_ok { } sub mailsent_ok { + local $Test::Builder::Level = $Test::Builder::Level + 1; my $class = shift; my $expected = shift; @@ -803,11 +1273,6 @@ sub mailsent_ok { ); } -sub set_mail_catcher { - my $self = shift; - return 1; -} - sub fetch_caught_mails { my $self = shift; return grep /\S/, split /%% split me! %%\n/, @@ -822,22 +1287,123 @@ sub clean_caught_mails { unlink $tmp{'mailbox'}; } +sub run_validator { + my $self = shift; + my %args = (check => 1, resolve => 0, force => 1, timeout => 0, @_ ); + + my $cmd = "$RT::SbinPath/rt-validator"; + die "Couldn't find $cmd command" unless -f $cmd; + + my $timeout = delete $args{timeout}; + + 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; + + local $SIG{ALRM} = sub { kill KILL => $pid; die "Timeout!" }; + + alarm $timeout if $timeout; + my $result = eval { local $/; <$child_out> }; + warn $@ if $@; + close $child_out; + waitpid $pid, 0; + alarm 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. RT::Test::get_relocatable_dir(File::Spec->updir(), 'data', 'emails') +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 $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, @_); + 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 @@ -855,6 +1421,21 @@ sub get_relocatable_file { 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)) { @@ -864,6 +1445,14 @@ sub get_abs_relocatable_dir { } } +sub gnupg_homedir { + my $self = shift; + File::Temp->newdir( + DIR => $tmp{directory}, + CLEANUP => 0, + ); +} + sub import_gnupg_key { my $self = shift; my $key = shift; @@ -872,154 +1461,59 @@ sub import_gnupg_key { $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 ); - } - } + my $path = find_relocatable_path( 'data', 'gnupg', 'keys' ); die "can't find the dir where gnupg keys are stored" - unless $abs_path; + unless $path; - return RT::Crypt::GnuPG::ImportKey( - RT::Test->file_content( [ $abs_path, $key ] ) ); + return RT::Crypt::GnuPG->ImportKey( + RT::Test->file_content( [ $path, $key ] ) ); } - sub lsign_gnupg_key { my $self = shift; my $key = shift; - require RT::Crypt::GnuPG; require GnuPG::Interface; - my $gnupg = new GnuPG::Interface; - 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'} = new IO::Handle), - stdout => ($handle{'output'} = new IO::Handle), - stderr => ($handle{'error'} = new IO::Handle), - logger => ($handle{'logger'} = new IO::Handle), - status => ($handle{'status'} = new IO::Handle), - command => ($handle{'command'} = new IO::Handle), - ); - - 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"; + 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"; + } } - } - 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 = new GnuPG::Interface; - 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'} = new IO::Handle), - stdout => ($handle{'output'} = new IO::Handle), - stderr => ($handle{'error'} = new IO::Handle), - logger => ($handle{'logger'} = new IO::Handle), - status => ($handle{'status'} = new IO::Handle), - command => ($handle{'command'} = new IO::Handle), - ); - - 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"; + 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; } - } 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 { @@ -1027,195 +1521,180 @@ sub started_ok { require RT::Test::Web; - my $which = $ENV{'RT_TEST_WEB_HANDLER'} || 'standalone'; + 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, @_ ); + return $self->$function( variant => $variant, @_ ); } -sub start_standalone_server { +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 RT::Interface::Web::Standalone; - - require Test::HTTP::Server::Simple::StashWarnings; - unshift @RT::Interface::Web::Standalone::ISA, - 'Test::HTTP::Server::Simple::StashWarnings'; - *RT::Interface::Web::Standalone::test_warning_path = sub { - "/__test_warnings"; - }; - - my $s = RT::Interface::Web::Standalone->new($port); - - my $ret = $s->started_ok; - push @SERVERS, $s->pids; - - $RT::Handle = new RT::Handle; - $RT::Handle->dbh( undef ); - RT->ConnectToDatabase; - - return ($ret, RT::Test::Web->new); -} - -sub start_apache_server { - my $self = shift; - my $variant = shift || 'mod_perl'; - - my %info = $self->apache_server_info( variant => $variant ); - - Test::More::diag(do { - open( my $fh, '<', $tmp{'config'}{'RT'} ) or die $!; - local $/; - <$fh> - }); - - my $tmpl = File::Spec->rel2abs( File::Spec->catfile( - 't', 'data', 'configs', - 'apache'. $info{'version'} .'+'. $variant .'.conf' - ) ); - my %opt = ( - listen => $port, - server_root => $info{'HTTPD_ROOT'} || $ENV{'HTTPD_ROOT'} - || Test::More::BAIL_OUT("Couldn't figure out server root"), - document_root => $RT::MasonComponentRoot, - tmp_dir => "$tmp{'directory'}", - rt_bin_path => $RT::BinPath, - rt_site_config => $ENV{'RT_SITE_CONFIG'}, - ); - foreach (qw(log pid lock)) { - $opt{$_ .'_file'} = File::Spec->catfile( - "$tmp{'directory'}", "apache.$_" + require Plack::Middleware::Test::StashWarnings; + my $stashwarnings = Plack::Middleware::Test::StashWarnings->new( + $ENV{'RT_TEST_WEB_HANDLER'} && $ENV{'RT_TEST_WEB_HANDLER'} eq 'inline' ? ( verbose => 0 ) : () ); + $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'; + } ); } - { - my $method = 'apache_'.$variant.'_server_options'; - $self->$method( \%info, \%opt ); - } - $tmp{'config'}{'apache'} = File::Spec->catfile( - "$tmp{'directory'}", "apache.conf" - ); - $self->process_in_file( - in => $tmpl, - out => $tmp{'config'}{'apache'}, - options => \%opt, - ); - - $self->fork_exec($info{'executable'}, '-f', $tmp{'config'}{'apache'}); - my $pid = do { - my $tries = 10; - while ( !-e $opt{'pid_file'} ) { - $tries--; - last unless $tries; - sleep 1; - } - Test::More::BAIL_OUT("Couldn't start apache server, no pid file") - unless -e $opt{'pid_file'}; - open( my $pid_fh, '<', $opt{'pid_file'} ) - or Test::More::BAIL_OUT("Couldn't open pid file: $!"); - my $pid = <$pid_fh>; - chomp $pid; - $pid; - }; - Test::More::ok($pid, "Started apache server #$pid"); + close $warn_fh; + $stashwarnings->add_warning( $warnings ) if $warnings; - push @SERVERS, $pid; - - return (RT->Config->Get('WebURL'), RT::Test::Web->new); + return $app; } -sub apache_server_info { +sub start_plack_server { + local $Test::Builder::Level = $Test::Builder::Level + 1; my $self = shift; - my %res = @_; - - my $bin = $res{'executable'} = $ENV{'RT_TEST_APACHE'} - || $self->find_apache_server - || Test::More::BAIL_OUT("Couldn't find apache server, use RT_TEST_APACHE"); - Test::More::diag("Using '$bin' apache executable for testing") - if $ENV{'TEST_VERBOSE'}; - - my $info = `$bin -V`; - ($res{'version'}) = ($info =~ m{Server\s+version:\s+Apache/(\d+\.\d+)\.}); - Test::More::BAIL_OUT( - "Couldn't figure out version of the server" - ) unless $res{'version'}; + 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); + } - my %opts = ($info =~ m/^\s*-D\s+([A-Z_]+?)(?:="(.*)")$/mg); - %res = (%res, %opts); + require POSIX; + POSIX::setsid() + or die "Can't start a new session: $!"; - $res{'modules'} = [ - map {s/^\s+//; s/\s+$//; $_} - grep $_ !~ /Compiled in modules/i, - split /\r*\n/, `$bin -l` - ]; + # 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(@_)); + }; - return %res; + exit; } -sub apache_mod_perl_server_options { +our $TEST_APP; +sub start_inline_server { + local $Test::Builder::Level = $Test::Builder::Level + 1; my $self = shift; - my %info = %{ shift() }; - my $current = shift; - my %required_modules = ( - '2.2' => [qw(authz_host log_config env alias perl)], - ); - my @mlist = @{ $required_modules{ $info{'version'} } }; + require Test::WWW::Mechanize::PSGI; + unshift @RT::Test::Web::ISA, 'Test::WWW::Mechanize::PSGI'; - $current->{'load_modules'} = ''; - foreach my $mod ( @mlist ) { - next if grep $_ =~ /^(mod_|)$mod\.c$/, @{ $info{'modules'} }; + # 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; - $current->{'load_modules'} .= - "LoadModule ${mod}_module modules/mod_${mod}.so\n"; - } - return; + Test::More::ok(1, "psgi test server ok"); + $TEST_APP = $self->test_app(@_); + return ("http://localhost:$port", RT::Test::Web->new); } -sub apache_fastcgi_server_options { +sub start_apache_server { + local $Test::Builder::Level = $Test::Builder::Level + 1; my $self = shift; - my %info = %{ shift() }; - my $current = shift; - - my %required_modules = ( - '2.2' => [qw(authz_host log_config env alias mime fastcgi)], + 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 ); - my @mlist = @{ $required_modules{ $info{'version'} } }; - - $current->{'load_modules'} = ''; - foreach my $mod ( @mlist ) { - next if grep $_ =~ /^(mod_|)$mod\.c$/, @{ $info{'modules'} }; - - $current->{'load_modules'} .= - "LoadModule ${mod}_module modules/mod_${mod}.so\n"; - } - return; -} + push @SERVERS, $pid; -sub find_apache_server { - my $self = shift; - return $_ foreach grep defined, - map $self->find_executable($_), - qw(httpd apache apache2 apache1); - return undef; + 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'} - || $ENV{'RT_TEST_WEB_HANDLER'} =~/^standalone(?:\+|\z)/; - kill $sig, @SERVERS; + kill 'TERM', @SERVERS; foreach my $pid (@SERVERS) { - waitpid $pid, 0; + 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 { @@ -1225,8 +1704,6 @@ sub file_content { $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}; @@ -1242,80 +1719,67 @@ sub file_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; + return File::Which::which( @_ ); } -sub fork_exec { - my $self = shift; +sub diag { + return unless $ENV{RT_TEST_VERBOSE} || $ENV{TEST_VERBOSE}; + goto \&Test::More::diag; +} - my $pid = fork; - unless ( defined $pid ) { - die "cannot fork: $!"; - } elsif ( !$pid ) { - exec @_; - die "can't exec `". join(' ', @_) ."` program: $!"; - } else { - return $pid; - } +sub parse_mail { + my $mail = shift; + require RT::EmailParser; + my $parser = RT::EmailParser->new; + $parser->ParseMIMEEntityFromScalar( $mail ); + return $parser->Entity; } -sub process_in_file { - my $self = shift; - my %args = ( in => undef, options => undef, @_ ); +sub works { + Test::More::ok($_[0], $_[1] || 'This works'); +} - my $text = $self->file_content( $args{'in'} ); - while ( my ($opt) = ($text =~ /\%\%(.+?)\%\%/) ) { - my $value = $args{'options'}{ lc $opt }; - die "no value for $opt" unless defined $value; +sub fails { + Test::More::ok(!$_[0], $_[1] || 'This should fail'); +} - $text =~ s/\%\%\Q$opt\E\%\%/$value/g; - } +sub plan { + my ($cmd, @args) = @_; + my $builder = RT::Test->builder; - my ($out_fh, $out_conf); - unless ( $args{'out'} ) { - ($out_fh, $out_conf) = tempfile(); - } else { - $out_conf = $args{'out'}; - open( $out_fh, '>', $out_conf ) - or die "couldn't open '$out_conf': $!"; + if ($cmd eq "skip_all") { + $check_warnings_in_end = 0; + } elsif ($cmd eq "tests") { + # Increment the test count for the warnings check + $args[0]++; } - print $out_fh $text; - seek $out_fh, 0, 0; - - return ($out_fh, $out_conf); + $builder->plan($cmd, @args); } -sub parse_mail { - my $mail = shift; - require RT::EmailParser; - my $parser = RT::EmailParser->new; - $parser->ParseMIMEEntityFromScalar( $mail ); - return $parser->Entity; +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 $?; - RT::Test->stop_server; + Test::NoWarnings::had_no_warnings() if $check_warnings_in_end; + + RT::Test->stop_server(1); # not success - if ( !$Test->summary || grep !$_, $Test->summary ) { + if ( !$Test->is_passing ) { $tmp{'directory'}->unlink_on_destroy(0); Test::More::diag( @@ -1325,15 +1789,33 @@ END { } if ( $ENV{RT_TEST_PARALLEL} && $created_new_db ) { + __drop_database(); + } - # Pg doesn't like if you issue a DROP DATABASE while still connected - my $dbh = $RT::Handle->dbh; - $dbh->disconnect if $dbh; - - $dbh = _get_dbh( RT::Handle->SystemDSN, $ENV{RT_DBA_USER}, $ENV{RT_DBA_PASSWORD} ); - RT::Handle->DropDatabase( $dbh, Force => 1 ); - $dbh->disconnect; + # 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;