[usit-rt.git] / lib / RT / Test.pm

# BEGIN BPS TAGGED BLOCK {{{
#
# COPYRIGHT:
#
# This software is Copyright (c) 1996-2013 Best Practical Solutions, LLC
#                                          <sales@bestpractical.com>
#
# (Except where explicitly superseded by other copyright notices)
#
#
# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# been provided with this software, but in any event can be snarfed
# from www.gnu.org.
#
# This work is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
# 02110-1301 or visit their web page on the internet at
# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
#
#
# CONTRIBUTION SUBMISSION POLICY:
#
# (The following paragraph is not intended to limit the rights granted
# to you to modify and distribute this software under the terms of
# the GNU General Public License and is only of importance to you if
# you choose to contribute your changes and enhancements to the
# community by submitting them to Best Practical Solutions, LLC.)
#
# By intentionally submitting any modifications, corrections or
# derivatives to this work, or any other work intended for use with
# Request Tracker, to Best Practical Solutions, LLC, you confirm that
# you are the copyright holder for those contributions and you grant
# Best Practical Solutions,  LLC a nonexclusive, worldwide, irrevocable,
# royalty-free, perpetual, license to use, copy, create derivative
# works based on those contributions, and sublicense and distribute
# those contributions and any derivatives thereof.
#
# END BPS TAGGED BLOCK }}}

package RT::Test;

use strict;
use warnings;


use base 'Test::More';

# 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;

our @EXPORT = qw(is_empty diag parse_mail works fails plan done_testing);

my %tmp = (
    directory => undef,
    config    => {
        RT => undef,
        apache => undef,
    },
    mailbox   => undef,
);

my %rttest_opt;

=head1 NAME

RT::Test - RT Testing

=head1 NOTES

=head2 COVERAGE

To run the rt test suite with coverage support, install L<Devel::Cover> and run:

    make test RT_DBA_USER=.. RT_DBA_PASSWORD=.. HARNESS_PERL_SWITCHES=-MDevel::Cover
    cover -ignore_re '^var/mason_data/' -ignore_re '^t/'

The coverage tests have DevelMode turned off, and have
C<named_component_subs> enabled for L<HTML::Mason> to avoid an optimizer
problem in Perl that hides the top-level optree from L<Devel::Cover>.

=cut

our $port;
our @SERVERS;

BEGIN {
    delete $ENV{$_} for qw/LANGUAGE LC_ALL LC_MESSAGES LANG/;
    $ENV{LANG} = "C";
};

sub import {
    my $class = shift;
    my %args = %rttest_opt = @_;

    $rttest_opt{'nodb'} = $args{'nodb'} = 1 if $^C;

    # Spit out a plan (if we got one) *before* we load modules
    if ( $args{'tests'} ) {
        plan( tests => $args{'tests'} )
          unless $args{'tests'} eq 'no_declare';
    }
    elsif ( exists $args{'tests'} ) {
        # do nothing if they say "tests => undef" - let them make the plan
    }
    elsif ( $args{'skip_all'} ) {
        plan(skip_all => $args{'skip_all'});
    }
    else {
        $class->builder->no_plan unless $class->builder->has_plan;
    }

    push @{ $args{'plugins'} ||= [] }, @{ $args{'requires'} }
        if $args{'requires'};
    push @{ $args{'plugins'} ||= [] }, $args{'testing'}
        if $args{'testing'};

    $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();

    $class->bootstrap_db( %args );

    __reconnect_rt()
        unless $args{nodb};

    __init_logging();

    RT->Plugins;

    RT::I18N->Init();
    RT->Config->PostLoadCheck;

    $class->set_config_wrapper;

    my $screen_logger = $RT::Logger->remove( 'screen' );
    require Log::Dispatch::Perl;
    $RT::Logger->add( Log::Dispatch::Perl->new
                      ( name      => 'rttest',
                        min_level => $screen_logger->min_level,
                        action => { error     => 'warn',
                                    critical  => 'warn' } ) );

    # XXX: this should really be totally isolated environment so we
    # can parallelize and be sane
    mkpath [ $RT::MasonSessionDir ]
        if RT->Config->Get('DatabaseType');

    my $level = 1;
    while ( my ($package) = caller($level-1) ) {
        last unless $package =~ /Test/;
        $level++;
    }

    Test::More->export_to_level($level);
    Test::NoWarnings->export_to_level($level);

    # Blow away symbols we redefine to avoid warnings.
    # better than "no warnings 'redefine'" because we might accidentally
    # suppress a mistaken redefinition
    no strict 'refs';
    delete ${ caller($level) . '::' }{diag};
    delete ${ caller($level) . '::' }{plan};
    delete ${ caller($level) . '::' }{done_testing};
    __PACKAGE__->export_to_level($level);
}

sub is_empty($;$) {
    my ($v, $d) = shift;
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    return Test::More::ok(1, $d) unless defined $v;
    return Test::More::ok(1, $d) unless length $v;
    return Test::More::is($v, '', $d);
}

my $created_new_db;    # have we created new db? mainly for parallel testing

sub db_requires_no_dba {
    my $self = shift;
    my $db_type = RT->Config->Get('DatabaseType');
    return 1 if $db_type eq 'SQLite';
}

sub bootstrap_port {
    my $class = shift;

    my %ports;

    # Determine which ports are in use
    use Fcntl qw(:DEFAULT :flock);
    my $portfile = "$tmp{'directory'}/../ports";
    sysopen(PORTS, $portfile, O_RDWR|O_CREAT)
        or die "Can't write to ports file $portfile: $!";
    flock(PORTS, LOCK_EX)
        or die "Can't write-lock ports file $portfile: $!";
    $ports{$_}++ for split ' ', join("",<PORTS>);

    # Pick a random port, checking that the port isn't in our in-use
    # list, and that something isn't already listening there.
    {
        $port = 1024 + int rand(10_000) + $$ % 1024;
        redo if $ports{$port};

        # There is a race condition in here, where some non-RT::Test
        # process claims the port after we check here but before our
        # server binds.  However, since we mostly care about race
        # conditions with ourselves under high concurrency, this is
        # generally good enough.
        my $paddr = sockaddr_in( $port, inet_aton('localhost') );
        socket( SOCK, PF_INET, SOCK_STREAM, getprotobyname('tcp') )
            or die "socket: $!";
        if ( connect( SOCK, $paddr ) ) {
            close(SOCK);
            redo;
        }
        close(SOCK);
    }

    $ports{$port}++;

    # Write back out the in-use ports
    seek(PORTS, 0, 0);
    truncate(PORTS, 0);
    print PORTS "$_\n" for sort {$a <=> $b} keys %ports;
    close(PORTS) or die "Can't close ports file: $!";
}

