File Coverage

blib/lib/Test/Stream/Util.pm

Criterion	Covered	Total	%
statement	178	194	91.7
branch	50	66	75.7
condition	36	58	62.0
subroutine	35	36	97.2
pod	10	12	83.3
total	309	366	84.4

package Test::Stream::Util;
use strict;
use warnings;

use Test::Stream::Capabilities qw/CAN_THREAD/;
use Scalar::Util qw/reftype blessed refaddr/;
use Carp qw/croak/;
use B();

use Test::Stream::Exporter qw/import export_to exports/;
exports qw{
        try protect

        get_tid USE_THREADS

        pkg_to_file

        get_stash

        sig_to_slot slot_to_sig
        parse_symbol

        term_size

        rtype render_ref

        set_sub_name
        CAN_SET_SUB_NAME
        sub_info
        sub_name
        rename_anon_sub

        update_mask
};
no Test::Stream::Exporter;

BEGIN {
    local ($@, $!, $SIG{__DIE__});
    my $have_sub_util = eval { require Sub::Util; 1 };
    my $have_sub_name = eval { require Sub::Name; 1 };

    my $set_subname = $have_sub_util ? Sub::Util->can('set_subname') : undef;
    my $subname     = $have_sub_name ? Sub::Name->can('subname')     : undef;

    *set_sub_name = $set_subname || $subname || sub { croak "Cannot set sub name" };

    if($set_subname || $subname) {
        *CAN_SET_SUB_NAME = sub() { 1 };
    }
    else {
        *CAN_SET_SUB_NAME = sub() { 0 };
    }
}

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

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

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

sub rename_anon_sub {
    my ($name, $sub, $caller) = @_;
    $caller ||= caller();

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

    my $cobj = B::svref_2object($sub);
    my $orig = $cobj->GV->NAME;
    return unless $orig =~ m/__ANON__$/;
    set_sub_name("${caller}::${name}", $sub);
}

sub update_mask {
    my ($file, $line, $name, $mask) = @_;

    no warnings 'once';
    my $masks = \%Trace::Mask::MASKS;
    use warnings 'once';

    # Get existing ref, if any
    my $ref = $masks->{$file}->{$line}->{$name};

    # No ref, easy!
    return $masks->{$file}->{$line}->{$name} = {%$mask}
        unless $ref;

    # Merge new mask into old
    %$ref = (%$ref, %$mask);
    return;
}

sub _manual_protect(&) {
    my $code = shift;

    rename_anon_sub('protect', $code, caller) if CAN_SET_SUB_NAME;

    my ($ok, $error);
    {
        my ($msg, $no) = ($@, $!);
        $ok = eval {
            BEGIN { update_mask(__FILE__, __LINE__ + 1, '*', {hide => 3}) }
            $code->();
            1
        } || 0;
        $error = $@ || "Error was squashed!\n";
        ($@, $!) = ($msg, $no);
    }
    die $error unless $ok;
    return $ok;
}

sub _local_protect(&) {
    my $code = shift;

    rename_anon_sub('protect', $code, caller) if CAN_SET_SUB_NAME;

    my ($ok, $error);
    {
        local ($@, $!);
        $ok = eval {
            BEGIN { update_mask(__FILE__, __LINE__ + 1, '*', {hide => 3}) }
            $code->();
            1
        } || 0;
        $error = $@ || "Error was squashed!\n";
    }
    die $error unless $ok;
    return $ok;
}

sub _manual_try(&;@) {
    my $code = shift;
    my $args = \@_;
    my $error;
    my $ok;

    rename_anon_sub('try', $code, caller) if CAN_SET_SUB_NAME;

    {
        my ($msg, $no) = ($@, $!);
        my $die = delete $SIG{__DIE__};

        $ok = eval {
            BEGIN { update_mask(__FILE__, __LINE__ + 1, '*', {hide => 3}) }
            $code->(@$args);
            1
        } || 0;
        unless($ok) {
            $error = $@ || "Error was squashed!\n";
        }

        ($@, $!) = ($msg, $no);
        if ($die) {
            $SIG{__DIE__} = $die;
        }
        else {
            delete $SIG{__DIE__};
        }
    }

    return ($ok, $error);
}

