File Coverage

blib/lib/Trace/Mask/Reference.pm

Criterion	Covered	Total	%
statement	118	118	100.0
branch	60	66	90.9
condition	40	54	74.0
subroutine	15	15	100.0
pod	4	5	80.0
total	237	258	91.8

package Trace::Mask::Reference;
use strict;
use warnings;

use Carp qw/croak/;

use Scalar::Util qw/reftype looks_like_number refaddr blessed/;

use Trace::Mask::Util qw/mask_frame mask_line get_mask/;

use base 'Exporter';
our @EXPORT_OK = qw{
    trace
    trace_string
    trace_mask_caller
    try_example
};

sub try_example(&) {
    my $code = shift;
    local $@;
    my $ok = eval {
        # Hides the call, the eval, and the call to try_example
        # This also has the added benefit that if there was an exception inside
        # try_example itself, the trace would not hide anything. The hide only
        # effects traces from inside the anonymous sub.
        BEGIN { mask_line({hide => 3}, 1) }
        $code->();
        1;
    };
    return if $ok;
    return $@ || "error was smashed!";
}

sub _call_details {
    my ($level) = @_;
    $level += 1;

    my (@call, @args);
    {
        package DB;
        @call = caller($level);
        @args = @DB::args;
    }

    return unless @call && defined $call[0];
    return (\@call, \@args);
}

sub _do_shift {
    my ($shift, $frame) = @_;

    # Args are a direct move
    $frame->[1] = $shift->[1];

    # Merge the masks numeric keys, shift wins
    for my $key (keys %{$shift->[2]}) {
        next unless $key =~ m/^\d+$/;
        $frame->[2]->{$key} = $shift->[2]->{$key};
    }

    # Copy all caller values from shift except 0-2
    for(my $i = 3; $i < @{$shift->[0]}; $i++) {
        $frame->[0]->[$i] = $shift->[0]->[$i];
    }
}

sub trace {
    my @stack;

    # Always have to start at 0 since frames can hide frames that come after them.
    my $level = 0;

    # Shortcut
    if ($ENV{NO_TRACE_MASK}) {
        while (my ($call, $args) = _call_details($level++)) {
            push @stack => [$call, $args];
        }
        return \@stack;
    }

    my ($shift, $last);
    my $skip = 0;
    my $stopped = 0;
    my $paused  = 0;
    while (my ($call, $args) = _call_details($level++)) {
        my $mask = get_mask(@{$call}[1,2,3]);
        my $frame = [$call, $args, $mask];

        my $lock = $mask->{lock};

        next if $paused && !($mask->{restart} || $lock);
        $paused = 0 if $mask->{restart};

        next if $stopped && !$lock;

        $last = $frame unless $mask->{hide} || $mask->{shift} || $lock;

        unless($lock) {
            # Need to do this even if the frame is not pushed now, it may be pushed
            # later depending on shift.
            for my $idx (keys %$mask) {
                next unless $idx =~ m/^\d+$/;
                next if $idx >= @$call;    # Do not create new call indexes
                $call->[$idx] = $mask->{$idx};
            }
        }

        if ($mask->{shift}) {
            $shift ||= $frame;
            $skip  = ($skip || $lock) ? $skip + $mask->{shift} - 1 : $mask->{shift};
        }
        elsif ($mask->{hide}) {
            $skip  = ($skip || $lock) ? $skip + $mask->{hide} - 1 : $mask->{hide};
        }
        elsif($skip && !(--$skip) && $shift) {
            _do_shift($shift, $frame) unless $lock;
            $shift = undef;
        }

        my $push = !($skip || ($mask->{no_start} && !@stack));

        push @stack => $frame if $push || $lock;

        $stopped = 1 if $mask->{stop};
        $paused  = 1 if $mask->{pause};
    }

    if ($shift) {
        _do_shift($shift, $last) unless $last->[2]->{lock};
        push @stack => $last unless @stack && $stack[-1] == $last;
    }

    return \@stack;
}

sub trace_mask_caller {
    my ($level) = @_;
    $level = 0 unless defined($level);

    my $trace = trace();
    return unless $trace && @$trace;

    my $frame = $trace->[$level + 2];
    return unless $frame;

    return @{$frame->[0]}[0, 1, 2] unless @_;
    return @{$frame->[0]};
}

sub trace_string {
    my ($level) = @_;
    $level = 0 unless defined($level);

    BEGIN { mask_line({hide => 1}, 1) };
    my $trace = trace();

    shift @$trace while @$trace && $level--;
    my $string = "";
    for my $frame (@$trace) {
        my ($call, $args) = @$frame;
        my $args_str = join ", " => map { render_arg($_) } @$args;
        $args_str ||= '';
        if ($call->[3] eq '(eval)') {
            $string .= "eval { ... } called at $call->[1] line $call->[2]\n";
        }
        else {
            $string .= "$call->[3]($args_str) called at $call->[1] line $call->[2]\n";
        }
    }

    return $string;
}

sub render_arg {
    my $arg = shift;
    return 'undef' unless defined($arg);

    if (ref($arg)) {
        my $type = reftype($arg);

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

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

    return $arg if looks_like_number($arg);
    $arg =~ s/'/\\'/g;
    return "'$arg'";
}

1;

__END__