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

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;