sub _local_try(&;@) {
    my $code = shift;
    my $args = \@_;
    my $error;
    my $ok;

    rename_anon_sub('try', $code, caller) if CAN_SET_SUB_NAME;

    {
        local ($@, $!, $SIG{__DIE__});
        $ok = eval {
            BEGIN { update_mask(__FILE__, __LINE__ + 1, '*', {hide => 3}) }
            $code->(@$args);
            1
        } || 0;
        unless($ok) {
            $error = $@ || "Error was squashed!\n";
        }
    }

    return ($ok, $error);
}

# Older versions of perl have a nasty bug on win32 when localizing a variable
# before forking or starting a new thread. So for those systems we use the
# non-local form. When possible though we use the faster 'local' form.
BEGIN {
    if ($^O eq 'MSWin32' && $] < 5.020002) {
        *protect = \&_manual_protect;
        *try     = \&_manual_try;
    }
    else {
        *protect = \&_local_protect;
        *try     = \&_local_try;
    }
}

BEGIN {
    if(CAN_THREAD) {
        if ($INC{'threads.pm'}) {
            # Threads are already loaded, so we do not need to check if they
            # are loaded each time
            *USE_THREADS = sub() { 1 };
            *get_tid = sub { threads->tid() };
        }
        else {
            # :-( Need to check each time to see if they have been loaded.
            *USE_THREADS = sub { $INC{'threads.pm'} ? 1 : 0 };
            *get_tid = sub { $INC{'threads.pm'} ? threads->tid() : 0 };
        }
    }
    else {
        # No threads, not now, not ever!
        *USE_THREADS = sub() { 0 };
        *get_tid     = sub() { 0 };
    }
}

sub pkg_to_file {
    my $pkg = shift;
    my $file = $pkg;
    $file =~ s{(::|')}{/}g;
    $file .= '.pm';
    return $file;
}

sub get_stash {
    my $pkg = shift;
    no strict 'refs';
    return \%{"$pkg\::"};
}

my %SIG_TABLE = (
    '&' => 'CODE',
    '%' => 'HASH',
    '@' => 'ARRAY',
    '$' => 'SCALAR',
    '*' => 'GLOB',
);
my %SLOT_TABLE = reverse %SIG_TABLE;

sub sig_to_slot { $SIG_TABLE{$_[0]}  }
sub slot_to_sig { $SLOT_TABLE{$_[0]} }

sub parse_symbol {
    my ($sym) = @_;

    my $sig = substr($sym, 0, 1);
    return ($sym, 'CODE') unless $SIG_TABLE{$sig};
    my $name = substr($sym, 1);

    my $slot = $SIG_TABLE{$sig} or croak "'$sig' is not a supported sigil";

    return ($name, $slot);
}

BEGIN {
    my ($ok, $err) = try { require Term::ReadKey };
    $ok &&= Term::ReadKey->can('GetTerminalSize');
    *USE_TERM_READKEY = $ok ? sub() { 1 } : sub() { 0 };
};

sub term_size {
    return $ENV{TS_TERM_SIZE} if $ENV{TS_TERM_SIZE};
    return 80 unless USE_TERM_READKEY;
    my $total;
    try {
        my @warnings;
        local $SIG{__WARN__} = sub { push @warnings => @_ };
        ($total) = Term::ReadKey::GetTerminalSize(*STDOUT);
        @warnings = grep { $_ !~ m/Unable to get Terminal Size/ } @warnings;
        warn @warnings;
    };
    return 80 if !$total;
    return 80 if $total < 80;
    return $total;
}

sub rtype {
    my ($thing) = @_;
    return '' unless defined $thing;

    my $rf = ref $thing;
    my $rt = reftype $thing;

    return '' unless $rf || $rt;
    return 'REGEXP' if $rf =~ m/Regex/i;
    return 'REGEXP' if $rt =~ m/Regex/i;
    return $rt || '';
}

sub render_ref {
    my ($in) = @_;

    return 'undef' unless defined($in);

    my $type = rtype($in);
    return "$in" unless $type;

    # Look past overloading
    my $class = blessed($in) || '';
    my $it = sprintf('0x%x', refaddr($in));
    my $ref = "$type($it)";

    return $ref unless $class;
    return "$class=$ref";
}

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

    croak "sub_info requires a coderef as its first argument"
        unless $sub && ref($sub) && reftype($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__