initial commit of file from CVS for e-smith-test on Wed 12 Jul 09:10:30 BST 2023

root/usr/share/perl5/vendor_perl/esmith/TestUtils.pm

@@ -0,0 +1,374 @@
+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;