package Devel::Agent::Proxy;

=head1 NAME

Devel::Agent::Proxy - instance proxy layer

=head1 SYNOPSIS

  use Devel::Agent::Proxy;

  my $self=new SomeClass(...);
  my $proxy=new Devel::Agent::Proxy(
    proxy_class_name=>'SomeClass',
    proxied_object=>$self,
  );

=head1 DESCRIPTION

Devel::Agent::Proxy

This class was created to act as an agent aware wrapper for classes that internals need to be kept of the radar of the agent debugger.

=cut

# would love to use Moo, but artifacts are bad!
use strict;
use warnings;
require Carp;
require Devel::Agent;
our $VERSION=$Devel::Agent::VERSION;

# COMMENT THIS OUT AFTER TESTING!!
#use Data::Dumper;

our $AUTOLOAD;

our %BUILD_ARGS;

my $has=sub {
  my ($method,%args)=@_;

  my $ref=ref $args{default};
  $BUILD_ARGS{$method}=\%args;
  unless($ref) {
    my $default=$args{default};
    $args{default}=sub { $default };
  }
  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];
    }
  };
  my $method_name=__PACKAGE__."::___$method";
  no strict 'refs';
  *{$method_name}=$sub;
};

=head1 Constructor/Method Accssor

This section documents the constructor methods and class accessors.  All constructor arguments are passed by thier name, all class accessors are prefixed with___.  For Example wrap_result_methods becomes $self->___wrap_result_methods in an accessor context.

=over 4

=item * wrap_result_methods=>HashRef[CodeRef]

This is a hashref of code refs that can be used to post process the results of a proxied method.

=cut

$has->(wrap_result_methods=>(
  #isa=>HashRef[CodeRef],
  is=>'ro',
  lazy=>1,
  default=>sub {
    return {};
  },
));

=item * proxy_class_name=>Str

This should be the name of the class we want the class_method and raw_method to appear as in the agent stack trace.

=cut

$has->(proxy_class_name=>(
  #isa=>Str,
  is=>'ro',
  required=>1,
));

=item * replace_name=>Str

This is autogenerated as needed, it will be set to $self->___proxy_class_name.'::' on first access.

=cut

$has->(replace_name=>(
  #isa=>Str,
  is=>'rw',
  lazy=>1,
  default=>sub {
    my ($self)=@_;
    return $self->___proxy_class_name.'::';
  },
));

=item * proxied_object=>Object

This is the object to be proxied.

=cut

$has->(proxied_object=>(
  #isa=>Object,
  required=>1,
  is=>'ro',
));

=item * current_method=>Str

This represents the current method being proxied and is set dynamically at runtime.

=cut

$has->(current_method=>(
  is=>'rw',
  required=>1,
));

=item * in_can=>0

Used by the internals of this object for state.

=cut

$has->(in_can=>(
  is=>'rw',
  default=>0,
  lazy=>1,
));

undef $has;

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

    if(exists $args{$key}) {
      $self->{$key}=$args{$key};
    } elsif($args->{required}) {
      &Carp::croak("$key is a required argument");
    } elsif(!$args->{lazy}) {
      my $cb=$args->{default};
      $self->{$key}=$self->$cb();
    }
  }
  return $self;
}

=back

=head1 Object Methods

This section documents the Methods created in this class.

=head2 $self->___db_stack_filter($agent,$frame,$args,$raw_caller)

This method is used by some plugin classes for Deve::Agent to handle frame alterations.  Basicaly this method is used to re-write a frame in tracing to pevent this object from showing up as iteself and appear as the object it is proxying.

=cut

sub ___db_stack_filter {
  my ($self,$agent,$frame,$args,$raw_caller)=@_;
  return 1 unless ref $self;

  # hide all the calls we make
  return 0 if $frame->{caller_class} eq __PACKAGE__;
  my $replace=$self->___replace_name;
  $frame->{class_method}=~ s/^(.*)::/$replace/s;
  $frame->{raw_method}=~ s/^(.*)::/$replace/s;
  return 1;
}

=head2 my $cb=$self->can('method')

Overload of UNIVERSAL->can method

=cut

sub can {
  my ($self,$method)=@_;
  my $p=$self->___proxied_object;

  my $cb=$p->can($method);
  return $cb unless $cb;
  $self->___current_method($method);

  return sub {
    $self->___in_can(1);
    $AUTOLOAD=$method;
    $self->$method(@_);
  };
}

=head2 if($self->isa("class")) { ... }

Overload of UNIVERSAL->isa("class")

=cut

sub isa {
  my ($self,$class)=@_;
  return $self->___proxied_object->isa($class);
}

=head2 if($self->DOES($object|$class)) { ... }

Overload of UNIVERSAL->DOES($object|$class)

=cut

sub DOES {
  my ($self,$role)=@_;
  return $self->___proxied_object->DOES($role);
}

=head2 Maybe[Any]=$self->AUTOLOAD(@args)

The guts of how this proxy class works, basically it auto loads methods to look like the object class it is proxying.

=cut

sub AUTOLOAD {
  # do this so we can pass @_ to our target function
  my $self=shift;
  my $method=$AUTOLOAD;
  $method=~ s/^.*:://s;
  $self->___current_method($method);
  my $p=$self->___proxied_object;

  my $cb;
  if($self->___in_can) {
    return $self->___exec_method($self->__in_can,@_);
  } if($cb=$p->can($method)) {
    $self->___current_method($method);
    return $self->___exec_method($cb,@_);
  } elsif($cb=$p->can('AUTOLOAD')) {
    $self->___current_method('AUTOLOAD');
    return $self->___exec_method($cb,@_);
  }
    
  Carp::croak(sprintf q{Can't locate object method "%s" via package "%s"},$method,$self->___proxy_class_name);
}

=head2 Maybe[Any]=$self->___exec_method($cb)

Handles wrapper logic for a given code reference.

=cut

sub ___exec_method {
  my $self=shift;
  my $cb=shift;
  my $wrap=$self->___wrap_result_methods;
  my $method=$self->___current_method;
  $self->___in_can(0);
  my $p=$self->___proxied_object;
  local $@;
  if(wantarray) {
    my @res;
    if(exists $wrap->{$method}) {
      @res=$wrap->{$method}->($self,1,$cb);
    } else {
      @res=$p->$cb(@_);
    }
    return @res;
  } else {
    my $res;
    if(exists $wrap->{$method}) {
      $res=$wrap->{$method}->($self,0,$cb);
    } else {
      $res=$p->$cb(@_);
    }
    return $res;
  }
}

# manditory in the case of auto load!!
sub DESTROY {
  my ($self)=@_;
  %$self=();
  undef $self;
}

1;

__END__

=head1 AUTHOR

Michael Shipper L<AKALINUX@CPAN.ORG>

=cut

