#
# COPYRIGHT:
#
-# This software is Copyright (c) 1996-2012 Best Practical Solutions, LLC
+# This software is Copyright (c) 1996-2015 Best Practical Solutions, LLC
# <sales@bestpractical.com>
#
# (Except where explicitly superseded by other copyright notices)
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,
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;
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_config( %args );
use RT;
- RT::LoadConfig;
- if (RT->Config->Get('DevelMode')) { require Module::Refresh; }
+ RT::LoadConfig;
RT::InitPluginPaths();
RT::InitClasses();
+ RT::I18N->Init();
+
+ $class->set_config_wrapper;
$class->bootstrap_db( %args );
__reconnect_rt()
unless $args{nodb};
- 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;
$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);
}
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";
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 <<END;
Set( \$LogToSyslog , undef);
-Set( \$LogToScreen , "warning");
+Set( \$LogToSTDERR , "warning");
Set( \$LogToFile, 'debug' );
Set( \$LogDir, q{$tmp{'directory'}} );
Set( \$LogToFileNamed, 'rt.debug.log' );
my $old_sub = \&RT::Config::Set;
no warnings 'redefine';
+
+ *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
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 = @_;
}
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
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->(@_);
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
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;
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
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;
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;
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 => $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" )
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";
}
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;
}
$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;
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') ) {
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<html> or
+C<text>.
+
+=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<switch_template_to> 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;
$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;
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';
sub close_mailgate_ok {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
my $class = shift;
my $mail = shift;
close $mail;
}
sub mailsent_ok {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
my $class = shift;
my $expected = shift;
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<RT::Scrip> object or ID as the first argument and an arrayref of
+L<RT::Queue> objects and/or Queue IDs as the second argument.
+
+The scrip's applications (L<RT::ObjectScrip> 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<not> 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. C<RT::Test::get_relocatable_dir(File::Spec->updir(), '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
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)) {
$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 {
}
require Plack::Middleware::Test::StashWarnings;
- my $stashwarnings = Plack::Middleware::Test::StashWarnings->new;
+ 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';
}
}
sub start_plack_server {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
my $self = shift;
require Plack::Loader;
}
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
our $TEST_APP;
sub start_inline_server {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
my $self = shift;
require 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(@_);
}
sub start_apache_server {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
my $self = shift;
my %server_opt = @_;
$server_opt{variant} ||= 'mod_perl';
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;
$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};
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 diag {
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
projects / freeside.git / blobdiff