File Coverage

blib/lib/Devel/DTrace/Provider/Builder.pm

Criterion	Covered	Total	%
statement	61	67	91.0
branch	5	12	41.6
condition			n/a
subroutine	18	20	90.0
pod	0	8	0.0
total	84	107	78.5

package Devel::DTrace::Provider::Builder;
use strict;
use warnings;

use Sub::Install qw/ install_sub /;
use Sub::Exporter -setup => {
    exports => [
        qw/ as /,
        probe => \&build_probe,
        provider => \&build_provider,
        import => \&build_import
    ],
    groups  => {
        default => [
            qw/ as probe provider import /
        ],
    },
    collectors => {
        INIT => \&capture_caller
    }
};

use Devel::DTrace::Provider;

{
    my $caller;
    my $providers;
    my $coderef;
    my $provider_name;

    sub capture_caller {
        my (undef, $args) = @_;
        $caller = $args->{into};
    }

    sub as (&) {
        $coderef = shift;
    }

    sub build_provider {
        sub ($$) {
            $provider_name = shift;
            my $provider;
            $provider = Devel::DTrace::Provider->new($provider_name, 'perl')
                 if Devel::DTrace::Provider::DTRACE_AVAILABLE();

            $providers->{$caller}->{$provider_name} = {
                args => {},
                provider => $provider
            };

            $coderef->();

            for my $probe_name (keys %{$providers->{$caller}->{$provider_name}->{args}}) {
                my $args = $providers->{$caller}->{$provider_name}->{args}->{$probe_name};
                $provider->add_probe($probe_name, 'func', $args)
                     if Devel::DTrace::Provider::DTRACE_AVAILABLE();
                export_probe_functions($caller, $provider, $provider_name, $probe_name);
            }

            $provider->enable
                 if Devel::DTrace::Provider::DTRACE_AVAILABLE();
        }
    }

    sub build_probe {
        sub ($;@) {
            my $name = shift;
            $providers->{$caller}->{$provider_name}->{args}->{$name} = \@_;
        }
    }

    sub build_import {
        sub {
            my $package = caller(0);
            for my $provider_name (keys %{$providers->{$caller}}) {
                my $provider = $providers->{$caller}->{$provider_name}->{provider};
                for my $probe_name (keys %{$providers->{$caller}->{$provider_name}->{args}}) {
                    export_probe_functions($package, $provider, $provider_name, $probe_name);
                }
            }
        }
    }
}

sub export_probe_functions {
    my ($package, $provider, $provider_name, $probe_name) = @_;

    my $probe = probe_function($provider, $probe_name);
    my $isenabled = probe_enabled_function($provider, $probe_name);

    $provider_name =~ tr/-/_/;
    $probe_name =~ tr/-/_/;

    my $enabled_name = $probe_name . '_enabled';
    my $provider_probe_name = $provider_name . '_' .$probe_name;
    my $provider_enabled_name = $provider_probe_name . '_enabled';

    install_sub({
        code => $probe,
        into => $package,
        as => $probe_name
    });
    install_sub({
        code => $isenabled,
        into => $package,
        as => $enabled_name
    });
    install_sub({
        code => $probe,
        into => $package,
        as => $provider_probe_name
    });
    install_sub({
        code => $isenabled,
        into => $package,
        as => $provider_enabled_name
    });
}

sub probe_function {
    my ($provider, $probe_name) = @_;

    if (Devel::DTrace::Provider::DTRACE_AVAILABLE()) {
        my $stub = $provider->probes->{$probe_name};
        return sub (&) { shift->($stub) if $stub->is_enabled };
    }
    else {
        return sub (&) { 1 };
    }
}

sub probe_enabled_function {
    my ($provider, $probe_name) = @_;

    if (Devel::DTrace::Provider::DTRACE_AVAILABLE()) {
        my $stub = $provider->probes->{$probe_name};
        return sub { $stub->is_enabled };
    }
    else {
        return sub { 0 };
    }
}

1;

__END__