File Coverage

blib/lib/Test/Pod/Snippets.pm

Criterion	Covered	Total	%
statement	50	67	74.6
branch	3	10	30.0
condition	1	3	33.3
subroutine	16	18	88.8
pod	5	11	45.4
total	75	109	68.8

package Test::Pod::Snippets;

use warnings;
use strict;
use Carp;

use Object::InsideOut;
use Test::Pod::Snippets::Parser;

our $VERSION = '0.03_03';

my @parser_of   :Field;

my @do_verbatim  :Field :Default(1)      :Arg(extract_verbatim_bits);
my @do_methods   :Field :Default(0)      :Arg(extract_methods);
my @do_functions :Field :Default(0)      :Arg(extract_functions);
my @object_name  :Field :Default('$thingy') :Arg(object_name);

sub _init :Init {
    my $self = shift;

    $parser_of[ $$self ] = Test::Pod::Snippets::Parser->new;
    $parser_of[ $$self ]->{tps} = $self;
}

sub get_object_name {
    my $self = shift;
    return $object_name[ $$self ];
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub is_extracting_verbatim_bits { return $do_verbatim[ ${$_[0]} ] }
sub is_extracting_methods       { return $do_methods[ ${$_[0]} ] }
sub is_extracting_functions     { return $do_functions[ ${$_[0]} ] }

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub extract_verbatim_bits {
    my $self = shift;
    return $do_verbatim[ $$self ] = shift;
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub extract_methods {
    my $self = shift;
    return $do_methods[ $$self ] = shift;
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub extract_functions {
    my $self = shift;
    return $do_functions[ $$self ] = shift;
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub generate_snippets {
    my( $self, @files ) = @_;
    my $i = 1;

    print "generating snippets\n";

    for ( @files ) {
        my $testfile = sprintf "t/pod-snippets-%02d.t", $i++;
        print "\t$_ => $testfile\n";

        open my $fh, '>', $testfile
                or die "can't open $testfile for writing: $!\n";
        print {$fh} $self->extract_snippets( $_ );
        close $fh;
    }
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub extract_from_string {
    my ( $self, $string ) = @_;
    open my $pod_fh, '<', \$string;
    return $self->extract_snippets( $pod_fh );
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub extract_snippets {
    my( $self, $file ) = @_;

    my $filename_call = 'GLOB' ne ref $file;

    if( $filename_call and not -f $file ) {
        croak "$file doesn't seem to exist";
    }

    my $output;
    open my $fh, '>', \$output;

    if ( $filename_call ) {
        $parser_of[ $$self ]->parse_from_file( $file, $fh );
    }
    else {
        $parser_of[ $$self ]->parse_from_filehandle( $file, $fh );
    }

    my $filename = $filename_call ? $file : 'unknown';

    return <<"END_TESTS";
use Test::More qw/ no_plan /;

no warnings;
no strict;    # things are likely to be sloppy

ok 1 => 'the tests compile';

$output

ok 1 => 'we reached the end!';

END_TESTS

}

sub snippets_ok {
    my( $self, $file ) = @_;

    my $code = $self->extract_snippets( $file );

    eval $code;

    warn $@ if $@;

    return not $@;
}


1; # End of Test::Pod::Snippets

__END__