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