File Coverage

blib/lib/Test/Subunits.pm

Criterion	Covered	Total	%
statement	70	74	94.5
branch	19	22	86.3
condition	7	9	77.7
subroutine	15	15	100.0
pod			n/a
total	111	120	92.5

package Test::Subunits;

use 5.010;
use strict;
use warnings;

our $VERSION = '0.000003';

sub import {
    # Client code passes in filename or module name...
    our (undef, $source) = @_;

    if (!defined $source || !length($source)) {
        _croak( q{No argument supplied to 'use Test::Subunits'} );
    }

    # Locate file in library path...
    $source = _locate($source);

    # Extract source code...
    my $source_code = _slurp($source);

    # Accumulate code to be extracted, while tracking line numbers...
    my $extracted_code = q{};
    my $line_number    = 1;

    # Locate and isolate subunits...
    $source_code =~ s{
        \G ^ (?&ws)
        (?:
            # A bracketed subunit...
            (? \#\#\{ )
            (?: # Optional subroutine wrapper specification...
                    (?&ws)     (?  (?&ident)     )
                    (?&ws)     (?   (?¶mlist) )
                (?: (?&ws) --> (?  (?&whatever)  ) )?
            )?
            (?&ws) \n
            (?
                .*?
                ^ (?&ws) \#\#\} (?&ws) (?&eol)
            )
        |
            # A paragraphed subunit...
            (? \#\#: )
            (?: # Optional subroutine wrapper specification...
                    (?&ws)     (?  (?&ident)     )
                    (?&ws)     (?   (?¶mlist) )
                (?: (?&ws) --> (?  (?&whatever)  ) )?
            )?
            (?&ws) \n
            (?
                .*?
                ^ (?&ws) (?&eol)
            )
        |
            # Catch junk after opening delimiters...
            (?  \#\#[:\{] (?&ws) \S (?&whatever) ) (?&eol)
        |
            # Catch unmatched delimiters...
            (?  \#\#[{}]          ) (?&whatever)   (?&eol)
        |
            # Catch unknown delimiters...
            (?    \#\#\S            ) (?&whatever)   (?&eol)
        |
            # One-or-more consecutive single-line subunits...
            (? \#\# )
            (?
                (?&whatever) (?&eol)
                (?: ^ (?&ws) \#\# (?=\s) (?&whatever) (?&eol) )*+
            )
        |
            # Ignore anything else...
            (?&whatever) (?&eol)
        )

        (?(DEFINE)
            (?
                \( (?&ws) (?&var) (?: (?&ws) , (?&ws) (?&var) )*+ (?&ws) \)
            )
            (?       [\$\@%] (?&ident)  )
            (?        \h*+               )
            (?  (?-s: .*+ )        )
            (?     [^\W\d] \w*+       )
            (?       \n | \Z            )
        )
    }{
        # Every match consumes at least one line...
        $line_number++;

        # Handle bad delimiters...
        if (exists $+{UNMATCHED_DELIM}) {
            my $where = "at $source line " . ($line_number - 1);
            $extracted_code .= qq(BEGIN { die "Unmatched $+{UNMATCHED_DELIM} $where\n" });
        }
        elsif (exists $+{UNKNOWN_DELIM}) {
            my $where = "at $source line " . ($line_number - 1);
            $extracted_code .= qq(BEGIN { die "Unrecognized subunit marker ($+{UNKNOWN_DELIM}) $where\n" });
        }
        elsif (exists $+{INVALID_WRAPPER}) {
            my $where = "at $source line " . ($line_number - 1);
            $extracted_code .= qq(BEGIN { die "Invalid wrapper specification: $+{INVALID_WRAPPER} $where\n" });
        }

        # Remember anything that was extracted...
        elsif (exists $+{EXTRACTED}) {
            my $extracted = $+{EXTRACTED};

            # Track how many lines the extracton covered...
            my $extracted_lines = ($extracted =~ tr/\n//);

            # Wrap in a subroutine, if requested...
            if (exists $+{SUBNAME}) {
                # If no return specification, return original parameter list...
                my $retexpr = $+{RETEXPR} // $+{PARAMS};

                # Build the wrapper...
                $extracted = "sub $+{SUBNAME} { my $+{PARAMS} = \@_;\n"
                           . $extracted
                           . "return $retexpr; }\n";
            }

            # Remember the extracted code (and where it was in the original file)...
            $extracted_code .= " # line $line_number $source\n" . $extracted;

            # Track the extra lines that have been matched...
            $line_number += $extracted_lines;
        }
    }egxms;

    # Remove any extra internal ## lines...
    $extracted_code =~ s{ ^ \h*+ \# \#[{}\s]? }{}gxms;

    # Compile the code in the caller's namespace...
    my $target_package = caller;
    eval qq{
        package $target_package;
        $extracted_code;
        1;
    } or die;
}

sub _croak {
    require Carp;
    Carp::croak(@_);
}

sub _slurp {
    local (@ARGV, $/) = shift;
    return readline();
}

sub _locate {
    my ($source) = @_;
    my $orig_source = $source;

    # Convert module name to filename if necessary...
    if ($source =~ m{^\w+(?:::\w+)*$}) {
        $source =~ s{::}{/}g ;
        $source .= '.pm';
    }

    # Try within all the standard inclusion directories...
    for my $path (@INC) {
        my $file = "$path/$source";
        return $file if -e $file;
    }

    # Finally, try the exact path by itself...
    return $source if -e $source;

    # Otherwise give up with extreme prejudice...
    _croak( qq{Test::Subunits can't locate requested source file: $orig_source} );
}


1; # Magic true value required at end of module
__END__