utperl : Unit Test driver for perl using "Reflection"

@rem = '--*-PERL-*--';
@rem = '
@echo off
rem setlocal
perl -S %0 %*
goto endofperl
@rem ';
#!perl -w
use strict;
use ut;

#-------------------------------------------
sub test_startswith()
{
  ut::assertStartsWith("abc", 'a');
  ut::assertStartsWith("abc", 'b');
}

#-------------------------------------------
sub test_equals()
{
  #these should fail
  ut::assertBool(undef);
  ut::assert(1, 0);
  ut::assertBool('');
  ut::assert(undef, 0);
  ut::assert(1, undef);
  
  #these should pass
  ut::assert(undef, undef);
  ut::assert(1, 1);
  ut::assertBool(1);
}

#---------------------------------
#main

  ut::run();

__END__
:endofperl

#!perl -w
use strict;
use IPC::Open2;

package ut;
my $gVerbose = 0;

my $gNumFiles;
my $gNumTests;
my $gNumAsserts;
my $gNumErrors;
my %tables = ();
my @todo = ();

#---------------------------------
sub reportError($)
  {
  my ($msg) = @_;

  $gNumErrors++;
  my $subr = (caller(2))[3];
  $subr =~ s/^[^:]+:://;
  my $file = (caller(1))[1];
  my $line = (caller(1))[2];
  print($file, "(", $line, ")", ": ", $subr ," FAILED:\n    $msg\n");
  }

#---------------------------------
sub assertStartsWith($$)
{
  $gNumAsserts++;
  my ($actual, $expected) = @_;
  return if ($actual =~ /^$expected/);

  reportError("actual='$actual', expected='$expected'");
}

#---------------------------------
sub assert($$)
{
  $gNumAsserts++;
  my ($actual, $expected) = @_;
  
  return if !defined($actual) && !defined($expected);
  if (defined ($actual) && defined ($expected))
    {
    return if ($actual eq $expected);
    }

  $actual = 'undef' if !defined $actual;
  $expected = 'undef' if !defined $expected;
  reportError("actual='$actual', expected='$expected'");
}

#---------------------------------
sub assertBool($)
{
  $gNumAsserts++;
  my ($actual) = @_;
  if (defined $actual)
    {
    return if ($actual);
    }
  else
    {
    $actual = 'undef';
    }
  reportError("actual='$actual', expected='true'");
}

#---------------------------------
sub init()
  {
  $gNumFiles = 0;
  $gNumTests = 0;
  $gNumAsserts = 0;
  $gNumErrors = 0;
  }

#---------------------------------
sub showstats()
  {
  print "\nSummary:\n";
  print "number of files  : $gNumFiles\n";
  print "number of tests  : $gNumTests\n";
  print "number of asserts: $gNumAsserts\n";
  print "number of errors : $gNumErrors\n";
  }

#-------------------------------------------
sub addNewSymbolTable(@)
{
  my ($packageName, $refToSymbolTable) = @_;

  return if defined $tables{$packageName} ;

  $tables{$packageName} = $refToSymbolTable;
  push @todo, $packageName;
}

#-------------------------------------------
sub getSymbolTable($)
  {
  my ($packageName) = @_;
  return $tables{$packageName};
  }

#-------------------------------------------
sub isMoreTodo()
{
  return scalar @todo;
}

#-------------------------------------------
sub nextSymbolTable()
{
  return pop @todo;
}

#-------------------------------------------
sub forAllSymbolsIn($$)
  {
  my ($rsub, $packageName) = @_;
  my $refToSymbolTable = getSymbolTable($packageName);
  foreach my $symbolName (sort keys %{$refToSymbolTable})
    {
    ## get the symbol table entry (a typeglob)
    local *sym = $$refToSymbolTable{$symbolName};

    &$rsub($packageName, $symbolName) if defined &sym;
    #print "subroutine $packageName$symbolName()\n" if defined &sym;

    next if $symbolName !~ /::$/ ;         ## package names end with '::'
    next if defined $tables{$symbolName} ; ## skip if we've already searched the package.

    ## it's a package, so the symbolName is a package name, which names a symbol table (a hash)
    #print "package    $symbolName\n";
    addNewSymbolTable($symbolName, \%{*sym});
    }
  }

#-------------------------------------------
sub searchForAllSubroutinesIn(@)
{
  addNewSymbolTable(@_);
  while (isMoreTodo())
    {
    forAllSymbolsIn( \&runsub, nextSymbolTable() );
    }
}

#-------------------------------------------
sub runsub($$)
{
    my ($packageName, $sub) = @_;

    return if ($packageName !~ /^main::/i);
    return if ($sub !~ /^test/);
    print "Test case $packageName$sub()\n" if $gVerbose;
    
    my %symtable = eval("%$packageName");
    local *sym = $symtable{$sub};

    $gNumTests++;
    &sym();
}

#--------------------------------------------------------
sub run()
{
  init();
  $gNumFiles = main::_utLoadTestFiles();
  searchForAllSubroutinesIn("main::", \%main::);
  showstats();
}

package main;

#----
sub _utLoadTestFiles
  {
  my $count = 0;
  my @testfiles = <test_*.pm>;
  foreach my $tfile (@testfiles)
    {
    $count++;
    #print "Loading $tfile ...\n"; 
    $tfile =~ s/\.pm$//i;
    eval "use $tfile;";
    print "$@" if $@ ne '';
    }
  return $count;
  }


1;