view release on metacpan or  search on metacpan

lib/Devel/Agent.pm  view on Meta::CPAN

The ___db_stack_filter method is expected to return true, if the call returns false, then the frame should not be traced. Since the frame passed in before it's runtime execution, the duration value will not be set. 

A basic implementation that exposes only the top level calls is defined in L<Devel::Agent::AwareRole>.  Loading this role into your class will hide all calls made by your class, but not calls made directly to it, this includes child classes that make...

Example:

  package My::Class::That::IS::Mostly::Hidden;

  use Role::Tiny::With; # you can also use Moo Moose or other role implementations
  with 'Devel::Agent::AwareRole';

  1;

If you want to force a class to not show its internals.. say a class like LWP::UserAgent.

  use LWP::UserAgent;
  reuqire Devel::Agent::AwareRole;

  # now only the top level calls to LWP::UserAgent will show up
  *LWP::UserAgent::___db_stack_filter=\&Devel::Agent::AwareRole::___db_stack_filter;

Or if you need to disable filtering on a class that has filtering then you can do the opposite
  
  *LWP::UserAgent::___db_stack_filter=sub { 1}

To be fully ignored

  *LWP::UserAgent::___db_stack_filter=sub { 0}

=head1 Frame information

The following hash represents what is provided as a representation of a frame

  {
    caller_class=>'main',         # class that called this class
    calls=>[],                    # child frames, empty unless $self->save_to_stack is true
    class_method=>'main::test_a', # the resolved class::method
    depth=>1,                     # stack depth, 1 is considered the root
    duration=>undef|Float,        # how long the frame took to execute, only defined when the frame has executed
    end_id=>undef|Int,            # frame final execution order where in the stack it ended 
    line=>2,                      # line number the frame was called from
    no_frame=>0|1,                # when true, this frame would have been filtered but was included for completeness
    order_id=>1,                  # inital frame execution order, where in the stack it started
    owner_id=>0,                  # which order_id frame triggered the execution of this frame
    raw_method=>'main::test_a',   # un-resolved method name
    source=>'test.pl',            # the source file
    t0=>[0,0],                    # Frame Start timestamp in: epoch, microseconds
  }

=head1 DB Constructor options

This section documents the %args the be passed to the new DB(%args) or DB->new(%args) call.  For each option documented in this section, there is an accesor by that given name that can be called by $self->$name($new_value) or my $current_value=$self-...

=cut

# prevent indexing ( as ya this will be noticed in the indexing process for sure!!! )
package 
  DB;

#use Modern::Perl;
use strict;
use warnings;
require Scalar::Util;

# as easy as Moo makes things.. its not welcome in a debugger ;(
use Time::HiRes qw(gettimeofday tv_interval);
use B qw(svref_2object);
use Data::Dumper;

our $AGENT;
my $IN_METHOD=0;
my $internals=0;

# ya no, only allow access to this class!!
my %BUILD_ARGS;

# Genrate functions similar to moo and moose, but don't actually use Moo or Moose..
sub has {
  my ($method,%args)=@_;

  my $ref=ref $args{default};
  $BUILD_ARGS{$method}=\%args;
  unless($ref) {
    my $default=$args{default};
    $args{default}=sub { $default };
  }
  if($args{clearer}) {
    my $sub=sub {
       my $self=shift;
      delete $self->{$method};
    };
    my $method="clear_$method";
    my $method_name=__PACKAGE__."::$method";
    no strict 'refs';
    *{$method_name}=$sub;
  }

  my $sub=sub {
    my $self=shift;
    if($#_==-1) {
      if(exists $self->{$method}) {
        return $self->{$method};
      } else {
        my $def=$args{default};
        my $value=$self->{$method}=$self->$def();
        return $value;
      }
    } else {
      return $self->{$method}=$_[0];
    }
  };
  no strict 'refs';
  my $method_name=__PACKAGE__."::$method";
  *{$method_name}=$sub;
}

sub new {
  my ($class,%args)=@_;
  my $self=bless {},$class;
  while(my ($key,$args)=each %BUILD_ARGS) {