sub bootstrap_tempdir {
    my $self = shift;
    my ($test_dir, $test_file) = ('t', '');

    if (File::Spec->rel2abs($0) =~ m{(?:^|[\\/])(x?t)[/\\](.*)}) {
        $test_dir  = $1;
        $test_file = "$2-";
        $test_file =~ s{[/\\]}{-}g;
    }

    my $dir_name = File::Spec->rel2abs("$test_dir/tmp");
    mkpath( $dir_name );
    return $tmp{'directory'} = File::Temp->newdir(
        "${test_file}XXXXXXXX",
        DIR => $dir_name
    );
}

sub bootstrap_config {
    my $self = shift;
    my %args = @_;

    $tmp{'config'}{'RT'} = File::Spec->catfile(
        "$tmp{'directory'}", 'RT_SiteConfig.pm'
    );
    open( my $config, '>', $tmp{'config'}{'RT'} )
        or die "Couldn't open $tmp{'config'}{'RT'}: $!";

    my $dbname = $ENV{RT_TEST_PARALLEL}? "rt4test_$port" : "rt4test";
    print $config qq{
Set( \$WebDomain, "localhost");
Set( \$WebPort,   $port);
Set( \$WebPath,   "");
Set( \@LexiconLanguages, qw(en zh_TW fr ja));
Set( \$RTAddressRegexp , qr/^bad_re_that_doesnt_match\$/i);
};
    if ( $ENV{'RT_TEST_DB_SID'} ) { # oracle case
        print $config "Set( \$DatabaseName , '$ENV{'RT_TEST_DB_SID'}' );\n";
        print $config "Set( \$DatabaseUser , '$dbname');\n";
    } else {
        print $config "Set( \$DatabaseName , '$dbname');\n";
        print $config "Set( \$DatabaseUser , 'u${dbname}');\n";
    }
    if ( $ENV{'RT_TEST_DB_HOST'} ) {
        print $config "Set( \$DatabaseHost , '$ENV{'RT_TEST_DB_HOST'}');\n";
    }

    if ( $args{'plugins'} ) {
        print $config "Set( \@Plugins, qw(". join( ' ', @{ $args{'plugins'} } ) .") );\n";

        my $plugin_data = File::Spec->rel2abs("t/data/plugins");
        print $config qq[\$RT::PluginPath = "$plugin_data";\n];
    }

    if ( $INC{'Devel/Cover.pm'} ) {
        print $config "Set( \$DevelMode, 0 );\n";
    }
    elsif ( $ENV{RT_TEST_DEVEL} ) {
        print $config "Set( \$DevelMode, 1 );\n";
    }
    else {
        print $config "Set( \$DevelMode, 0 );\n";
    }

    $self->bootstrap_logging( $config );

    # set mail catcher
    my $mail_catcher = $tmp{'mailbox'} = File::Spec->catfile(
        $tmp{'directory'}->dirname, 'mailbox.eml'
    );
    print $config <<END;
Set( \$MailCommand, sub {
    my \$MIME = shift;

    open( my \$handle, '>>', '$mail_catcher' )
        or die "Unable to open '$mail_catcher' for appending: \$!";

    \$MIME->print(\$handle);
    print \$handle "%% split me! %%\n";
    close \$handle;
} );
END

    $self->bootstrap_more_config($config, \%args);

    print $config $args{'config'} if $args{'config'};

    print $config "\n1;\n";
    $ENV{'RT_SITE_CONFIG'} = $tmp{'config'}{'RT'};
    close $config;

    return $config;
}

sub bootstrap_more_config { }

sub bootstrap_logging {
    my $self = shift;
    my $config = shift;

    # prepare file for logging
    $tmp{'log'}{'RT'} = File::Spec->catfile(
        "$tmp{'directory'}", 'rt.debug.log'
    );
    open( my $fh, '>', $tmp{'log'}{'RT'} )
        or die "Couldn't open $tmp{'config'}{'RT'}: $!";
    # make world writable so apache under different user
    # can write into it
    chmod 0666, $tmp{'log'}{'RT'};

    print $config <<END;
Set( \$LogToSyslog , undef);
Set( \$LogToScreen , "warning");
Set( \$LogToFile, 'debug' );
Set( \$LogDir, q{$tmp{'directory'}} );
Set( \$LogToFileNamed, 'rt.debug.log' );
END
}

sub set_config_wrapper {
    my $self = shift;

    my $old_sub = \&RT::Config::Set;
    no warnings 'redefine';
    *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;

        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 $old_sub->(@_);
    };
}

sub bootstrap_db {
    my $self = shift;
    my %args = @_;

    unless (defined $ENV{'RT_DBA_USER'} && defined $ENV{'RT_DBA_PASSWORD'}) {
        Test::More::BAIL_OUT(
            "RT_DBA_USER and RT_DBA_PASSWORD environment variables need"
            ." to be set in order to run 'make test'"
        ) unless $self->db_requires_no_dba;
    }

    require RT::Handle;
    if (my $forceopt = $ENV{RT_TEST_FORCE_OPT}) {
        Test::More::diag "forcing $forceopt";
        $args{$forceopt}=1;
    }

    # Short-circuit the rest of ourselves if we don't want a db
    if ($args{nodb}) {
        __drop_database();
        return;
    }

    my $db_type = RT->Config->Get('DatabaseType');
    __create_database();
    __reconnect_rt('as dba');
    $RT::Handle->InsertSchema;
    $RT::Handle->InsertACL unless $db_type eq 'Oracle';

    __init_logging();
    __reconnect_rt();

    $RT::Handle->InsertInitialData
        unless $args{noinitialdata};

    $RT::Handle->InsertData( $RT::EtcPath . "/initialdata" )
        unless $args{noinitialdata} or $args{nodata};

    $self->bootstrap_plugins_db( %args );
}

