Beefy Boxes and Bandwidth Generously Provided by pair Networks Frank
laziness, impatience, and hubris
 
PerlMonks  

Autogenerate Test Scripts

by tachyon (Chancellor)
on Aug 02, 2003 at 11:22 UTC ( #280268=snippet: print w/ replies, xml ) Need Help??

Description:

This script will help you write test suites by automatigically generating a complete test suite for a given Module (OO or export based). All you will need to do is add the appropriate tests to the supplied ok( some_func() ) stubs, deleting or adding tests as appropriate. It also has a handy renumber function that is written into the test script stub so when you add a new test in the middle of your tests you can just do:

script.t renum

And all your tests will get correctly renumbered. The plan will also be updated.

Update

Added chmod 0755 $0 on renum and write stubs.

#!/usr/bin/perl -w

use strict;
use Test;
# use the required libraries ( you will need to edit this for your dev
+el environment)
use lib '/devel/www/cgi-bin/';


if ( $ARGV[0] and $ARGV[0] =~ m!help|\?! ) {
    open SELF, $0 or die "Can't open myself to read pod you will have 
+to RTFS!\n";
    local $/;
    my $pod = <SELF>;
    close SELF;
    my ( $help ) = $pod =~ m!^(=head.*?=cut)!sm;
    print $help ? "$help\n" : "Sorry no help available, RTFS!\n";
  exit 0;
}

# set debugging mode if desired
my $debug = ( $ARGV[0] and $ARGV[0] eq 'debug' ) ? 1 : 0;
# is this an auto renumber request
my $renum = ( $ARGV[0] and $ARGV[0] eq 'renum' ) ? 1 : 0;

# use a BEGIN block so we print our plan before MyModule is loaded
BEGIN { plan tests => 1, todo => [] }

=head2 NAME template.t

This script will automatically write stub test files for you. A little
+ 
work from you to fill in the blanks and you have a test suite. It will
+ 
handle OO or Export based test stubbing

=head2 SYNOPSIS

You can call this script in four ways

script.t
script.t debug
script.t renum
script.t Some::Module [oo]

When called with no command line are all the tests are run

When called with the debug option all tests are run + extra reporting

When called with the renum option all the ok() tests within script.t 
will be automatically sequentially numbered with a comment like

ok(BLAH)    #35

where 35 is the test number you will see when you run the tests.

When called with any command line arg other than 'debug' or 'renum' 
then the script will assume that this is a module name and search 
@INC for that module. You will probably want to add a line like:

use lib '/my/devel/module/base/dir/';

so that the script can find the module you want to stub testf for. 
Provided a matching module is found the script will write a stub test 
script called 

stub_[NAME].t 

into the current directory. By default this stub test file will be 
written to test all the @EXPORT and @EXPORT_OK functions. If it is an 
OO module that has no exports add a second command line arg (any true 
value will do) and it will read all the sub names and add stub tests 
for the lot, both oo and direct calls.

The stub file should be renamed [NAME].t unless this already exists
in which case you will need to do some cut and paste.

All you then need to do is add some data to the ok() stub tests, 
delete or add more and you have a fully functional test suite. The 
stub module retains the renum functionality of template.t but loses 
the generate new stubs functionality.

=head2 EXPORT

Nothing, but it does write the stub_[NAME].t file

=head2 BUGS

Probably, perhaps they are features?

=head2 AUTHOR INFORMATION

Copyright 2002 Dr James Freeman E<lt>jfreeman@tassie.net.auE<gt>

This package is free software and is provided "as is" without express 
or implied warranty in the hope that it may be found useful.

