X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=blobdiff_plain;f=rt%2Flib%2FRT%2FTest.pm;h=31a114e3f8e078991dcc3b38f6ff01b02c57b2b7;hp=0d6da1b9e718393e9a5853b35ca076350e2741e9;hb=187086c479a09629b7d180eec513fb7657f4e291;hpb=43a06151e47d2c59b833cbd8c26d97865ee850b6 diff --git a/rt/lib/RT/Test.pm b/rt/lib/RT/Test.pm index 0d6da1b9e..31a114e3f 100644 --- a/rt/lib/RT/Test.pm +++ b/rt/lib/RT/Test.pm @@ -2,7 +2,7 @@ # # COPYRIGHT: # -# This software is Copyright (c) 1996-2012 Best Practical Solutions, LLC +# This software is Copyright (c) 1996-2018 Best Practical Solutions, LLC # # # (Except where explicitly superseded by other copyright notices) @@ -51,15 +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 @EXPORT = qw(is_empty diag parse_mail works fails); +our @EXPORT = qw(is_empty diag parse_mail works fails plan done_testing); my %tmp = ( directory => undef, @@ -94,20 +110,28 @@ problem in Perl that hides the top-level optree from L. 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 = @_; + 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'} ) { - $class->builder->plan(skip_all => $args{'skip_all'}); + plan(skip_all => $args{'skip_all'}); } else { $class->builder->no_plan unless $class->builder->has_plan; @@ -117,6 +141,8 @@ sub import { 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; @@ -127,26 +153,27 @@ sub import { $class->bootstrap_config( %args ); use RT; + RT::LoadConfig; - if (RT->Config->Get('DevelMode')) { require Module::Refresh; } + RT::InitPluginPaths(); + RT::InitClasses(); - $class->bootstrap_db( %args ); + RT::I18N->Init(); - RT::InitPluginPaths(); + $class->set_config_wrapper; + $class->bootstrap_db( %args ); __reconnect_rt() unless $args{nodb}; - RT::InitClasses(); - RT::InitLogging(); + __init_logging(); RT->Plugins; - RT::I18N->Init(); RT->Config->PostLoadCheck; - $class->set_config_wrapper; + $class->encode_output; my $screen_logger = $RT::Logger->remove( 'screen' ); require Log::Dispatch::Perl; @@ -167,13 +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 their diag so we can redefine it without warning + # 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); } @@ -270,8 +306,9 @@ sub bootstrap_config { Set( \$WebDomain, "localhost"); Set( \$WebPort, $port); Set( \$WebPath, ""); -Set( \@LexiconLanguages, qw(en zh_TW fr ja)); +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"; @@ -280,9 +317,15 @@ Set( \$RTAddressRegexp , qr/^bad_re_that_doesnt_match\$/i); 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'} ) { @@ -343,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: $!"; + 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 @@ -364,34 +457,20 @@ sub set_config_wrapper { my @caller = caller(1); # preserve list context @caller = caller(0) unless @caller; - if ( ($caller[1]||'') =~ /\.t$/) { - 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: $!"; - require Data::Dumper; - local $Data::Dumper::Terse = 1; - my $dump = Data::Dumper::Dumper([@_[2 .. $#_]]); - $dump =~ s/;\s+$//; - print $fh - "\nSet(${sigil}${name}, \@{". $dump ."});\n1;\n"; - close $fh; - - if ( @SERVERS ) { - warn "you're changing config option in a test file" - ." when server is active"; - } - } + return 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 = @_; @@ -409,15 +488,24 @@ sub bootstrap_db { $args{$forceopt}=1; } - return if $args{nodb}; + # 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'); + + if ($db_type eq "SQLite") { + RT->Config->WriteSet( DatabaseName => File::Spec->catfile( $self->temp_directory, "rt4test" ) ); + } + __create_database(); __reconnect_rt('as dba'); $RT::Handle->InsertSchema; $RT::Handle->InsertACL unless $db_type eq 'Oracle'; - RT->InitLogging; + __init_logging(); __reconnect_rt(); $RT::Handle->InsertInitialData @@ -452,7 +540,7 @@ sub bootstrap_plugins_paths { 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->(@_); @@ -556,6 +644,13 @@ sub __drop_database { 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; } @@ -592,6 +687,23 @@ sub __disconnect_rt { 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 @@ -633,7 +745,10 @@ sub load_or_create_user { 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; @@ -651,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 @@ -710,7 +858,7 @@ sub create_tickets { while ( @data ) { my %args = %{ shift @data }; $args{$_} = $res[ $args{$_} ]->id foreach - grep $args{ $_ }, keys %RT::Ticket::LINKTYPEMAP; + grep $args{ $_ }, keys %RT::Link::TYPEMAP; push @res, $self->create_ticket( %$defaults, %args ); } return @res; @@ -722,7 +870,10 @@ sub create_ticket { my $self = shift; my %args = @_; - if ($args{Queue} && $args{Queue} =~ /\D/) { + 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; @@ -733,12 +884,28 @@ sub create_ticket { if ( my $content = delete $args{'Content'} ) { $args{'MIMEObj'} = MIME::Entity->build( - From => $args{'Requestor'}, - Subject => $args{'Subject'}, - Data => $content, + From => Encode::encode( "UTF-8", $args{'Requestor'} ), + Subject => RT::Interface::Email::EncodeToMIME( String => $args{'Subject'} ), + Type => (defined $args{ContentType} ? $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" ) @@ -797,7 +964,11 @@ sub load_or_create_custom_field { my %args = ( Disabled => 0, @_ ); 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"; } @@ -835,7 +1006,7 @@ sub store_rights { 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; } @@ -868,7 +1039,7 @@ sub set_rights { $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; @@ -887,16 +1058,16 @@ sub add_rights { if ( $principal =~ /^(everyone|(?:un)?privileged)$/i ) { $principal = RT::Group->new( RT->SystemUser ); $principal->LoadSystemInternalGroup($1); - } elsif ( $principal =~ /^(Owner|Requestor|(?:Admin)?Cc)$/i ) { + } else { + my $type = $principal; $principal = RT::Group->new( RT->SystemUser ); - $principal->LoadByCols( - Domain => (ref($e->{'Object'})||'RT::System').'-Role', - Type => $1, - ref($e->{'Object'})? (Instance => $e->{'Object'}->id): (), + $principal->LoadRoleGroup( + Object => ($e->{'Object'} || RT->System), + Name => $type ); - } else { - die "principal is not an object, but also is not name of a system group"; } + 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') ) { @@ -912,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; @@ -950,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; @@ -1010,12 +1224,20 @@ sub send_via_mailgate { 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'; @@ -1026,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; @@ -1033,6 +1256,7 @@ sub close_mailgate_ok { } sub mailsent_ok { + local $Test::Builder::Level = $Test::Builder::Level + 1; my $class = shift; my $expected = shift; @@ -1063,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 @@ -1096,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)) { @@ -1121,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 = GnuPG::Interface->new(); - my %opt = RT->Config->Get('GnuPGOptions'); - $gnupg->options->hash_init( - RT::Crypt::GnuPG::_PrepareGnuPGOptions( %opt ), - meta_interactive => 0, - ); - - my %handle; - my $handles = GnuPG::Handles->new( - stdin => ($handle{'input'} = IO::Handle->new()), - stdout => ($handle{'output'} = IO::Handle->new()), - stderr => ($handle{'error'} = IO::Handle->new()), - logger => ($handle{'logger'} = IO::Handle->new()), - status => ($handle{'status'} = IO::Handle->new()), - command => ($handle{'command'} = IO::Handle->new()), - ); - - eval { - local $SIG{'CHLD'} = 'DEFAULT'; - local @ENV{'LANG', 'LC_ALL'} = ('C', 'C'); - my $pid = $gnupg->wrap_call( - handles => $handles, - commands => ['--lsign-key'], - command_args => [$key], - ); - close $handle{'input'}; - while ( my $str = readline $handle{'status'} ) { - if ( $str =~ /^\[GNUPG:\]\s*GET_BOOL sign_uid\..*/ ) { - print { $handle{'command'} } "y\n"; + 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 = GnuPG::Interface->new(); - my %opt = RT->Config->Get('GnuPGOptions'); - $gnupg->options->hash_init( - RT::Crypt::GnuPG::_PrepareGnuPGOptions( %opt ), - meta_interactive => 0, - ); - - my %handle; - my $handles = GnuPG::Handles->new( - stdin => ($handle{'input'} = IO::Handle->new()), - stdout => ($handle{'output'} = IO::Handle->new()), - stderr => ($handle{'error'} = IO::Handle->new()), - logger => ($handle{'logger'} = IO::Handle->new()), - status => ($handle{'status'} = IO::Handle->new()), - command => ($handle{'command'} = IO::Handle->new()), - ); - - eval { - local $SIG{'CHLD'} = 'DEFAULT'; - local @ENV{'LANG', 'LC_ALL'} = ('C', 'C'); - my $pid = $gnupg->wrap_call( - handles => $handles, - commands => ['--edit-key'], - command_args => [$key], - ); - close $handle{'input'}; - - my $done = 0; - while ( my $str = readline $handle{'status'} ) { - if ( $str =~ /^\[GNUPG:\]\s*\QGET_LINE keyedit.prompt/ ) { - if ( $done ) { - print { $handle{'command'} } "quit\n"; - } else { - print { $handle{'command'} } "trust\n"; + 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 { @@ -1276,8 +1521,10 @@ sub started_ok { require RT::Test::Web; - if ($rttest_opt{nodb}) { - die "you are trying to use a test web server without db, try use noinitialdata => 1 instead"; + 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."; } @@ -1298,26 +1545,52 @@ sub test_app { my $self = shift; my %server_opt = @_; - require RT::Interface::Web::Handler; - my $app = RT::Interface::Web::Handler->PSGIApp; + 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; - $app = Plack::Middleware::Test::StashWarnings->wrap($app); + 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 => sub { + 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; @@ -1346,15 +1619,14 @@ sub start_plack_server { my $Tester = Test::Builder->new; $Tester->ok(1, "started plack server ok"); - __reconnect_rt(); + __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: $!"; - } + 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 @@ -1367,6 +1639,7 @@ sub start_plack_server { our $TEST_APP; sub start_inline_server { + local $Test::Builder::Level = $Test::Builder::Level + 1; my $self = shift; require Test::WWW::Mechanize::PSGI; @@ -1375,6 +1648,8 @@ sub start_inline_server { # 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(@_); @@ -1382,6 +1657,7 @@ sub start_inline_server { } sub start_apache_server { + local $Test::Builder::Level = $Test::Builder::Level + 1; my $self = shift; my %server_opt = @_; $server_opt{variant} ||= 'mod_perl'; @@ -1405,9 +1681,7 @@ sub stop_server { my $in_end = shift; return unless @SERVERS; - my $sig = 'TERM'; - $sig = 'INT' if $ENV{'RT_TEST_WEB_HANDLER'} eq "plack"; - kill $sig, @SERVERS; + kill 'TERM', @SERVERS; foreach my $pid (@SERVERS) { if ($ENV{RT_TEST_WEB_HANDLER} =~ /^apache/) { sleep 1 while kill 0, $pid; @@ -1430,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}; @@ -1446,18 +1718,9 @@ sub file_content { } sub find_executable { - my $self = shift; - my $name = shift; + my ( $self, $exe ) = @_; - 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( $exe ); } sub diag { @@ -1470,7 +1733,9 @@ sub parse_mail { require RT::EmailParser; my $parser = RT::EmailParser->new; $parser->ParseMIMEEntityFromScalar( $mail ); - return $parser->Entity; + my $entity = $parser->Entity; + $entity->{__store_link_to_object_to_avoid_early_cleanup} = $parser; + return $entity; } sub works { @@ -1481,15 +1746,38 @@ 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