sub bootstrap_plugins_paths {
    my $self = shift;
    my %args = @_;

    return unless $args{'plugins'};
    my @plugins = @{ $args{'plugins'} };

    my $cwd;
    if ( $args{'testing'} ) {
        require Cwd;
        $cwd = Cwd::getcwd();
    }

    require RT::Plugin;
    my $old_func = \&RT::Plugin::_BasePath;
    no warnings 'redefine';
    *RT::Plugin::_BasePath = sub {
        my $name = $_[0]->{'name'};

        return $cwd if $args{'testing'} && $name eq $args{'testing'};

        if ( grep $name eq $_, @plugins ) {
            my $variants = join "(?:|::|-|_)", map "\Q$_\E", split /::/, $name;
            my ($path) = map $ENV{$_}, grep /^CHIMPS_(?:$variants).*_ROOT$/i, keys %ENV;
            return $path if $path;
        }
        return $old_func->(@_);
    };
}

sub bootstrap_plugins_db {
    my $self = shift;
    my %args = @_;

    return unless $args{'plugins'};

    require File::Spec;

    my @plugins = @{ $args{'plugins'} };
    foreach my $name ( @plugins ) {
        my $plugin = RT::Plugin->new( name => $name );
        Test::More::diag( "Initializing DB for the $name plugin" )
            if $ENV{'TEST_VERBOSE'};

        my $etc_path = $plugin->Path('etc');
        Test::More::diag( "etc path of the plugin is '$etc_path'" )
            if $ENV{'TEST_VERBOSE'};

        unless ( -e $etc_path ) {
            # We can't tell if the plugin has no data, or we screwed up the etc/ path
            Test::More::ok(1, "There is no etc dir: no schema" );
            Test::More::ok(1, "There is no etc dir: no ACLs" );
            Test::More::ok(1, "There is no etc dir: no data" );
            next;
        }

        __reconnect_rt('as dba');

        { # schema
            my ($ret, $msg) = $RT::Handle->InsertSchema( undef, $etc_path );
            Test::More::ok($ret || $msg =~ /^Couldn't find schema/, "Created schema: ".($msg||''));
        }

        { # ACLs
            my ($ret, $msg) = $RT::Handle->InsertACL( undef, $etc_path );
            Test::More::ok($ret || $msg =~ /^Couldn't find ACLs/, "Created ACL: ".($msg||''));
        }

        # data
        my $data_file = File::Spec->catfile( $etc_path, 'initialdata' );
        if ( -e $data_file ) {
            __reconnect_rt();
            my ($ret, $msg) = $RT::Handle->InsertData( $data_file );;
            Test::More::ok($ret, "Inserted data".($msg||''));
        } else {
            Test::More::ok(1, "There is no data file" );
        }
    }
    __reconnect_rt();
}

sub _get_dbh {
    my ($dsn, $user, $pass) = @_;
    if ( $dsn =~ /Oracle/i ) {
        $ENV{'NLS_LANG'} = "AMERICAN_AMERICA.AL32UTF8";
        $ENV{'NLS_NCHAR'} = "AL32UTF8";
    }
    my $dbh = DBI->connect(
        $dsn, $user, $pass,
        { RaiseError => 0, PrintError => 1 },
    );
    unless ( $dbh ) {
        my $msg = "Failed to connect to $dsn as user '$user': ". $DBI::errstr;
        print STDERR $msg; exit -1;
    }
    return $dbh;
}

sub __create_database {
    # bootstrap with dba cred
    my $dbh = _get_dbh(
        RT::Handle->SystemDSN,
        $ENV{RT_DBA_USER}, $ENV{RT_DBA_PASSWORD}
    );

    unless ( $ENV{RT_TEST_PARALLEL} ) {
        # already dropped db in parallel tests, need to do so for other cases.
        __drop_database( $dbh );

    }
    RT::Handle->CreateDatabase( $dbh );
    $dbh->disconnect;
    $created_new_db++;
}

sub __drop_database {
    my $dbh = shift;

    # Pg doesn't like if you issue a DROP DATABASE while still connected
    # it's still may fail if web-server is out there and holding a connection
    __disconnect_rt();

    my $my_dbh = $dbh? 0 : 1;
    $dbh ||= _get_dbh(
        RT::Handle->SystemDSN,
        $ENV{RT_DBA_USER}, $ENV{RT_DBA_PASSWORD}
    );

    # We ignore errors intentionally by not checking the return value of
    # DropDatabase below, so let's also suppress DBI's printing of errors when
    # we overzealously drop.
    local $dbh->{PrintError} = 0;
    local $dbh->{PrintWarn} = 0;

    RT::Handle->DropDatabase( $dbh );
    $dbh->disconnect if $my_dbh;
}

sub __reconnect_rt {
    my $as_dba = shift;
    __disconnect_rt();

    # look at %DBIHandle and $PrevHandle in DBIx::SB::Handle for explanation
    $RT::Handle = RT::Handle->new;
    $RT::Handle->dbh( undef );
    $RT::Handle->Connect(
        $as_dba
        ? (User => $ENV{RT_DBA_USER}, Password => $ENV{RT_DBA_PASSWORD})
        : ()
    );
    $RT::Handle->PrintError;
    $RT::Handle->dbh->{PrintError} = 1;
    return $RT::Handle->dbh;
}

sub __disconnect_rt {
    # look at %DBIHandle and $PrevHandle in DBIx::SB::Handle for explanation
    $RT::Handle->dbh->disconnect if $RT::Handle and $RT::Handle->dbh;

    %DBIx::SearchBuilder::Handle::DBIHandle = ();
    $DBIx::SearchBuilder::Handle::PrevHandle = undef;

    $RT::Handle = undef;

    delete $RT::System->{attributes};

    DBIx::SearchBuilder::Record::Cachable->FlushCache
          if DBIx::SearchBuilder::Record::Cachable->can("FlushCache");
}

sub __init_logging {
    my $filter;
    {
        # We use local to ensure that the $filter we grab is from InitLogging
        # and not the handler generated by a previous call to this function
        # itself.
        local $SIG{__WARN__};
        RT::InitLogging();
        $filter = $SIG{__WARN__};
    }
    $SIG{__WARN__} = sub {
        if ($filter) {
            my $status = $filter->(@_);
            if ($status and $status eq 'IGNORE') {
                return; # pretend the bad dream never happened
            }
        }
        # Avoid reporting this anonymous call frame as the source of the warning.
        goto &$Test_NoWarnings_Catcher;
    };
}


=head1 UTILITIES

=head2 load_or_create_user

=cut

sub load_or_create_user {
    my $self = shift;
    my %args = ( Privileged => 1, Disabled => 0, @_ );
    
    my $MemberOf = delete $args{'MemberOf'};
    $MemberOf = [ $MemberOf ] if defined $MemberOf && !ref $MemberOf;
    $MemberOf ||= [];

    my $obj = RT::User->new( RT->SystemUser );
    if ( $args{'Name'} ) {
        $obj->LoadByCols( Name => $args{'Name'} );
    } elsif ( $args{'EmailAddress'} ) {
        $obj->LoadByCols( EmailAddress => $args{'EmailAddress'} );
    } else {
        die "Name or EmailAddress is required";
    }
    if ( $obj->id ) {
        # cool
        $obj->SetPrivileged( $args{'Privileged'} || 0 )
            if ($args{'Privileged'}||0) != ($obj->Privileged||0);
        $obj->SetDisabled( $args{'Disabled'} || 0 )
            if ($args{'Disabled'}||0) != ($obj->Disabled||0);
    } else {
        my ($val, $msg) = $obj->Create( %args );
        die "$msg" unless $val;
    }

    # clean group membership
    {
        require RT::GroupMembers;
        my $gms = RT::GroupMembers->new( RT->SystemUser );
        my $groups_alias = $gms->Join(
            FIELD1 => 'GroupId', TABLE2 => 'Groups', FIELD2 => 'id',
        );
        $gms->Limit( ALIAS => $groups_alias, FIELD => 'Domain', VALUE => 'UserDefined' );
        $gms->Limit( FIELD => 'MemberId', VALUE => $obj->id );
        while ( my $group_member_record = $gms->Next ) {
            $group_member_record->Delete;
        }
    }

    # add new user to groups
    foreach ( @$MemberOf ) {
        my $group = RT::Group->new( RT::SystemUser() );
        $group->LoadUserDefinedGroup( $_ );
        die "couldn't load group '$_'" unless $group->id;
        $group->AddMember( $obj->id );
    }

    return $obj;
}

=head2 load_or_create_queue

=cut

sub load_or_create_queue {
    my $self = shift;
    my %args = ( Disabled => 0, @_ );
    my $obj = RT::Queue->new( RT->SystemUser );
    if ( $args{'Name'} ) {
        $obj->LoadByCols( Name => $args{'Name'} );
    } else {
        die "Name is required";
    }
    unless ( $obj->id ) {
        my ($val, $msg) = $obj->Create( %args );
        die "$msg" unless $val;
    } else {
        my @fields = qw(CorrespondAddress CommentAddress);
        foreach my $field ( @fields ) {
            next unless exists $args{ $field };
            next if $args{ $field } eq ($obj->$field || '');
            
            no warnings 'uninitialized';
            my $method = 'Set'. $field;
            my ($val, $msg) = $obj->$method( $args{ $field } );
            die "$msg" unless $val;
        }
    }

    return $obj;
}

sub delete_queue_watchers {
    my $self = shift;
    my @queues = @_;

    foreach my $q ( @queues ) {
        foreach my $t (qw(Cc AdminCc) ) {
            $q->DeleteWatcher( Type => $t, PrincipalId => $_->MemberId )
                foreach @{ $q->$t()->MembersObj->ItemsArrayRef };
        }
    }
}

sub create_tickets {
    local $Test::Builder::Level = $Test::Builder::Level + 1;

    my $self = shift;
    my $defaults = shift;
    my @data = @_;
    @data = sort { rand(100) <=> rand(100) } @data
        if delete $defaults->{'RandomOrder'};

    $defaults->{'Queue'} ||= 'General';

    my @res = ();
    while ( @data ) {
        my %args = %{ shift @data };
        $args{$_} = $res[ $args{$_} ]->id foreach
            grep $args{ $_ }, keys %RT::Ticket::LINKTYPEMAP;
        push @res, $self->create_ticket( %$defaults, %args );
    }
    return @res;
}

sub create_ticket {
    local $Test::Builder::Level = $Test::Builder::Level + 1;

    my $self = shift;
    my %args = @_;

    if ($args{Queue} && $args{Queue} =~ /\D/) {
        my $queue = RT::Queue->new(RT->SystemUser);
        if (my $id = $queue->Load($args{Queue}) ) {
            $args{Queue} = $id;
        } else {
            die ("Error: Invalid queue $args{Queue}");
        }
    }

    if ( my $content = delete $args{'Content'} ) {
        $args{'MIMEObj'} = MIME::Entity->build(
            From    => $args{'Requestor'},
            Subject => $args{'Subject'},
            Data    => $content,
        );
    }

    my $ticket = RT::Ticket->new( RT->SystemUser );
    my ( $id, undef, $msg ) = $ticket->Create( %args );
    Test::More::ok( $id, "ticket created" )
        or Test::More::diag("error: $msg");

    # hackish, but simpler
    if ( $args{'LastUpdatedBy'} ) {
        $ticket->__Set( Field => 'LastUpdatedBy', Value => $args{'LastUpdatedBy'} );
    }


    for my $field ( keys %args ) {
        #TODO check links and watchers

        if ( $field =~ /CustomField-(\d+)/ ) {
            my $cf = $1;
            my $got = join ',', sort map $_->Content,
                @{ $ticket->CustomFieldValues($cf)->ItemsArrayRef };
            my $expected = ref $args{$field}
                ? join( ',', sort @{ $args{$field} } )
                : $args{$field};
            Test::More::is( $got, $expected, 'correct CF values' );
        }
        else {
            next if ref $args{$field};
            next unless $ticket->can($field) or $ticket->_Accessible($field,"read");
            next if ref $ticket->$field();
            Test::More::is( $ticket->$field(), $args{$field}, "$field is correct" );
        }
    }

    return $ticket;
}

sub delete_tickets {
    my $self = shift;
    my $query = shift;
    my $tickets = RT::Tickets->new( RT->SystemUser );
    if ( $query ) {
        $tickets->FromSQL( $query );
    }
    else {
        $tickets->UnLimit;
    }
    while ( my $ticket = $tickets->Next ) {
        $ticket->Delete;
    }
}

=head2 load_or_create_custom_field

=cut

sub load_or_create_custom_field {
    my $self = shift;
    my %args = ( Disabled => 0, @_ );
    my $obj = RT::CustomField->new( RT->SystemUser );
    if ( $args{'Name'} ) {
        $obj->LoadByName( Name => $args{'Name'}, Queue => $args{'Queue'} );
    } else {
        die "Name is required";
    }
    unless ( $obj->id ) {
        my ($val, $msg) = $obj->Create( %args );
        die "$msg" unless $val;
    }

    return $obj;
}

sub last_ticket {
    my $self = shift;
    my $current = shift;
    $current = $current ? RT::CurrentUser->new($current) : RT->SystemUser;
    my $tickets = RT::Tickets->new( $current );
    $tickets->OrderBy( FIELD => 'id', ORDER => 'DESC' );
    $tickets->Limit( FIELD => 'id', OPERATOR => '>', VALUE => '0' );
    $tickets->RowsPerPage( 1 );
    return $tickets->First;
}

sub store_rights {
    my $self = shift;

    require RT::ACE;
    # fake construction
    RT::ACE->new( RT->SystemUser );
    my @fields = keys %{ RT::ACE->_ClassAccessible };

    require RT::ACL;
    my $acl = RT::ACL->new( RT->SystemUser );
    $acl->Limit( FIELD => 'RightName', OPERATOR => '!=', VALUE => 'SuperUser' );

    my @res;
    while ( my $ace = $acl->Next ) {
        my $obj = $ace->PrincipalObj->Object;
        if ( $obj->isa('RT::Group') && $obj->Type eq 'UserEquiv' && $obj->Instance == RT->Nobody->id ) {
            next;
        }

        my %tmp = ();
        foreach my $field( @fields ) {
            $tmp{ $field } = $ace->__Value( $field );
        }
        push @res, \%tmp;
    }
    return @res;
}

sub restore_rights {
    my $self = shift;
    my @entries = @_;
    foreach my $entry ( @entries ) {
        my $ace = RT::ACE->new( RT->SystemUser );
        my ($status, $msg) = $ace->RT::Record::Create( %$entry );
        unless ( $status ) {
            Test::More::diag "couldn't create a record: $msg";
        }
    }
}

sub set_rights {
    my $self = shift;

    require RT::ACL;
    my $acl = RT::ACL->new( RT->SystemUser );
    $acl->Limit( FIELD => 'RightName', OPERATOR => '!=', VALUE => 'SuperUser' );
    while ( my $ace = $acl->Next ) {
        my $obj = $ace->PrincipalObj->Object;
        if ( $obj->isa('RT::Group') && $obj->Type eq 'UserEquiv' && $obj->Instance == RT->Nobody->id ) {
            next;
        }
        $ace->Delete;
    }
    return $self->add_rights( @_ );
}

sub add_rights {
    my $self = shift;
    my @list = ref $_[0]? @_: @_? { @_ }: ();

    require RT::ACL;
    foreach my $e (@list) {
        my $principal = delete $e->{'Principal'};
        unless ( ref $principal ) {
            if ( $principal =~ /^(everyone|(?:un)?privileged)$/i ) {
                $principal = RT::Group->new( RT->SystemUser );
                $principal->LoadSystemInternalGroup($1);
            } elsif ( $principal =~ /^(Owner|Requestor|(?:Admin)?Cc)$/i ) {
                $principal = RT::Group->new( RT->SystemUser );
                $principal->LoadByCols(
                    Domain => (ref($e->{'Object'})||'RT::System').'-Role',
                    Type => $1,
                    ref($e->{'Object'})? (Instance => $e->{'Object'}->id): (),
                );
            } else {
                die "principal is not an object, but also is not name of a system group";
            }
        }
        unless ( $principal->isa('RT::Principal') ) {
            if ( $principal->can('PrincipalObj') ) {
                $principal = $principal->PrincipalObj;
            }
        }
        my @rights = ref $e->{'Right'}? @{ $e->{'Right'} }: ($e->{'Right'});
        foreach my $right ( @rights ) {
            my ($status, $msg) = $principal->GrantRight( %$e, Right => $right );
            $RT::Logger->debug($msg);
        }
    }
    return 1;
}

sub run_mailgate {
    my $self = shift;

    require RT::Test::Web;
    my %args = (
        url     => RT::Test::Web->rt_base_url,
        message => '',
        action  => 'correspond',
        queue   => 'General',
        debug   => 1,
        command => $RT::BinPath .'/rt-mailgate',
        @_
    );
    my $message = delete $args{'message'};

    $args{after_open} = sub {
        my $child_in = shift;
        if ( UNIVERSAL::isa($message, 'MIME::Entity') ) {
            $message->print( $child_in );
        } else {
            print $child_in $message;
        }
    };

    $self->run_and_capture(%args);
}

sub run_and_capture {
    my $self = shift;
    my %args = @_;

    my $after_open = delete $args{after_open};

    my $cmd = delete $args{'command'};
    die "Couldn't find command ($cmd)" unless -f $cmd;

    $cmd .= ' --debug' if delete $args{'debug'};

    while( my ($k,$v) = each %args ) {
        next unless $v;
        $cmd .= " --$k '$v'";
    }
    $cmd .= ' 2>&1';

    DBIx::SearchBuilder::Record::Cachable->FlushCache;

    require IPC::Open2;
    my ($child_out, $child_in);
    my $pid = IPC::Open2::open2($child_out, $child_in, $cmd);

    $after_open->($child_in, $child_out) if $after_open;

    close $child_in;

    my $result = do { local $/; <$child_out> };
    close $child_out;
    waitpid $pid, 0;
    return ($?, $result);
}

sub send_via_mailgate_and_http {
    my $self = shift;
    my $message = shift;
    my %args = (@_);

    my ($status, $gate_result) = $self->run_mailgate(
        message => $message, %args
    );

    my $id;
    unless ( $status >> 8 ) {
        ($id) = ($gate_result =~ /Ticket:\s*(\d+)/i);
        unless ( $id ) {
            Test::More::diag "Couldn't find ticket id in text:\n$gate_result"
                if $ENV{'TEST_VERBOSE'};
        }
    } else {
        Test::More::diag "Mailgate output:\n$gate_result"
            if $ENV{'TEST_VERBOSE'};
    }
    return ($status, $id);
}


sub send_via_mailgate {
    my $self    = shift;
    my $message = shift;
    my %args = ( action => 'correspond',
                 queue  => 'General',
                 @_
               );

    if ( UNIVERSAL::isa( $message, 'MIME::Entity' ) ) {
        $message = $message->as_string;
    }

    my ( $status, $error_message, $ticket )
        = RT::Interface::Email::Gateway( {%args, message => $message} );
    return ( $status, $ticket ? $ticket->id : 0 );

}


sub open_mailgate_ok {
    my $class   = shift;
    my $baseurl = shift;
    my $queue   = shift || 'general';
    my $action  = shift || 'correspond';
    Test::More::ok(open(my $mail, '|-', "$RT::BinPath/rt-mailgate --url $baseurl --queue $queue --action $action"), "Opened the mailgate - $!");
    return $mail;
}


sub close_mailgate_ok {
    my $class = shift;
    my $mail  = shift;
    close $mail;
    Test::More::is ($? >> 8, 0, "The mail gateway exited normally. yay");
}

sub mailsent_ok {
    my $class = shift;
    my $expected  = shift;

    my $mailsent = scalar grep /\S/, split /%% split me! %%\n/,
        RT::Test->file_content(
            $tmp{'mailbox'},
            'unlink' => 0,
            noexist => 1
        );

    Test::More::is(
        $mailsent, $expected,
        "The number of mail sent ($expected) matches. yay"
    );
}

sub fetch_caught_mails {
    my $self = shift;
    return grep /\S/, split /%% split me! %%\n/,
        RT::Test->file_content(
            $tmp{'mailbox'},
            'unlink' => 1,
            noexist => 1
        );
}

sub clean_caught_mails {
    unlink $tmp{'mailbox'};
}

=head2 get_relocatable_dir

Takes a path relative to the location of the test file that is being
run and returns a path that takes the invocation path into account.

e.g. 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 @directories = File::Spec->splitdir(
        File::Spec->rel2abs((File::Spec->splitpath($0))[1])
    );
    push @directories, File::Spec->splitdir($_) for @_;

    my @clean;
    for (@directories) {
        if    ($_ eq "..") { pop @clean      }
        elsif ($_ ne ".")  { push @clean, $_ }
    }
    return File::Spec->catdir(@clean);
}

=head2 get_relocatable_file

Same as get_relocatable_dir, but takes a file and a path instead
of just a path.

e.g. RT::Test::get_relocatable_file('test-email',
        (File::Spec->updir(), 'data', 'emails'))

=cut

sub get_relocatable_file {
    my $file = shift;
    return File::Spec->catfile(get_relocatable_dir(@_), $file);
}

sub get_abs_relocatable_dir {
    (my $volume, my $directories, my $file) = File::Spec->splitpath($0);
    if (File::Spec->file_name_is_absolute($directories)) {
        return File::Spec->catdir($directories, @_);
    } else {
        return File::Spec->catdir(Cwd->getcwd(), $directories, @_);
    }
}

sub gnupg_homedir {
    my $self = shift;
    File::Temp->newdir(
        DIR => $tmp{directory},
        CLEANUP => 0,
    );
}

sub import_gnupg_key {
    my $self = shift;
    my $key  = shift;
    my $type = shift || 'secret';

    $key =~ s/\@/-at-/g;
    $key .= ".$type.key";

    require RT::Crypt::GnuPG;

    # simple strategy find data/gnupg/keys, from the dir where test file lives
    # to updirs, try 3 times in total
    my $path = File::Spec->catfile( 'data', 'gnupg', 'keys' );
    my $abs_path;
    for my $up ( 0 .. 2 ) {
        my $p = get_relocatable_dir($path);
        if ( -e $p ) {
            $abs_path = $p;
            last;
        }
        else {
            $path = File::Spec->catfile( File::Spec->updir(), $path );
        }
    }

    die "can't find the dir where gnupg keys are stored"
      unless $abs_path;

    return RT::Crypt::GnuPG::ImportKey(
        RT::Test->file_content( [ $abs_path, $key ] ) );
}


sub lsign_gnupg_key {
    my $self = shift;
    my $key = shift;

    require RT::Crypt::GnuPG; require GnuPG::Interface;
    my $gnupg = GnuPG::Interface->new();
    my %opt = RT->Config->Get('GnuPGOptions');
    $gnupg->options->hash_init(
        RT::Crypt::GnuPG::_PrepareGnuPGOptions( %opt ),
        meta_interactive => 0,
    );

    my %handle; 
    my $handles = GnuPG::Handles->new(
        stdin   => ($handle{'input'}   = IO::Handle->new()),
        stdout  => ($handle{'output'}  = IO::Handle->new()),
        stderr  => ($handle{'error'}   = IO::Handle->new()),
        logger  => ($handle{'logger'}  = IO::Handle->new()),
        status  => ($handle{'status'}  = IO::Handle->new()),
        command => ($handle{'command'} = IO::Handle->new()),
    );

    eval {
        local $SIG{'CHLD'} = 'DEFAULT';
        local @ENV{'LANG', 'LC_ALL'} = ('C', 'C');
        my $pid = $gnupg->wrap_call(
            handles => $handles,
            commands => ['--lsign-key'],
            command_args => [$key],
        );
        close $handle{'input'};
        while ( my $str = readline $handle{'status'} ) {
            if ( $str =~ /^\[GNUPG:\]\s*GET_BOOL sign_uid\..*/ ) {
                print { $handle{'command'} } "y\n";
            }
        }
        waitpid $pid, 0;
    };
    my $err = $@;
    close $handle{'output'};

    my %res;
    $res{'exit_code'} = $?;
    foreach ( qw(error logger status) ) {
        $res{$_} = do { local $/; readline $handle{$_} };
        delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
        close $handle{$_};
    }
    $RT::Logger->debug( $res{'status'} ) if $res{'status'};
    $RT::Logger->warning( $res{'error'} ) if $res{'error'};
    $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
    if ( $err || $res{'exit_code'} ) {
        $res{'message'} = $err? $err : "gpg exitted with error code ". ($res{'exit_code'} >> 8);
    }
    return %res;
}

sub trust_gnupg_key {
    my $self = shift;
    my $key = shift;

    require RT::Crypt::GnuPG; require GnuPG::Interface;
    my $gnupg = GnuPG::Interface->new();
    my %opt = RT->Config->Get('GnuPGOptions');
    $gnupg->options->hash_init(
        RT::Crypt::GnuPG::_PrepareGnuPGOptions( %opt ),
        meta_interactive => 0,
    );

    my %handle; 
    my $handles = GnuPG::Handles->new(
        stdin   => ($handle{'input'}   = IO::Handle->new()),
        stdout  => ($handle{'output'}  = IO::Handle->new()),
        stderr  => ($handle{'error'}   = IO::Handle->new()),
        logger  => ($handle{'logger'}  = IO::Handle->new()),
        status  => ($handle{'status'}  = IO::Handle->new()),
        command => ($handle{'command'} = IO::Handle->new()),
    );

    eval {
        local $SIG{'CHLD'} = 'DEFAULT';
        local @ENV{'LANG', 'LC_ALL'} = ('C', 'C');
        my $pid = $gnupg->wrap_call(
            handles => $handles,
            commands => ['--edit-key'],
            command_args => [$key],
        );
        close $handle{'input'};

        my $done = 0;
        while ( my $str = readline $handle{'status'} ) {
            if ( $str =~ /^\[GNUPG:\]\s*\QGET_LINE keyedit.prompt/ ) {
                if ( $done ) {
                    print { $handle{'command'} } "quit\n";
                } else {
                    print { $handle{'command'} } "trust\n";
                }
            } elsif ( $str =~ /^\[GNUPG:\]\s*\QGET_LINE edit_ownertrust.value/ ) {
                print { $handle{'command'} } "5\n";
            } elsif ( $str =~ /^\[GNUPG:\]\s*\QGET_BOOL edit_ownertrust.set_ultimate.okay/ ) {
                print { $handle{'command'} } "y\n";
                $done = 1;
            }
        }
        waitpid $pid, 0;
    };
    my $err = $@;
    close $handle{'output'};

    my %res;
    $res{'exit_code'} = $?;
    foreach ( qw(error logger status) ) {
        $res{$_} = do { local $/; readline $handle{$_} };
        delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
        close $handle{$_};
    }
    $RT::Logger->debug( $res{'status'} ) if $res{'status'};
    $RT::Logger->warning( $res{'error'} ) if $res{'error'};
    $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
    if ( $err || $res{'exit_code'} ) {
        $res{'message'} = $err? $err : "gpg exitted with error code ". ($res{'exit_code'} >> 8);
    }
    return %res;
}

sub started_ok {
    my $self = shift;

    require RT::Test::Web;

    if ($rttest_opt{nodb} and not $rttest_opt{server_ok}) {
        die "You are trying to use a test web server without a database. "
           ."You may want noinitialdata => 1 instead. "
           ."Pass server_ok => 1 if you know what you're doing.";
    }


    $ENV{'RT_TEST_WEB_HANDLER'} = undef
        if $rttest_opt{actual_server} && ($ENV{'RT_TEST_WEB_HANDLER'}||'') eq 'inline';
    $ENV{'RT_TEST_WEB_HANDLER'} ||= 'plack';
    my $which = $ENV{'RT_TEST_WEB_HANDLER'};
    my ($server, $variant) = split /\+/, $which, 2;

    my $function = 'start_'. $server .'_server';
    unless ( $self->can($function) ) {
        die "Don't know how to start server '$server'";
    }
    return $self->$function( variant => $variant, @_ );
}

sub test_app {
    my $self = shift;
    my %server_opt = @_;

    my $app;

    my $warnings = "";
    open( my $warn_fh, ">", \$warnings );
    local *STDERR = $warn_fh;

    if ($server_opt{variant} and $server_opt{variant} eq 'rt-server') {
        $app = do {
            my $file = "$RT::SbinPath/rt-server";
            my $psgi = do $file;
            unless ($psgi) {
                die "Couldn't parse $file: $@" if $@;
                die "Couldn't do $file: $!"    unless defined $psgi;
                die "Couldn't run $file"       unless $psgi;
            }
            $psgi;
        };
    } else {
        require RT::Interface::Web::Handler;
        $app = RT::Interface::Web::Handler->PSGIApp;
    }

    require Plack::Middleware::Test::StashWarnings;
    my $stashwarnings = Plack::Middleware::Test::StashWarnings->new;
    $app = $stashwarnings->wrap($app);

    if ($server_opt{basic_auth}) {
        require Plack::Middleware::Auth::Basic;
        $app = Plack::Middleware::Auth::Basic->wrap(
            $app,
            authenticator => sub {
                my ($username, $password) = @_;
                return $username eq 'root' && $password eq 'password';
            }
        );
    }

    close $warn_fh;
    $stashwarnings->add_warning( $warnings ) if $warnings;

    return $app;
}

sub start_plack_server {
    my $self = shift;

    require Plack::Loader;
    my $plack_server = Plack::Loader->load
        ('Standalone',
         port => $port,
         server_ready => sub {
             kill 'USR1' => getppid();
         });

    # We are expecting a USR1 from the child process after it's ready
    # to listen.  We set this up _before_ we fork to avoid race
    # conditions.
    my $handled;
    local $SIG{USR1} = sub { $handled = 1};

    __disconnect_rt();
    my $pid = fork();
    die "failed to fork" unless defined $pid;

    if ($pid) {
        sleep 15 unless $handled;
        Test::More::diag "did not get expected USR1 for test server readiness"
            unless $handled;
        push @SERVERS, $pid;
        my $Tester = Test::Builder->new;
        $Tester->ok(1, "started plack server ok");

        __reconnect_rt()
            unless $rttest_opt{nodb};
        return ("http://localhost:$port", RT::Test::Web->new);
    }

    require POSIX;
    if ( $^O !~ /MSWin32/ ) {
        POSIX::setsid()
            or die "Can't start a new session: $!";
    }

    # stick this in a scope so that when $app is garbage collected,
    # StashWarnings can complain about unhandled warnings
    do {
        $plack_server->run($self->test_app(@_));
    };

    exit;
}

our $TEST_APP;
sub start_inline_server {
    my $self = shift;

    require Test::WWW::Mechanize::PSGI;
    unshift @RT::Test::Web::ISA, 'Test::WWW::Mechanize::PSGI';

    # Clear out squished CSS and JS cache, since it's retained across
    # servers, since it's in-process
    RT::Interface::Web->ClearSquished;
    require RT::Interface::Web::Request;
    RT::Interface::Web::Request->clear_callback_cache;

    Test::More::ok(1, "psgi test server ok");
    $TEST_APP = $self->test_app(@_);
    return ("http://localhost:$port", RT::Test::Web->new);
}

sub start_apache_server {
    my $self = shift;
    my %server_opt = @_;
    $server_opt{variant} ||= 'mod_perl';
    $ENV{RT_TEST_WEB_HANDLER} = "apache+$server_opt{variant}";

    require RT::Test::Apache;
    my $pid = RT::Test::Apache->start_server(
        %server_opt,
        port => $port,
        tmp => \%tmp
    );
    push @SERVERS, $pid;

    my $url = RT->Config->Get('WebURL');
    $url =~ s!/$!!;
    return ($url, RT::Test::Web->new);
}

sub stop_server {
    my $self = shift;
    my $in_end = shift;
    return unless @SERVERS;

    my $sig = 'TERM';
    $sig = 'INT' if $ENV{'RT_TEST_WEB_HANDLER'} eq "plack";
    kill $sig, @SERVERS;
    foreach my $pid (@SERVERS) {
        if ($ENV{RT_TEST_WEB_HANDLER} =~ /^apache/) {
            sleep 1 while kill 0, $pid;
        } else {
            waitpid $pid, 0;
        }
    }

    @SERVERS = ();
}

sub temp_directory {
    return $tmp{'directory'};
}

sub file_content {
    my $self = shift;
    my $path = shift;
    my %args = @_;

    $path = File::Spec->catfile( @$path ) if ref $path eq 'ARRAY';

    Test::More::diag "reading content of '$path'" if $ENV{'TEST_VERBOSE'};

    open( my $fh, "<:raw", $path )
        or do {
            warn "couldn't open file '$path': $!" unless $args{noexist};
            return ''
        };
    my $content = do { local $/; <$fh> };
    close $fh;

    unlink $path if $args{'unlink'};

    return $content;
}

sub find_executable {
    my $self = shift;
    my $name = shift;

    require File::Spec;
    foreach my $dir ( split /:/, $ENV{'PATH'} ) {
        my $fpath = File::Spec->catpath(
            (File::Spec->splitpath( $dir, 'no file' ))[0..1], $name
        );
        next unless -e $fpath && -r _ && -x _;
        return $fpath;
    }
    return undef;
}

sub diag {
    return unless $ENV{RT_TEST_VERBOSE} || $ENV{TEST_VERBOSE};
    goto \&Test::More::diag;
}

sub parse_mail {
    my $mail = shift;
    require RT::EmailParser;
    my $parser = RT::EmailParser->new;
    $parser->ParseMIMEEntityFromScalar( $mail );
    return $parser->Entity;
}

sub works {
    Test::More::ok($_[0], $_[1] || 'This works');
}

sub fails {
    Test::More::ok(!$_[0], $_[1] || 'This should fail');
}

sub plan {
    my ($cmd, @args) = @_;
    my $builder = RT::Test->builder;

    if ($cmd eq "skip_all") {
        $check_warnings_in_end = 0;
    } elsif ($cmd eq "tests") {
        # Increment the test count for the warnings check
        $args[0]++;
    }
    $builder->plan($cmd, @args);
}

sub done_testing {
    my $builder = RT::Test->builder;

    Test::NoWarnings::had_no_warnings();
    $check_warnings_in_end = 0;

    $builder->done_testing(@_);
}

END {
    my $Test = RT::Test->builder;
    return if $Test->{Original_Pid} != $$;

    # we are in END block and should protect our exit code
    # so calls below may call system or kill that clobbers $?
    local $?;

    Test::NoWarnings::had_no_warnings() if $check_warnings_in_end;

    RT::Test->stop_server(1);

    # not success
    if ( !$Test->is_passing ) {
        $tmp{'directory'}->unlink_on_destroy(0);

        Test::More::diag(
            "Some tests failed or we bailed out, tmp directory"
            ." '$tmp{directory}' is not cleaned"
        );
    }

    if ( $ENV{RT_TEST_PARALLEL} && $created_new_db ) {
        __drop_database();
    }

    # Drop our port from t/tmp/ports; do this after dropping the
    # database, as our port lock is also a lock on the database name.
    if ($port) {
        my %ports;
        my $portfile = "$tmp{'directory'}/../ports";
        sysopen(PORTS, $portfile, O_RDWR|O_CREAT)
            or die "Can't write to ports file $portfile: $!";
        flock(PORTS, LOCK_EX)
            or die "Can't write-lock ports file $portfile: $!";
        $ports{$_}++ for split ' ', join("",<PORTS>);
        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;