375 lines
8.1 KiB
Perl
375 lines
8.1 KiB
Perl
package esmith::TestUtils;
|
|
|
|
use strict;
|
|
use Exporter;
|
|
use Carp;
|
|
use esmith::ConfigDB;
|
|
use esmith::AccountsDB;
|
|
use vars qw( @ISA @EXPORT);
|
|
|
|
@ISA = qw( Exporter );
|
|
@EXPORT = qw(
|
|
destruction_ok
|
|
|
|
get_random_username
|
|
new_random_username
|
|
|
|
simulate_perl_program
|
|
|
|
scratch_copy
|
|
);
|
|
|
|
|
|
=head1 NAME
|
|
|
|
esmith::TestUtils -- general utilities for writing esmith tests
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
my $username = get_random_username();
|
|
my $newuser = new_random_username();
|
|
|
|
my $exit = simulate_perl_program($program);
|
|
|
|
if (destruction_ok()) { ... }
|
|
|
|
my $scratch_file = scratch_copy($file);
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
This module provides a bunch of useful little utility routines to
|
|
facilitate writing tests on the SMEServer.
|
|
|
|
=head2 destruction_ok()
|
|
|
|
Returns true or false depending on whether or not it's OK for tests to be destructive
|
|
on this server.
|
|
|
|
=for testing
|
|
use_ok(esmith::TestUtils);
|
|
is(destruction_ok(), 0, "Destruction turned off by default");
|
|
$ENV{ESMITH_CONFIG_DB} = "configuration.conf";
|
|
is(destruction_ok(), 1, "Destruction turned on in config file");
|
|
|
|
=cut
|
|
|
|
sub destruction_ok {
|
|
if (my $configdb = esmith::ConfigDB->open()) {
|
|
if (my $test_record = $configdb->get('testing')) {
|
|
if ($test_record->prop('destruction')) {
|
|
return 1;
|
|
}
|
|
}
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
=head2 get_random_username()
|
|
|
|
my $username = get_random_username;
|
|
|
|
Gets a random username from the accounts database.
|
|
|
|
=begin testing
|
|
|
|
use_ok(esmith::AccountsDB);
|
|
$ENV{ESMITH_ACCOUNT_DB} = "accounts.conf";
|
|
$ENV{ESMITH_CONFIG_DB} = "configuration.conf";
|
|
|
|
my $u = get_random_username();
|
|
my $accountdb = esmith::AccountsDB->open();
|
|
my @users = $accountdb->users();
|
|
@users = map { $_->key() } @users;
|
|
ok((grep !/^$u$/, @users), "get_random_username got username $u from accounts");
|
|
|
|
=end testing
|
|
|
|
=cut
|
|
|
|
sub get_random_username {
|
|
my $accountdb = esmith::AccountsDB->open();
|
|
my @users = $accountdb->users();
|
|
my $user = $users[rand(@users)];
|
|
return $user->key();
|
|
}
|
|
|
|
=head2 new_random_username()
|
|
|
|
my $username = new_random_username;
|
|
|
|
Returns a random username (just a random string of at least 3 letters) which
|
|
is not yet in the accounts database.
|
|
|
|
=begin testing
|
|
|
|
my $u = new_random_username();
|
|
use esmith::AccountsDB;
|
|
my $accountdb = esmith::AccountsDB->open();
|
|
my @users = $accountdb->users();
|
|
@users = map { $_->key() } @users;
|
|
ok((grep !/^$u$/, @users), "new_random_username invented new username $u");
|
|
|
|
=end testing
|
|
|
|
=cut
|
|
|
|
sub new_random_username {
|
|
my $accountdb = esmith::AccountsDB->open();
|
|
my @users = $accountdb->users();
|
|
@users = map { $_->key() } @users;
|
|
my @alphabet = split "", "abcdefghijklmnopqrstuvwxyz";
|
|
my $guessed = "test-";
|
|
while (1) {
|
|
$guessed .= $alphabet[rand(26)];
|
|
return $guessed unless grep /^$guessed$/, @users;
|
|
}
|
|
}
|
|
|
|
=head2 simulate_perl_program
|
|
|
|
my $exit = simulate_perl_program($program_file, @args);
|
|
|
|
"runs" the given $program_file for testing and reports it's $exit
|
|
code. @args will be expanded via glob() and passed into the program.
|
|
|
|
The $program_file is not actually run in a seperate process. Instead,
|
|
it is run in the current processs, simulating calling the program.
|
|
|
|
You'd do this in order to override certain functions it may call
|
|
for testing purposes. For example:
|
|
|
|
=begin testing
|
|
|
|
use esmith::Broker ();
|
|
|
|
# override esmith::Broker::saveConfig so it does not
|
|
# actually save the config. Instead, we trap the arguments
|
|
# for examination.
|
|
my @sSC_args;
|
|
sub esmith::Broker::saveServerConfig {
|
|
@sSC_args = @_;
|
|
return 1;
|
|
}
|
|
|
|
my $exit = simulate_perl_program($Original_File, qw(wibble));
|
|
|
|
is( $exit, 0, 'exited normally' );
|
|
is( $_STDOUT_, "wibble was frobnized\n" );
|
|
is( $_STDERR_, '', 'no warnings' );
|
|
is_deeply( \@sSC_args, [('Broker', 1234, { foo => 23 })],
|
|
'saveServerConfig called correctly' );
|
|
|
|
=end testing
|
|
|
|
|
|
B<Restrictions>
|
|
|
|
$program_file must be a Perl program.
|
|
|
|
any args on the #! line may not be honored.
|
|
|
|
it cannot assume it's in package main.
|
|
|
|
If the program dies the error will be on $@. The output of the
|
|
program will be available on $_STDOUT_ and $_STDERR_ as provided by
|
|
Test::Inline.
|
|
|
|
=begin testing
|
|
|
|
use esmith::TestUtils qw(simulate_perl_program);
|
|
|
|
can_ok(__PACKAGE__, 'simulate_perl_program');
|
|
|
|
my $Temp_File = '00e-smith-test/tmp_program';
|
|
END { unlink $Temp_File; }
|
|
|
|
sub _temp_program {
|
|
open(FILE, ">$Temp_File") or die $!;
|
|
print FILE @_;
|
|
close FILE;
|
|
$_STDOUT_ = '';
|
|
$_STDERR_ = '';
|
|
}
|
|
|
|
_temp_program(<<'OUT');
|
|
print "ok 1\n";
|
|
print STDERR "ok 2\n";
|
|
$Foo = 'present';
|
|
OUT
|
|
|
|
my $exit = simulate_perl_program($Temp_File);
|
|
is( $exit, 0 );
|
|
is( $@, '' );
|
|
is( $_STDOUT_, "ok 1\n" );
|
|
is( $_STDERR_, "ok 2\n" );
|
|
|
|
ok( !defined &CORE::GLOBAL::exit, 'trick exit() doesnt leak out' );
|
|
|
|
_temp_program(<<'OUT');
|
|
print $Foo ? "\$Foo should not carry over: $Foo" : "ok";
|
|
warn "wibble";
|
|
OUT
|
|
|
|
$exit = simulate_perl_program($Temp_File);
|
|
is( $exit, 0 );
|
|
is( $@, '' );
|
|
is( $_STDOUT_, "ok" );
|
|
is( $_STDERR_, "wibble at $Temp_File line 2.\n" );
|
|
|
|
|
|
_temp_program(<<'OUT');
|
|
die "Ack!\n";
|
|
OUT
|
|
|
|
$exit = simulate_perl_program($Temp_File);
|
|
is( $exit, 255*256, 'die sets the right error code' );
|
|
is( $@, "Ack!\n" );
|
|
is( $_STDOUT_, '' );
|
|
is( $_STDERR_, '' );
|
|
|
|
|
|
_temp_program(<<'OUT');
|
|
exit(42);
|
|
OUT
|
|
|
|
$exit = simulate_perl_program($Temp_File);
|
|
is( $exit, 256*42, 'exit code propagated' );
|
|
is( $@, '' );
|
|
is( $_STDOUT_, '' );
|
|
is( $_STDERR_, '' );
|
|
|
|
_temp_program(<<'OUT');
|
|
print "@ARGV";
|
|
OUT
|
|
|
|
$exit = simulate_perl_program($Temp_File, qw(this that));
|
|
is( $exit, 0 );
|
|
is( $@, '' );
|
|
is( $_STDOUT_, 'this that', 'args passed in' );
|
|
is( $_STDERR_, '' );
|
|
|
|
_temp_program(<<'OUT');
|
|
print "@ARGV";
|
|
OUT
|
|
|
|
$exit = simulate_perl_program($Temp_File, qw(00*));
|
|
is( $exit, 0 );
|
|
is( $@, '' );
|
|
is( $_STDOUT_, '00e-smith-test', 'args expanded' );
|
|
is( $_STDERR_, '' );
|
|
|
|
|
|
=end testing
|
|
|
|
=cut
|
|
|
|
my $Pack = 0;
|
|
sub simulate_perl_program {
|
|
my($prog, @args) = @_;
|
|
|
|
my $error;
|
|
eval sprintf q{
|
|
BEGIN {
|
|
no warnings 'redefine';
|
|
*CORE::GLOBAL::exit = sub (;$) {
|
|
my $exit = $_[0] || 0;
|
|
bless \$exit, 'esmith::TestUtils::simulate_perl_program::exit';
|
|
die \$exit;
|
|
};
|
|
}
|
|
|
|
package esmith::TestUtils::simulate_perl_program::%d;
|
|
|
|
local @ARGV = map glob($_), @args;
|
|
do $prog;
|
|
$error = $@; # make the do error visible outside the eval
|
|
}, $Pack++;
|
|
|
|
# so future eval's aren't effected.
|
|
undef &CORE::GLOBAL::exit;
|
|
delete $::CORE::GLOBAL::{exit};
|
|
|
|
if( $error ) {
|
|
if( UNIVERSAL::isa($error,
|
|
'esmith::TestUtils::simulate_perl_program::exit')
|
|
)
|
|
{
|
|
return 256 * ${$error};
|
|
}
|
|
else {
|
|
$@ = $error;
|
|
return 255 * 256;
|
|
}
|
|
}
|
|
else {
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
|
|
=head2 scratch_copy
|
|
|
|
my $scratch = scratch_copy($src);
|
|
my $scratch = scratch_copy($src, $dest);
|
|
|
|
Creates a scratch copy of the $src file that you can safely scribbled
|
|
around with for testing. Returns the location of the $scratch file.
|
|
If $dest is given it will use that for $scratch.
|
|
|
|
If the copy fails, $scratch will be undefined.
|
|
|
|
When the program exits the $scratch file will be deleted.
|
|
|
|
=begin testing
|
|
|
|
use esmith::TestUtils qw(scratch_copy);
|
|
|
|
my $src = 'accounts.conf';
|
|
my $scratch = scratch_copy($src);
|
|
isnt( $scratch, undef );
|
|
ok( -e $scratch, 'scratch_copy() created a scratch file' ) || diag $!;
|
|
|
|
use Digest::MD5;
|
|
open(FILE, $src) || die $!;
|
|
my $srcmd5 = Digest::MD5->new->addfile(*FILE)->hexdigest;
|
|
open(FILE, $scratch) || die $1;
|
|
my $destmd5 = Digest::MD5->new->addfile(*FILE)->hexdigest;
|
|
close FILE;
|
|
|
|
is( $srcmd5, $destmd5, ' same as the original' );
|
|
|
|
=end testing
|
|
|
|
=cut
|
|
|
|
my @Scratch_Files = ();
|
|
sub scratch_copy {
|
|
my($src, $dest) = @_;
|
|
|
|
$dest = "$src.scratch" unless defined $dest;
|
|
|
|
require File::Copy;
|
|
my $ret = File::Copy::copy($src, $dest);
|
|
|
|
if($ret) {
|
|
push @Scratch_Files, $dest;
|
|
return $dest;
|
|
}
|
|
else {
|
|
return undef;
|
|
}
|
|
}
|
|
|
|
END { unlink @Scratch_Files }
|
|
|
|
=head1 AUTHOR
|
|
|
|
Mitel Networks Corporation
|
|
|
|
See http://www.e-smith.org/ for more information.
|
|
|
|
=cut
|
|
|
|
|
|
1;
|