File Coverage

blib/lib/Test2/Util/Sub.pm

Criterion	Covered	Total	%
statement	53	54	98.1
branch	14	18	77.7
condition	1	3	33.3
subroutine	13	13	100.0
pod	2	5	40.0
total	83	93	89.2

package Test2::Util::Sub;
use strict;
use warnings;

our $VERSION = '0.000156';

use Carp qw/croak carp/;
use B();

our @EXPORT_OK = qw{
    sub_info
    sub_name

    gen_reader gen_writer gen_accessor
};
use base 'Exporter';

sub gen_reader {
    my $field = shift;
    return sub { $_[0]->{$field} };
}

sub gen_writer {
    my $field = shift;
    return sub { $_[0]->{$field} = $_[1] };
}

sub gen_accessor {
    my $field = shift;
    return sub {
        my $self = shift;
        ($self->{$field}) = @_ if @_;
        return $self->{$field};
    };
}

sub sub_name {
    my ($sub) = @_;

    croak "sub_name requires a coderef as its only argument"
        unless ref($sub) eq 'CODE';

    my $cobj = B::svref_2object($sub);
    my $name = $cobj->GV->NAME;
    return $name;
}

sub sub_info {
    my ($sub, @all_lines) = @_;
    my %in = map {$_ => 1} @all_lines;

    croak "sub_info requires a coderef as its first argument"
        unless ref($sub) eq 'CODE';

    my $cobj    = B::svref_2object($sub);
    my $name    = $cobj->GV->NAME;
    my $file    = $cobj->FILE;
    my $package = $cobj->GV->STASH->NAME;

    my $op = $cobj->START;
    while ($op) {
        push @all_lines => $op->line if $op->can('line');
        last unless $op->can('next');
        $op = $op->next;
    }

    my ($start, $end, @lines);
    if (@all_lines) {
        @all_lines = sort { $a <=> $b } @all_lines;
        ($start, $end) = ($all_lines[0], $all_lines[-1]);

        # Adjust start and end for the most common case of a multi-line block with
        # parens on the lines before and after.
        if ($start < $end) {
            $start-- unless $start <= 1 || $in{$start};
            $end++   unless $in{$end};
        }
        @lines = ($start, $end);
    }

    return {
        ref        => $sub,
        cobj       => $cobj,
        name       => $name,
        file       => $file,
        package    => $package,
        start_line => $start,
        end_line   => $end,
        all_lines  => \@all_lines,
        lines      => \@lines,
    };
}

1;

__END__