#-------------------------------------------------------------------------------
# $URL$
# $Date$
# $Author$
# $Revision$
#-------------------------------------------------------------------------------
package Wetware::Test::CreateTestSuite;
use warnings;
use strict;
use Wetware::Test::Utilities qw(is_testsuite_module);
use English qw( -no_match_vars ) ;
use File::Basename qw(dirname);
use File::Find qw(find);
use File::Path;
use File::Spec;
use Readonly;
#-------------------------------------------------------------------------------
our $VERSION = 0.03;
# we could 'use constant' here, but....
Readonly::Scalar my $FAILURE_EXIT => 1;
Readonly::Scalar my $NORMAL_EXIT => 0;
Readonly::Hash my %t_dir_content_for => (
'pod-coverage.t' => sub { return content_for_pod_coverage_t(); },
'00_compile_pm.t' => sub { return content_for_compile_pm_t(); },
'01_test_classes.t' => sub { return content_for_test_class_t(); },
);
#-------------------------------------------------------------------------------
sub _init {
my ($self) = @_;
$self->{'SEARCH_DIR'} = './lib' unless $self->search_dir();
return $self;
}
#-------------------------------------------------------------------------------
# The Content group - these simple return here to documents.
#-------------------------------------------------------------------------------
sub content_for_head {
my $head_content =<<'EOX';
#-------------------------------------------------------------------------------
# $URL$
# $Date$
# $Author$
# $Revision$
#-------------------------------------------------------------------------------
# AUTO GENERATED by Wetware::Test::CreateTestSuite
EOX
return $head_content;
}
sub content_for_compile_pm_t {
my $head_content = content_for_head();
my $body_content =<<'EOX';
use strict;
use warnings;
use Test::More;
use Test::Compile;
all_non_testsuite_modules();
#-----------------------------------------------------------------------------
sub all_non_testsuite_modules {
my @modules = grep { $_ !~ m{/TestSuite.pm$} } all_pm_files();
plan tests => scalar @modules;
foreach my $module ( @modules ) {
pm_file_ok
($module);
}
return;
}
EOX
my $content = $head_content . $body_content;
return $content;
}
sub content_for_pod_coverage_t {
my $head_content = content_for_head();
my $body_content =<<'EOX';
use strict;
use warnings;
use Test::More;
#-----------------------------------------------------------------------------
# Ensure a recent version of Test::Pod::Coverage
my $min_tpc = 1.08;
eval "use Test::Pod::Coverage $min_tpc";
plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage"
if $@;
# Test::Pod::Coverage doesn't require a minimum Pod::Coverage version,
# but older versions don't recognize some common documentation styles
my $min_pc = 0.18;
eval "use Pod::Coverage $min_pc";
plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage"
if $@;
#-----------------------------------------------------------------------------
all_non_testsuite_pod();
#-----------------------------------------------------------------------------
sub all_non_testsuite_pod {
my @modules = grep { $_ !~ m{::TestSuite$} } all_modules();
plan tests => scalar @modules;
foreach my $module ( @modules ) {
pod_coverage_ok($module);
}
return;
}
EOX
my $content = $head_content . $body_content;
return $content;
}
sub content_for_test_class_t {
my $head_content = content_for_head();
my $body_content =<<'EOX';
use strict;
use warnings;
use FindBin qw($Bin);
use Wetware::Test::Class::Load "$Bin/../blib/lib/";
EOX
my $content = $head_content . $body_content;
return $content;
}
#-------------------------------------------------------------------------------
# back to normalish subs
#-------------------------------------------------------------------------------
sub find_pm {
my ($self, $directory) = @_;
my @pm;
my $wanted = sub {
my $file_name = $_;
my $full_path = $File::Find::name;
if ( $file_name =~ /\.pm$/ ) {
push @pm , $full_path ;
}
return
};
# this will filter out the CVS and .svn directories
# and while we are at it, any of the . dirs
my $preprocess = sub {
my (@dirs_found) = @_;
my @dirs_to_use = grep {
$_ ne 'CVS' && $_ ne '.svn' && $_ !~ /^\./
} @dirs_found;
return @dirs_to_use;
};
my $options = { 'wanted' => $wanted, 'preprocess' => $preprocess};
File::Find::find( $options, $directory );
return @pm;
}
sub _test_suite_dir_for {
my ($self, $file_path) = @_;
(my $test_suite_dir = $file_path ) =~ s{.pm$}{};
return $test_suite_dir;
}
sub has_testsuite {
my ($self, $file_path) = @_;
my $test_suite_dir = $self->_test_suite_dir_for($file_path);
return unless -d $test_suite_dir;
my $test_suite_path = File::Spec->join($test_suite_dir, 'TestSuite.pm');
return $self->is_testsuite($test_suite_path);
}
sub is_testsuite {
my ($self, $file_path) = @_;
return is_testsuite_module($file_path);
}
#-------------------------------------------------------------------------------
# the ALL CAPS FOR PARAMS style - till I come up with a better way.
#
sub new {
my ($class, %params) = @_; # Normalize the keys of the params hash to ALL_CAPS.
my %uppercase_params = map { ( uc $_ => $params{$_} ) } keys %params;
my $self = bless \%uppercase_params, $class;
return $self->_init();
}
sub overwrite_t_files {
my $self = shift;
return $self->{'OVERWRITE_T_FILES'};
}
sub parse_pm_file {
my ($self, $pm_path) = @_;
my ($pkg_name,$sub_name, @sub_names);
my @lines = $self->slurp($pm_path);
LINE:
foreach my $line (@lines) {
chomp $line;
$line =~ s/#.*//g; # remove comments.
next LINE unless $line;
if ( my ($tmp_name) = ($line =~ m/package\s*([^\s;]+)/) ) {
$pkg_name = $tmp_name;
next LINE; # we found the package line
}
if ( ($sub_name) = ($line =~ m/sub\s*([^\s]+)/) ) {
push @sub_names , $sub_name;
next LINE; # we found the package line
}
}
return ($pkg_name, @sub_names);
}
sub pm_that_need_test_suite {
my ($self, $dir ) = @_;
my @pm_paths = $self->find_pm($dir);
my @pm_needing_test_suite;
PM:
foreach my $pm_path (@pm_paths) {
next PM if $self->is_testsuite($pm_path);
next PM if $self->has_testsuite($pm_path);
push @pm_needing_test_suite, $pm_path;
}
return @pm_needing_test_suite;
}
sub preview {
my $self = shift;
return $self->{'PREVIEW'};
}
sub run {
my ($self) = @_;
my $search_dir = $self->search_dir();
my @pm = $self->pm_that_need_test_suite($search_dir);
if ( $self->preview() ){
print "The following PM files do not yet have a TestSuite.pm\n";
foreach my $pm_path (@pm) {
print "\t -- ${pm_path}\n";
}
# TODO: should we show the t/ files that could be set?
return $NORMAL_EXIT;
}
$self->write_testsuites_for(@pm);
$self->write_t_dir_files();
return $NORMAL_EXIT;
}
sub search_dir {
my $self = shift;
return $self->{'SEARCH_DIR'};
}
sub slurp {
my ($self, $file) = @_;
open(my $fh, '<', $file)
|| Carp::confess("unable to open '$file': $OS_ERROR");
local $INPUT_RECORD_SEPARATOR ;
my $content = <$fh>;
close $fh;
my @lines = split(/\n/, $content); # want them as lines.
return @lines;
}
sub t_dir {
my $self = shift;
my $search_dir = $self->search_dir();
my $up_dir = dirname($search_dir);
my $t_dir = File::Spec->join($up_dir, 't');
return $t_dir;
}
sub test_sub_for {
my ($self, $sub_name) = @_;
my $test_sub =<<'EOX';
#-----------------------------------------------------------------------------
sub test_SUB_NAME : Test(1) {
my $self = shift;
my $class = $self->class_under_test();
Test::More::can_ok($class, 'SUB_NAME');
return $self;
}
EOX
$test_sub =~ s/SUB_NAME/$sub_name/g;
return $test_sub;
}
sub usage_lines {
my $use_lines =<<'EOX';
use strict;
use warnings;
use Wetware::Test::Suite;
use base q{Wetware::Test::Suite};
use Test::More;
EOX
return $use_lines;
}
sub useful_test_case_content {
my $use_lines =<<'EOX';
#-----------------------------------------------------------------------------
sub test_new : Test(1) {
my $self = shift;
my $object = $self->object_under_test();
my $expected_class = $self->class_under_test();
Test::More::isa_ok( $object, $expected_class );
return $self;
}
#-----------------------------------------------------------------------------
# a template for the next start of a test of another method
# sub test_new_method_name : Test(1) {
# my $self = shift;
# my $class = $self->class_under_test();
# Test::More::can_ok($class, 'new_method_name');
# return $self;
# }
EOX
return $use_lines;
}
sub write_test_suite_file {
my ($self,$test_suite_dir, $pkg_name, @subs) = @_;
my $test_suite_file_path = File::Spec->join($test_suite_dir, 'TestSuite.pm');
my $head_content = $self->content_for_head();
$self->_content_to($head_content,$test_suite_file_path);
my $package_line = "package ${pkg_name}::TestSuite;\n";
$self->_append_content_to($package_line,$test_suite_file_path);
my $usage_lines = $self->usage_lines();
$self->_append_content_to($usage_lines,$test_suite_file_path);
my $comment_line = q{#-----------------------------------------------------------------------------};
my $use_pkg_line = "use ${pkg_name};\n${comment_line}\nsub class_under_test { return \'${pkg_name}\'; }\n";
$self->_append_content_to($use_pkg_line,$test_suite_file_path);
my $useful_test_case_content = $self->useful_test_case_content();
$self->_append_content_to($useful_test_case_content,$test_suite_file_path);
SUB_NAME:
foreach my $sub_name (@subs) {
next SUB_NAME if $sub_name eq 'new';
my $test_sub = $self->test_sub_for($sub_name);
$self->_append_content_to($test_sub,$test_suite_file_path);
}
$self->_append_content_to("\n${comment_line}\n1;\n",$test_suite_file_path);
return;
}
sub write_testsuites_for {
my ($self, @pm_paths) = @_;
return unless @pm_paths; # no work, no worry.
foreach my $pm_path ( @pm_paths) {
my ($pkg_name, @subs) = $self->parse_pm_file($pm_path);
my $test_suite_dir = $self->_test_suite_dir_for($pm_path);
if ( ! -d $test_suite_dir ) {
File::Path::mkpath( $test_suite_dir )
|| Carp::confess("Unable to make dir '$test_suite_dir':$OS_ERROR");
}
$self->write_test_suite_file($test_suite_dir, $pkg_name, @subs);
}
return $self;
}
#-------------------------------------------------------------------------------
sub _t_dir_files {
my @t_dir_files = keys %t_dir_content_for;
return @t_dir_files;
}
sub write_t_dir_files {
my ($self) = @_;
my $t_dir = $self->t_dir();
# will want a logging system at some point
# to note that this is not the directory....
return unless -d $t_dir;
my @t_dir_files = $self->_t_dir_files();
my $over_write = $self->overwrite_t_files();
T_FILE:
foreach my $t_file (@t_dir_files) {
my $t_file_path = File::Spec->join($t_dir, $t_file);
# If the over_write flag is set, then we do
# not care if the file exists. Otherwise, we skip
# any of the files that exist.
if ( ! $over_write ) {
next T_FILE if -f $t_file_path;
}
my $content = $t_dir_content_for{$t_file}->();
$self->_content_to( $content, $t_file_path );
}
return $self;
}
sub _content_to {
my ($self, $content, $file_path, $mode) = @_;
$mode ||= '>';
open(my $fh, $mode , $file_path)
or Carp::confess("unable to write '$file_path' : $OS_ERROR");
print $fh $content;
close $fh;
return;
}
sub _append_content_to {
my ($self, $content, $file_path) = @_;
my $mode = '>>';
return $self->_content_to($content, $file_path, $mode);
}
#-------------------------------------------------------------------------------
1;
__END__
=pod
=head1 NAME
Wetware::Test::CreateTestSuite - for creating TestSuite.pm
=head1 SYNOPSIS
use Wetware::Test::CreateTestSuite;
my $test_stuite_creator = Wetware::Test::CreatTestSuite->new( %{$options} );
$test_stuite_creator->run();
=head1 DESCRIPTION
The goal: automate the process of creating a Test::Class based TestSuite.pm
for each module Foo. So that there will be at least a Foo::TestSuite.pm frame
that will have a working test_new() method.
It will also seek to install into the t/ of the "search_dir" the three
basic scripts.
The new 01_test_class.t script requires that there is the
Wetware::Test::Class::Load that will skip over the CVS and .svn directories
that may get copied into blib/lib from lib by the basic Module::Build
process.
=head1 METHODS
=head2 new( %params)
Constructs the immutable CreateTestSuite object.
=head2 run()
At present I do not see a good reason for any other public methods.
Since it just needs to be constructed and run.
It will exit with the normal exit value for unix of '0'.
=head1 DemiPrivate METHODS
This is the list of mostly private methods, but are listed so that IF anyone
comes up with a good case to subclass this...
=head2 write_testsuites_for(@pm)
Given a list of pm_paths, write the TestSuite.pm.
=head2 slurp($file)
Nice slurp the data in.
=head2 preview()
accessor to preview.
=head2 pm_that_need_test_suite($dir)
Calls C<find_pm()> to get a list of pm in the $dir.
It then filgers out those that are TestSuite.pm, or have
a TestSuite.pm module.
The list returned is those that will need to have one added.
=head2 write_t_dir_files()
Writes out the alternative C<.t> files into C<t/>. These files are:
=over
=item * 00_compile_pm.t
=item * 01_test_class.t
=item * pod-coverage.t
=back
Note, these will not overwrite existing files, so IF this is
run after module-starter has installed the default pod-coverage.t
that file should be removed first.
TODO: what if we had a cli option for this? some sort of
I<--t_files_only>
=head2 parse_pm_file()
TBD
=head2 is_testsuite($file_path)
wrapper on Wetware::Test::Utilities::is_testsuite_module;
=head2 has_testsuite($module_path)
Constructs the path to the Foo::TestSuite, given
the path to the Foo Module. Then uses the file path
to the TestSuite to call C<is_testsuite()>.
It will short circuit, if there is no Foo directory.
=head2 find_pm($directory)
A wrapper on File::Find:find() that has both a wanted()
and a preprocess() method passed in as an option.
It will currently skip over any directory that is begins
with 'CVS', '.svn' and any that begins with a '.'.
=head2 search_dir()
Accessor that returns the search directory.
=head2 t_dir()
returns the path to where the t/ is expected to be.
=head2 overwrite_t_files()
Accessor to named command line value.
=head2 write_test_suite_file($test_dir, $pkg_name, @subnames)
Given the directory where TestSuite.pm is to be written,
the pkg_name it will test, and a list of subnames,
write out the TestSuite.pm file itself.
=head1 CONTENT METHODS
There is a debate about whether or not we should have a
get_resources_from_INC() method that would find these
as template files..... instead of having these three
hereto document methods....
=head2 content_for_head() - returns the 'svn' comment block
=head2 content_for_compile_pm_t()
=head2 content_for_pod_coverage_t()
=head2 content_for_test_class_t()
If we shift to a get_resources_from_INC() approach, then
these will be the access methods to that solution.
=head2 test_sub_for($sub_name)
Creates the content for the test_SUBNAME() sub.
=head2 usage_lines()
Returns a set of stock use lines.
=head2 useful_test_case_content()
Adds a test_new() and a commented out test_methodNameHere() method.
=head1 CHANGE STOCK test files
There are two semi standard .t test scripts that need to
be changed to work and play well with the TestSuite approach,
since if one attempts to do the simple Test::Compile of
any Module that inherits from a Test::Class based module
with the INIT block, they will fail becaue 'it is too
late for INIT' - this is also true of Pod Coverage.
So the fix is to call a sub.
Modify pod-coverage.t to use:
=over
all_non_testsuite_pod();
#-------------------------------------------------------------
sub all_non_testsuite_pod {
my @modules = grep { $_ !~ m{::TestSuite$} } all_modules();
plan tests => scalar @modules;
foreach my $module ( @modules ) {
pod_coverage_ok($module);
}
return;
}
=back
And it will filter out the modules *::TestSuite.
The compile_pm script is about the same, except that it runs with
module file names:
=over
all_non_testsuite_modules();
#----------------------------------------------------------------
sub all_non_testsuite_modules {
my @modules = grep { $_ !~ m{/TestSuite.pm$} } all_pm_files();
plan tests => scalar @modules;
foreach my $module ( @modules ) {
pm_file_ok
($module);
}
return;
}
=back
You can download this module from the CPAN and look at the
t/ directory for the specific test files.
=head1 AUTHOR
"drieux", C<< <"drieux [AT] at wetware.com"> >>
=head1 BUGS
Please report any bugs or feature requests
to C<bug-wetware-test-createtestsuite at rt.cpan.org>, or through
the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Wetware-Test-CreateTestSuite>.
I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc Wetware::Test::CreateTestSuite
You can also look for information at:
=over 4
=item * RT: CPAN's request tracker
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Wetware-Test-CreateTestSuite>
=item * AnnoCPAN: Annotated CPAN documentation
L<http://annocpan.org/dist/Wetware-Test-CreateTestSuite>
=item * CPAN Ratings
L<http://cpanratings.perl.org/d/Wetware-Test-CreateTestSuite>
=item * Search CPAN
L<http://search.cpan.org/dist/Wetware-Test-CreateTestSuite/>
=back
=head1 COPYRIGHT & LICENSE
Copyright 2009 "drieux", all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
# End of Wetware::Test::CreateTestSuite