File Coverage

blib/lib/Test/Synopsis.pm

Criterion	Covered	Total	%
statement	94	94	100.0
branch	22	26	84.6
condition	6	9	66.6
subroutine	18	18	100.0
pod	2	2	100.0
total	142	149	95.3

package Test::Synopsis;

use strict;
use warnings;
use 5.008_001;

our $VERSION = '0.17'; # VERSION

use parent qw( Test::Builder::Module );
our @EXPORT = qw( synopsis_ok all_synopsis_ok );

use ExtUtils::Manifest qw( maniread );
my %ARGS;
 # = ( dump_all_code_on_error => 1 ); ### REMOVE THIS FOR PRODUCTION!!!
sub all_synopsis_ok {
  %ARGS = @_;

  my $manifest = maniread();
  my @files = grep m!^lib/.*\.p(od|m)$!, keys %$manifest
  or __PACKAGE__->builder->skip_all('No files in lib to test');

  __PACKAGE__->builder->no_plan();

  synopsis_ok(@files);
}

sub synopsis_ok {
    my @files = @_;

    for my $file (@files) {
        my $blocks = _extract_synopsis($file);
        unless (@$blocks) {
            __PACKAGE__->builder->ok(1, "No SYNOPSIS code");
            next;
        }

        my $block_num = 0;
        for my $block (@$blocks) {
            $block_num++;
            my ($line, $code, $options) = @$block;

            # don't want __END__ blocks in SYNOPSIS chopping our '}' in wrapper sub
            # same goes for __DATA__ and although we'll be sticking an extra '}'
            # into its contents; it shouldn't matter since the code shouldn't be
            # run anyways.
            $code =~ s/(?=(?:__END__|__DATA__)\s*$)/}\n/m;

            $options = join(";", @$options);
            my $test   = qq($options;\nsub{\n#line $line "$file"\n$code\n;});
            #use Test::More (); Test::More::note "=========\n$test\n========";
            my $ok     = _compile($test);

            # See if the user is trying to skip this test using the =for block
            if ( !$ok and $@=~/^SKIP:.+BEGIN failed--compilation aborted/si ) {
                $@ =~ s/^SKIP:\s*//;
                $@ =~ s/\nBEGIN failed--compilation aborted at.+//s;
                __PACKAGE__->builder->skip($@, 1);
            } else {
                my $block_name = $file;
                ## Show block number only if more than one block
                if (@$blocks > 1) {
                    $block_name .= " (section $block_num)";
                }
                __PACKAGE__->builder->ok($ok, $block_name)
                    or __PACKAGE__->builder->diag(
                        $ARGS{dump_all_code_on_error}
                        ? "$@\nEVALED CODE:\n$test"
                        : $@
                    );
            }
        }
    }
}

my $sandbox = 0;
sub _compile {
    package
        Test::Synopsis::Sandbox;
    eval sprintf "package\nTest::Synopsis::Sandbox%d;\n%s",
      ++$sandbox, $_[0]; ## no critic
}

sub _extract_synopsis
{
    my $file = shift;

    my $parser = Test::Synopsis::Parser->new;
    $parser->parse_file($file);
    $parser->{tsyn_blocks}
}

package
  Test::Synopsis::Parser; # on new line to avoid indexing

use Pod::Simple 3.09;
use parent 'Pod::Simple';

sub new
{
    my $self = shift->SUPER::new(@_);
    $self->accept_targets('test_synopsis');
    $self->merge_text(1);
    $self->no_errata_section(1);
    $self->strip_verbatim_indent(sub {
        my $lines = shift;
        my ($indent) = $lines->[0] =~ /^(\s*)/;
        $indent
    });

    $self->{tsyn_stack} = [];
    $self->{tsyn_options} = [];
    $self->{tsyn_blocks} = [];
    $self->{tsyn_in_synopsis} = '';

    $self
}

sub _handle_element_start
{
    my ($self, $element_name, $attrs) = @_;

    #Test::More::note Test::More::explain($element_name);
    #Test::More::note Test::More::explain($attrs);
    push @{$self->{tsyn_stack}}, [ $element_name, $attrs ];
}

sub _handle_element_end
{
    return unless $_[0]->{tsyn_stack};
    pop @{ $_[0]->{tsyn_stack} };
}

sub _handle_text
{
    return unless $_[0]->{tsyn_stack};
    my ($self, $text) = @_;
    my $elt = $self->{tsyn_stack}[-1][0];
    if ($elt eq 'head1') {
        if ($self->{tsyn_in_synopsis}) {
            # Exiting SYNOPSIS => Skip everything to the end
            delete $self->{tsyn_stack};
        }
        $self->{tsyn_in_synopsis} = $text =~ /SYNOPSIS\s*$/;
    } elsif ($elt eq 'Data') {
        # use Test::More; Test::More::note "XXX";
        my $up = $self->{tsyn_stack}[-2];
        if ($up->[0] eq 'for' && $up->[1]->{target} eq 'test_synopsis') {
            my $line = $up->[1]{start_line};
            my $file = $self->source_filename;
            push @{$self->{tsyn_options}}, qq<#line $line "$file"\n$text\n>;
        }
    } elsif ($elt eq 'Verbatim' && $self->{tsyn_in_synopsis}) {
        my $line = $self->{tsyn_stack}[-1][1]{start_line};
        push @{ $self->{tsyn_blocks} }, [
            $line,
            $text,
            $self->{tsyn_options},
        ];
        $self->{tsyn_options} = [];
    }
}


1;
__END__