script.t renum

##</code><code>##

#!/usr/bin/perl -w

use strict;
use Test;
# use the required libraries ( you will need to edit this for your devel 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 when 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, failed $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 @exports, @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 '', map{ "    $_\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 functions";
    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 correct 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 when 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 the stubs
    $data =~ s/=head2.*#leave this\n=cut/$replacement_pod/s;  # fix pod
    $data =~ s/sub run_add_test_stubs.*//s;                   # delete this section
    $data =~ s/plan\s+tests\s*=>\s*\d+/plan tests => $num_tests/; # fix test count
    print O $data;
    close O;
    close I;
    print "Wrote test stub file $outfile for $MODULE OK\n";
}

1;