File Coverage

blib/lib/Pinwheel/DocTest.pm

Criterion	Covered	Total	%
statement	257	258	99.6
branch	43	44	97.7
condition	22	23	95.6
subroutine	66	66	100.0
pod	0	4	0.0
total	388	395	98.2

package Pinwheel::DocTest;

use strict;
use warnings;

use Data::Dumper;
use PPI;
use Test::Builder;
use Test::More;


sub p
{
    local $Data::Dumper::Indent = 0;
    local $Data::Dumper::Sortkeys = 1;
    local $Data::Dumper::Terse = 1;
    local $Data::Dumper::Useqq = 1;
    return Dumper(shift) . "\n";
}

sub is_silent
{
    my ($coderef, $d) = @_;

    $d = PPI::Document->new($coderef);
    return $d->find_any(sub {
        $_[1]->isa('PPI::Token::Operator') and $_[1]->content eq '='
    });
}

sub _expand_ellipsis
{
    my ($s) = @_;
    $s = join('.*',
        map { s/([\$\^\.\*\+\?\(\)\{\}\[\]\|\\])/\\$1/g; $_ }
        split(/\.\.\./, $s)
    );
    return qr/^$s$/s;
}

sub run_tests
{
    my ($pkg, $tests) = @_;
    my ($test, $fh, $testfn, $output, $got);

    $test = Test::More->builder;
    $fh = $test->todo_output;
    local $Test::Builder::Level = 0;
    foreach (@$tests) {
        my ($input, $expected, $line, $comment) = @$_;
        tie(*STDOUT, 'Pinwheel::DocTest::CaptureOut');
        $got = eval qq{
            package $pkg;
            no strict qw(vars subs refs);
#line $line "console"
            $input;
        };
        $output = ;
        untie(*STDOUT);
        if ($@) {
            $got = $@;
        } elsif (is_silent(\$input)) {
            $got = undef;
        } else {
            $got = p($got);
            $got = $output . $got if defined($output);
        }
        if (defined($expected) && $expected =~ /\.\.\./) {
            $expected = _expand_ellipsis($expected);
            $testfn = 'like';
        } else {
            $testfn = 'is_eq';
        }
        if ($comment) {
            $comment =~ s/^\s*\n//s;
            $comment =~ s/\s*$//;
            $comment =~ s/\n/\n# /g;
            print $fh "# $comment\n";
        }
        eval qq{
            package $pkg;
#line $line "console"
            \$test->$testfn(\$got, \$expected);
        };
    }
}


sub test_file
{
    my ($filename) = @_;
    my ($fh, $pkg, $end, @tests);
    my ($in_doctest, $indent, $input, $output, $line, $comment);

    open($fh, "< $filename");
    $pkg = caller();
    $end = 0;
    $in_doctest = 0;

    while (!$end) {
        $_ = <$fh>;
        $end = !defined($_);
        # Fake a blank line at the end to ensure the final test is picked up
        $_ = '' if $end;

        if (/^=begin\s+doctest\b/) {
            $in_doctest = 1;
        } elsif (!$in_doctest) {
            next;
        } elsif (/^(\s*)>>> (.+)/) {
            if (defined($input)) {
                push @tests, [$input, $output, $line, $comment];
                $comment = undef;
            }
            $indent = $1;
            $input = $2 . "\n";
            $output = undef;
            $line = $.;
        } elsif (defined($input) && (/^\s*$/ || /^=cut\b/)) {
            $in_doctest = 0 if /^=cut\b/;
            push @tests, [$input, $output, $line, $comment];
            $input = undef;
            $comment = undef;
        } elsif (!defined($input)) {
            if (/^=cut\b/) {
                $in_doctest = 0;
            } else {
                $comment = ($comment || '') . $_;
            }
        } elsif (!defined($output) && /^$indent\.\.\. (.+)/) {
            $input .= $1 . "\n";
        } elsif (/^$indent\s*$/) {
            $output = ($output || '') . "\n";
        } else {
            /^$indent(.+)/;
            $output = ($output || '') . $1 . "\n";
        }
    }
    run_tests($pkg, \@tests);

    close($fh);
}



package Pinwheel::DocTest::CaptureOut;

sub TIEHANDLE
{
    return bless([], $_[0]);
}

sub PRINTF
{
    my ($self, $format, @args) = @_;
    push @$self, sprintf($format, @args);
}

sub PRINT
{
    my ($self, @args) = @_;
    push @$self, join('', @args);
}

sub READLINE
{
    my ($self) = @_;
    return scalar(@$self) ? join('', @$self) : undef;
}



package Pinwheel::DocTest::Mock;

use Carp;
use overload '&{}' => \&getfn;

our $AUTOLOAD;


sub new
{
    my ($class, $name) = @_;
    return bless({name => $name, results => {}}, $class);
}

sub getfn
{
    my ($self) = @_;

    return sub {
        my $result;
        print "Called $self->{name} with " . Pinwheel::DocTest::p(\@_);
        $result = $self->{results}{''};
        return $result->(@_) if (ref($result) eq 'CODE');
        return $result;
    };
}

sub AUTOLOAD
{
    my $self = shift;
    my ($name, $result);

    $name = $AUTOLOAD;
    $name =~ s/.*:://;
    return unless ($name =~ /[a-z]/);
    if ($name =~ /(.+)_returns$/ || $name =~ /^returns$/) {
        $self->{results}{$1 || ''} = shift;
        return;
    }

    print "Called $self->{name}\->$name with " . Pinwheel::DocTest::p(\@_);
    $result = $self->{results}{$name};
    return $result->(@_) if (ref($result) eq 'CODE');
    return $result;
}


1;