File Coverage

blib/lib/Trace/Mask/Util.pm

Criterion	Covered	Total	%
statement	96	96	100.0
branch	40	42	95.2
condition	34	40	85.0
subroutine	18	18	100.0
pod	7	7	100.0
total	195	203	96.0

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

use Carp qw/croak carp/;

use Scalar::Util qw/reftype looks_like_number/;
use B;

our $VERSION = "0.000001";

use base 'Exporter';
our @EXPORT_OK = qw{
    update_mask
    validate_mask
    get_mask
    mask_line
    mask_call
    mask_sub
    mask_frame
};

my %VALID_MASK = (
    hide     => 1,
    no_start => 1,
    shift    => 1,
    stop     => 1,
    restart  => 1,
    lock     => 1,
);

sub _MASKS() { no warnings 'once'; \%Trace::Mask::MASKS }

sub _subname {
    my $cobj = B::svref_2object($_[0]);
    my $package = $cobj->GV->STASH->NAME;
    my $subname = $cobj->GV->NAME;
    return "$package\::$subname";
}

sub _validate_mask {
    my $mask = shift;
    my @errors = validate_mask($mask) or return;
    my @caller = caller(1);
    my $out = join "\n" => map {"    $_"} @errors;
    die "Invalid mask at $caller[1] line $caller[2].\n$out\n"
}

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

    my $name = ref $sub ? _subname($sub) : $sub;

    my $masks = _MASKS();

    # 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 update_mask {
    my ($file, $line, $sub, $mask) = @_;
    _validate_mask($mask);
    _update_mask(@_);
}

sub validate_mask {
    my ($mask) = @_;

    return ("Mask must be a hashref")
        unless $mask && ref($mask) && reftype($mask) eq 'HASH';

    my @errors;

    # Sort the keys to keep it consistent
    for my $key (sort keys %$mask) {
        next if $key =~ m/^\d+$/; # integer keys are always valid
        next if $VALID_MASK{$key};
        push @errors => "invalid mask option '$key'";
    }

    if (my $shift = $mask->{shift}) {
        push @errors => "'shift' value must be a positive integer"
            unless $shift =~ m/^\d+$/ && $shift >= 0;
    }

    if (my $hide = $mask->{hide}) {
        push @errors => "'hide' value must be a positive integer"
            unless $hide =~ m/^\d+$/ && $hide >= 0;
    }

    return @errors;
}

sub mask_line {
    my ($mask, $delta, @subs) = @_;
    my ($pkg, $file, $line) = caller(0);

    _validate_mask($mask);

    croak "The second argument to mask_line() must be an integer"
        if $delta && (ref($delta) || $delta !~ m/^-?\d+$/);

    push @subs => '*' unless @subs;
    $line += $delta if $delta;

    _update_mask($file, $line, $_, $mask) for @subs;
    return;
}

sub mask_call {
    my $mask = shift;
    my $sub = shift;
    my ($pkg, $file, $line) = caller(0);

    _validate_mask($mask);

    $sub = $pkg->can($sub) if $sub && !ref($sub);

    croak "The second argument to mask_call() must be a coderef, or the name of a sub to call"
        unless $sub && ref($sub) && reftype($sub) eq 'CODE';

    _update_mask($file, $line, $sub, $mask);

    @_ = (@_);    # Hide the shifted args
    goto &$sub;
}

sub mask_sub {
    my ($mask, $sub, $file, $line) = @_;
    $file ||= '*';
    $line ||= '*';

    _validate_mask($mask);

    $sub = caller->can($sub) if $sub && !ref($sub);

    croak "The second argument to mask_sub() must be a coderef, or the name of a sub in the calling package"
        unless $sub && ref($sub) && reftype($sub) eq 'CODE';

    my $name = _subname($sub);
    croak "mask_sub() cannot be used on an unamed sub"
        if $name =~ m/__ANON__$/;

    _update_mask($file, $line, $name, $mask);
    return;
}

sub mask_frame {
    my %mask = @_;

    _validate_mask(\%mask);

    my ($pkg, $file, $line, $name) = caller(1);
    _update_mask($file, $line, $name, \%mask);

    return;
}

sub get_mask {
    my ($file, $line, $sub) = @_;

    my $name = ref($sub) ? _subname($sub) : $sub;

    my $masks = _MASKS();

    return {lock => $1} if $sub =~ m/(?:^|:)(END|BEGIN|UNITCHECK|CHECK|INIT|DESTROY|import|unimport)$/;

    my @order = grep { defined $_ } (
        $masks->{$file}->{'*'}->{'*'},
        $masks->{$file}->{$line}->{'*'},
        $masks->{'*'}->{'*'}->{$name},
        $masks->{$file}->{'*'}->{$name},
        $masks->{$file}->{$line}->{$name},
    );

    return {} unless @order;
    return { map { %{$_} } @order };
}

1;

__END__