File Coverage

blib/lib/SlapbirdAPM/Dancer2/Trace.pm

Criterion	Covered	Total	%
statement	21	56	37.5
branch	0	10	0.0
condition	0	9	0.0
subroutine	7	14	50.0
pod	0	3	0.0
total	28	92	30.4

package SlapbirdAPM::Dancer2::Trace;

use strict;
use warnings;

my $logger;

# set a callback sub for logging
sub callback {
    shift if @_ > 1;

    my $coderef = shift;
    unless ( ref($coderef) eq 'CODE' and defined(&$coderef) ) {
        require Carp;
        Carp::croak("$coderef is not a code reference!");
    }

    $logger = $coderef;
}

# where logging actually happens
sub _log_call {
    my %args = @_;
    return $logger->(%args);
}

sub trace_pkgs {
    my $class = shift;
    _wrap_symbols(@_);
}

sub trace_subs {
    my ( $class, @tracers ) = @_;

    for (@tracers) {
        no strict 'refs';
        no warnings;
        my $sub = *{$_}{CODE};
        next unless defined $sub and defined &$sub;
        *{$_} = sub {
            return _log_call( name => "$_", args => [@_], 'sub' => $sub );
        };
    }
}

sub _wrap_symbols {
    my (@traces) = @_;

    my %seen = ( map { ( $_ => 1 ) } @traces );

    while ( my $traced = shift @traces ) {
        next if $traced eq __PACKAGE__;

        my $src;

        no strict 'refs';

        # get the calling package symbol table name
        {
            no strict 'refs';
            $src = \%{ $traced . '::' };
        }

        # loop through all symbols in calling package, looking for subs
        for my $symbol ( keys %$src ) {

            # get all code references, make sure they're valid
            my $sub = *{ $traced . '::' . $symbol }{CODE};
            next unless defined $sub and defined &$sub;

            {
                no warnings;
                *{ ${traced} . '::' . $symbol } = sub {
                    return _log_call(
                        name => "${traced}::$symbol",
                        args => [@_],
                        sub  => $sub
                    );
                };
            };
        }
    }
}

1;