It may be used, redistributed and/or modified under the terms
of the Perl Artistic License 
(see http://www.perl.com/perl/misc/Artistic.html)

=cut

if ( $ARGV[0] and ! $debug ) {
    if ( $renum ) {
        run_renumber();
    }
    else {
        run_add_test_stubs( @ARGV );
    }
  exit;
}

=head1 Synopsis of Test syntax

  use strict;
  use Test;
  # use a BEGIN block so we print our plan before MyModule is loaded
  BEGIN { plan tests => 14, todo => [3,4] }
  # load your module...
  use MyModule;
  ok(0); # failure
  ok(1); # success
  ok(0); # ok, expected failure (see todo list, above)
  ok(1); # surprise success!
  ok(0,1);             # failure: '0' ne '1'
  ok('broke','fixed'); # failure: 'broke' ne 'fixed'
  ok('fixed','fixed'); # success: 'fixed' eq 'fixed'
  ok('fixed',qr/x/);   # success: 'fixed' =~ qr/x/
  ok(sub { 1+1 }, 2);  # success: '2' eq '2'
  ok(sub { 1+1 }, 3);  # failure: '2' ne '3'
  ok(0, int(rand(2));  # (just kidding :-)
  my @list = (0,0);
  ok @list, 3, "\@list=".join(',',@list);      #extra diagnostics
  ok 'segmentation fault', '/(?i)success/';    #regex match
  skip($feature_is_missing, ...);    #do platform specific test

Note use the ok( blah, blah ) form rather than ok( blah == blah ) as w
+hen a 
test fails the first form tells you what it got and what it expected. 
+The second
form with either be 1 or 0 - not so informative.

#leave this
=cut

#---------------------------------------------------------------------
+---------
# BEGIN module specific test code
#---------------------------------------------------------------------
+---------

#<TEST CODE HERE>

#---------------------------------------------------------------------
+---------
# END module specific test code
#---------------------------------------------------------------------
+---------

#---------------------------------------------------------------------
+---------
# Wrap up and report in
#---------------------------------------------------------------------
+---------


my $tests = $Test::ntest - 1;
$tests ||= 1;  # protect illegal div 0 error....
my $fail = @Test::FAILDETAIL;
my $ok = $tests - $fail;
print "\nRan $0 debug=$debug\nCompleted $tests tests $ok/$tests OK, fa
+iled $fail/$tests\n";
printf "%3.1f%% of tests completed successfully, %3.1f%% failed\n" , $
+ok*100/$tests, $fail*100/$tests;

if ( $debug and $fail ) {
    use Data::Dumper;
    print "\n",Dumper(@Test::FAILDETAIL);
}

sub run_renumber {
    rename $0, "$0.bak" or die "Rename $0 to $0.bak failed $!\n";
    open I, "$0.bak" or die "Can't open self $0.bak $!\n";
    open O, ">$0" or die "Can't write new file\n";
    chmod 0755, $0;
    my $num = 0;
    my $file = '';
    my $found_begin = 0;
    my $found_end   = 0;
    while (<I>) {
        $found_end   = 1 if m/# END/;
        $found_begin = 1 if m/# BEGIN/;
        if ( $found_begin and m/^\s*(ok\s*\(.*;)/ and ! $found_end ) {
            $num++;
            $file .= "$1    #$num\n";
        }
        else {
            $file .=  $_;
        }
    }
    $file =~ s/plan\s+tests\s*=>\s*\d+/plan tests => $num/;
    print O $file;
    close O;
    close I;
    print "Added test numbers 1..$num to $0 and fixed plan OK\n";
    unlink "$0.bak" or warn "Can't unlink backup $0.bak $!\n";
}

# find all the subs in a module
sub find_all_subs {
    my ( $MODULE ) = @_;
    $MODULE =~ s!::!/!g;
    my @subs = ();
    for my $dir ( @INC ) {
        print "Checking $dir/$MODULE.pm\n";
      next unless -e "$dir/$MODULE.pm";
        print "Found $dir/$MODULE.pm\n";
        open M, "$dir/$MODULE.pm" or die "Can't read $dir/$MODULE.pm $
+!\n";
        local $/;
        my $module = <M>;
        close M;
        @subs = $module =~ m/^\s*sub\s+(\w+)/gm;
      last;
    }
  return @subs;
}

sub run_add_test_stubs {
    my ( $MODULE, $IS_OO ) = @_;
    no strict;
    eval "require($MODULE)";
  die "Could not require $MODULE\n$@\n" if $@;
    my @exports;
    if ( $IS_OO ) {
        @exports = find_all_subs( $MODULE );
    }
    else {
        eval { my @exports_ok = eval "\@${MODULE}::EXPORT_OK"; push @e
+xports, @exports_ok };
        eval { my @export = eval "\@${MODULE}::EXPORT"; push @exports,
+ @export };
    }
  die "$MODULE has no \@EXPORT or \@EXPORT_OK functions\nIs it oo? If 
+so add oo as a command line arg\n\n\$ perl template Some::Module oo\n
+\n\$ perl template --help\n\n" unless @exports;
    printf "Found %d functions to test!\n", scalar @exports;
    my $num_tests = 1;
    my $imports   = $IS_OO ? ";\n\nmy \$obj;" : "qw(\n" . (join '', ma
+p{ "    $_\n" } @exports ) . ");\n";
    my $comment   = $IS_OO ? '# first use the $MODULE.pm module' : "# 
+first use the $MODULE.pm module and import all the \@EXPORT_OK functi
+ons";
    my $test_stubs = $IS_OO ? 
join "\n", map{ <<STUBS1;
# tests for $_()

#\$obj = $MODULE->new();
# oo tests
#ok( \$obj->$_(undef), '' );
#ok( \$obj->$_(0), '' );
#ok( \$obj->$_(''), '' );
#ok( \$obj->$_('some','args'), '' );

# direct calls in case you want them....
#ok( ${MODULE}::$_(undef), '' );
#ok( ${MODULE}::$_(0), '' );
#ok( ${MODULE}::$_(''), '' );
#ok( ${MODULE}::$_('some','args'), '' );

STUBS1
}@exports
:
join "\n", map{ <<STUBS2;
# tests for $_()

#ok( $_(undef), '' );
#ok( $_(0), '' );
#ok( $_(''), '' );
#ok( $_('some','args'), '' );

STUBS2
}@exports;

my $code=<<CODE;

$comment

use $MODULE $imports

# first make sure the module loaded OK
ok(1);    # test 1

$test_stubs

CODE
my $replacement_pod =<<'CODE';
=head1 Usage

You can call this script in three ways

script.t
script.t debug
script.t renum

When called with no command line are all the tests are run

When called with the debug option all tests are run + extra reporting

When called with any other command line arg, 'renum' for instance the 
+script will 
renumber all the tests within it and set the plan tests key to the cor
+rect value.

=head1 Synopsis of Test syntax

  use strict;
  use Test;
  # use a BEGIN block so we print our plan before MyModule is loaded
  BEGIN { plan tests => 14, todo => [3,4] }
  # load your module...
  use MyModule;
  ok(0); # failure
  ok(1); # success
  ok(0); # ok, expected failure (see todo list, above)
  ok(1); # surprise success!
  ok(0,1);             # failure: '0' ne '1'
  ok('broke','fixed'); # failure: 'broke' ne 'fixed'
  ok('fixed','fixed'); # success: 'fixed' eq 'fixed'
  ok('fixed',qr/x/);   # success: 'fixed' =~ qr/x/
  ok(sub { 1+1 }, 2);  # success: '2' eq '2'
  ok(sub { 1+1 }, 3);  # failure: '2' ne '3'
  ok(0, int(rand(2));  # (just kidding :-)
  my @list = (0,0);
  ok @list, 3, "\@list=".join(',',@list);      #extra diagnostics
  ok 'segmentation fault', '/(?i)success/';    #regex match
  skip($feature_is_missing, ...);    #do platform specific test

Note use the ok( blah, blah ) form rather than ok( blah == blah ) as w
+hen a 
test fails the first form tells you waht it got and what it expected. 
+The second
form with either be 1 or 0 - not so informative. 

=cut

if ( $ARGV[0] and $ARGV[0] ne 'debug' ) {
    run_renumber();
  exit;
}
CODE
    my @bits = split '::', $MODULE;
    my $outfile = 'stub_' . lc($bits[-1]) . '.t';
    open I, $0 or die "Can't open self $0 $!\n";
    open O, ">$outfile" or die "Can't write $outfile\n";
    local $/;
    my $data = <I>;
    $data =~ s/#<TEST CODE HERE>/$code/;                      # add th
+e stubs
    $data =~ s/=head2.*#leave this\n=cut/$replacement_pod/s;  # fix po
+d
    $data =~ s/sub run_add_test_stubs.*//s;                   # delete
+ this section
    $data =~ s/plan\s+tests\s*=>\s*\d+/plan tests => $num_tests/; # fi
+x test count
    print O $data;
    close O;
    close I;
    print "Wrote test stub file $outfile for $MODULE OK\n";
}

1;
Comment on Autogenerate Test Scripts
Download Code
Re: Autogenerate Test Scripts
by hsmyers (Canon) on Aug 02, 2003 at 23:14 UTC
    This is a plot, right!!? You're just trying to make it so easy to uses tests that we no longer have any excuses left at all. For shame! How can we remain slovenly and slip-shod if you continue on this path? You will doom us all to decency!!!

    --hsm

    "Never try to teach a pig to sing...it wastes your time and it annoys the pig."

Back to Snippets Section

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: snippet [id://280268]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others examining the Monastery: (17)
As of 2014-04-17 15:42 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    April first is:







    Results (453 votes), past polls