File Coverage

blib/lib/Test/Structure.pm

Criterion	Covered	Total	%
statement	45	45	100.0
branch	4	12	33.3
condition	1	3	33.3
subroutine	11	11	100.0
pod	4	4	100.0
total	65	75	86.6

package Test::Structure;
use warnings;
use strict;
use PPI;
use File::Spec::Functions;

my $CLASS = __PACKAGE__;

use base 'Test::Builder::Module';

=head1 NAME

Test::Structure - Test for the structure of a package

=head1 VERSION

Version 0.04

=cut

our $VERSION = '0.04';

=head1 SYNOPSIS

Have you ever wished that you could build tests based on the structure of a package, not
how a package acts. Ya me either, but I've bumped in to a situation where I needed it.

    use Test::Structure tests => 5;

    require_ok( 'My::Package' );
    has_includes( 'My::Package', qw{My::Other::Package Some::Other::Package} );
    has_subs( 'My::Package', qw{this that} );
    has_commetns( 'My;::Package' );
    has_pod( 'My::Package' );

=head1 EXPORT

=cut

our @EXPORT = qw{ has_includes
                  has_subs
                  has_comments
                  has_pod
               };
# PRIVATE: take My::Package and build the right path for it
sub _pkg2path { catfile( split /::/, shift ) . '.pm' };

# PRIVATE: build up a PPI::Document for the given package
sub _doc {
   my $pkg = shift;
   eval sprintf q{require %s}, $pkg;
   my $doc = PPI::Document->new( $INC{Test::Structure::_pkg2path($pkg)} || $pkg );
   $doc;
}

=head2 has_includes

=cut

sub has_includes ($@) {
   my $pkg = shift;
   my $tb  = $CLASS->builder;
   my $doc = Test::Structure::_doc($pkg);
   my %inc = map{ $_->module => 1 }
             @{ $doc->find('PPI::Statement::Include') } ;
   my @missing =  grep{ ! $inc{$_} } @_ ;
   $tb->ok(! scalar( @missing ) )
      || $tb->diag( sprintf qq{Package %s is missing the following package%s%s},
                            $pkg,
                            (scalar(@missing)>1) ? 's' : '',
                            join qq{\n - }, '', @missing
                  );
}

=head2 has_subs

=cut

sub has_subs {
   my $pkg = shift;
   my $tb  = $CLASS->builder;
   my $doc = Test::Structure::_doc($pkg);
   my %subs = map {$_->name => 1}
              grep{ !$_->isa('PPI::Statement::Scheduled')}
              @{$doc->find('PPI::Statement::Sub')};

   my @missing =  grep{ ! $subs{$_} } @_ ;
   $tb->ok(! scalar( @missing ) )
      || $tb->diag( sprintf qq{Package %s does not define the following sub%s%s},
                            $pkg,
                            (scalar(@missing)>1) ? 's' : '',
                            join qq{\n - }, '', @missing
                  );
}


=head2 has_pod

=cut

sub has_pod ($) {
   my $pkg = shift;
   my $tb  = $CLASS->builder;
   $tb->ok( Test::Structure::_doc($pkg)->find_any('PPI::Token::Pod'), sprintf q{Package %s has POD.}, $pkg )
      || $tb->diag( sprintf q{Package %s does not seem to have any POD.}, $pkg );
}

=head2 has_comments

=cut

sub has_comments ($) {
   my $pkg = shift;
   my $tb  = $CLASS->builder;
   $tb->ok( Test::Structure::_doc($pkg)->find_any('PPI::Token::Comment'), sprintf q{Package %s has comments.}, $pkg )
      || $tb->diag( sprintf q{Package %s does not seem to have any comments.}, $pkg );
}

=head1 AUTHOR

notbenh, C<<  >>

=head1 BUGS

Please report any bugs or feature requests to C, or through
the web interface at L.  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 Test::Structure


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * Search CPAN

L

=back


=head1 ACKNOWLEDGEMENTS


=head1 LICENSE AND COPYRIGHT

Copyright 2010 notbenh.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.


=cut

1;