Extract inline tests when Makefile.PL is run, if we're not an end

[gitmo/Moose.git] / extract-inline-tests

#!/usr/bin/perl

use strict;
use warnings;

{
    package My::Extract;

    use base 'Test::Inline::Extract';

    # This extracts the SYNOPSIS in addition to code specifically
    # marked for testing
    my $search = qr/
		(?:^|\n)                           # After the beginning of the string, or a newline
		(                                  # ... start capturing
		                                   # EITHER
			package\s+                            # A package
			[^\W\d]\w*(?:(?:\'|::)[^\W\d]\w*)*    # ... with a name
			\s*;                                  # And a statement terminator
                |
                        =head1[ \t]+SYNOPSIS\n
                        .*?
                        (?=\n=)
		|                                  # OR
			=for[ \t]+example[ \t]+begin\n        # ... when we find a =for example begin
			.*?                                   # ... and keep capturing
			\n=for[ \t]+example[ \t]+end\s*?      # ... until the =for example end
			(?:\n|$)                              # ... at the end of file or a newline
		|                                  # OR
			=begin[ \t]+(?:test|testing)\b        # ... when we find a =begin test or testing
			.*?                                   # ... and keep capturing
			\n=end[ \t]+(?:test|testing)\s*?      # ... until an =end tag
			(?:\n|$)                              # ... at the end of file or a newline
		)                                  # ... and stop capturing
		/isx;

    sub _elements {
	my $self     = shift;
	my @elements = ();
	while ( $self->{source} =~ m/$search/go ) {
            my $elt = $1;

            # A hack to turn the SYNOPSIS into something Test::Inline
            # doesn't barf on
            if ( $elt =~ s/=head1[ \t]+SYNOPSIS/=begin testing SETUP\n\n{/ ) {
                $elt .= "}\n\n=end testing SETUP";
            }

            push @elements, $elt;
	}

        # If we have just one element it's a SYNOPSIS, so there's no
        # tests.
        return unless @elements > 1;

        if ( @elements && $self->{source} =~ /=head1 NAME\n\n(Moose::Cookbook\S+)/ ) {
            unshift @elements, 'package ' . $1 . ';';
        }

	(List::Util::first { /^=/ } @elements) ? \@elements : '';
    }
}

{
    package My::Content;

    use base 'Test::Inline::Content::Default';

    sub process {
        my $self = shift;

        my $base = $self->SUPER::process(@_);

        $base =~ s/(\$\| = 1;)/use Test::Exception;\n$1/;

        return $base;
    }
}

use File::Find::Rule;
use Test::Inline;


my $target = 't/000_recipes';

for my $t_file ( File::Find::Rule->file->name(qr/\.t$/)->in($target) ) {
    unlink $t_file or die "Cannot unlink $t_file: $!";
}

my $inline = Test::Inline->new(
    verbose        => 1,
    readonly       => 1,
    output         => $target,
    ExtractHandler => 'My::Extract',
    ContentHandler => 'My::Content',
);

for my $pod (
    File::Find::Rule->file->name(qr/\.pod$/)->in('lib/Moose/Cookbook') ) {
    $inline->add($pod);
}

$inline->save;