File Coverage

blib/lib/Devel/XRay.pm

Criterion	Covered	Total	%
statement	35	35	100.0
branch	3	6	50.0
condition			n/a
subroutine	10	10	100.0
pod			n/a
total	48	51	94.1

package Devel::XRay;

use warnings;
use strict;
use Filter::Simple;
use Carp qw(croak);

our $VERSION = '0.95';

BEGIN {
    use constant DEBUG => 0;

    unless ( exists $INC{'Time/HiRes.pm'} ) {
        eval { require Time::HiRes; };
    }
    our $timing =
        exists $INC{'Time/HiRes.pm'}
        ? 'sprintf("%.6f", &Time::HiRes::time())'
        : 'sprintf("%d", time)';

    our %operations = (
        only   => \&_only,
        ignore => \&_ignore,
        all    => \&_all,
        none   => \&_none,
    );

    our $operation;
    our $subs  = '';
    our $trace = ' print STDERR "[" . ' . $timing
        . ' . "] " . (caller(0))[3] . "\\n";';
    our $all_regex = qr/(sub\s+\w.+?{)/s;
    our $regex     = '';

    sub import {
        ( undef, $operation, my (@subs) ) = @_;

        if ($operation) {
            croak "unknown import operation: $operation"
                unless exists $operations{$operation};
            croak "sub list required for operation: $operation\n"
                unless $operation eq 'all' || $operation eq 'none' || @subs;
            $regex = '(sub\s+(?:' . join( '|', @subs ) . ')\s*\{)';
            $regex = $regex . quotemeta($trace) if $operation eq 'ignore';

            #warn "regex: $regex\n";
            $regex = qr/$regex/s;
        }
        else {
            $operation = 'all';
        }
    }

    sub _only   { s/$regex/$1$trace/g; }
    sub _ignore { _all($_); s/$regex/$1/g; }
    sub _all    { s/$all_regex/$1$trace/g; }
    sub _none   { }

    FILTER {
        return unless $_;
        warn "performing operation: $operation\n" if DEBUG;
        $operations{$operation}->($_);
        warn $_ . "\n" if DEBUG;
    }
}

1;

__END__