e-smith-test/root/usr/share/perl5/vendor_perl/esmith/TestUtils.pm

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;