package MooseX::Role::TraceMethodDispatch;

# preamble
#use pre;
use feature qw(:5.10);  # remove under pre
use MooseX::Role::Strict;
#use Moose::Role;

# libs
use Data::Dumper;

our $VERSION = '$Change: 174842 $';


# Attributes

has 'tracing' => (
    is      => 'rw',
    isa     => 'Bool',
    default => 0,
    trigger => \&_set_tracing,
);

has 'dump_args' => (
    is      => 'rw',
    isa     => 'Bool',
    default => 0,
    trigger => \&_set_args_dump
);

has 'dump_args_in' => (
    is      => 'rw',
    isa     => 'Bool',
    default => 0,
    trigger => \&_set_args_dump_in,
);

has 'dump_args_out' => (
    is      => 'rw',
    isa     => 'Bool',
    default => 0,
    trigger => \&_set_args_dump_out,
);

# XXX: load conf should not get called if already implimented elsewhere!
#has 'conf' => (
#    is      => 'rw',
#    isa     => 'Hashref', # XXX: Should become A::Conf object
#    builder => '_load_conf',
#);

has 'dump_maxdepth' => (
  is      => 'rw',
  isa     => 'Maybe[Int]',
  default => undef,
);

has 'dump_skip_self' => (
    is      => 'rw',
    isa     => 'Bool',
    default => 0,
);


# Builders
#sub _load_conf { {} }

# Triggers

# these need to be skipped to avoid deep recursion
my @_skip_methods = qw(
    tracing
    dump_args
    dump_args_in
    dump_args_out
    dump_maxdepth
    dump_skip_self
);
sub _set_tracing {
    my $self = shift;
    my ($new, $old) = @_;
    
    # if tracing is being set to false, short-circuit and return
    # also, we only need to do this once the first time set to true
    # XXX: is there a way to drop method modifiers?
    return unless $new;
    
    # Get methods
    my $class = ref $self;
    my $meta = $self->meta;
    my @methods = $meta->get_method_list();
    
    # do we have a log object?
    # XXX: Should we check to see if it is ours, or at least has an info method?
    my $is_logging = grep($_ eq 'log', @methods) ? 1 : 0;
    
    
    # go over methods and declare before and after method modifiers that handle
    # tracing and method dumping.
    for my $method (@methods) {
        # avoid deep recursion
        next if $method ~~ @_skip_methods;
        push(@_skip_methods, $method); # don't add next time
        
        $meta->add_before_method_modifier($method, sub {
            my $self = $_[0]; # don't shift
            
            return unless $self->tracing();
            
            my $msg = "##### Entering $class" . "::$method #####\n";
            
            if ($self->dump_args_in) {
                local $Data::Dumper::Maxdepth = $self->dump_maxdepth;
                $msg .= "*** $method args ***\n";
                $msg .= ! $self->dump_skip_self ? Dumper(\@_) : Dumper([@_[1..$#_]]);
            }
            
            $is_logging ? $self->info($msg) : warn $msg;
        });
        
        $meta->add_after_method_modifier($method, sub {
            my $self = $_[0]; # don't shift
            
            return unless $self->tracing();
            
            my $msg = "##### Leaving $class" . "::$method #####\n";
            
            if ($self->dump_args_in) {
                local $Data::Dumper::Maxdepth = $self->dump_maxdepth;
                $msg .= "*** $method returned ***\n";
                $msg .= ! $self->dump_skip_self ? Dumper(\@_) : Dumper([@_[1..$#_]]);
            }
            
            $is_logging ? $self->info($msg) : warn $msg;
        });
    }
    
} # _set_tracing


sub _set_args_dump {
    my $self = shift;
    my ($new, $old) = @_;
    
    # if we're turning on arg dumping turn on tracing too
    $self->tracing($new) if $new;
    
    $self->dump_args_in($new);
    $self->dump_args_out($new);
}
sub _set_args_dump_in  {
    my $self = shift;
    $self->tracing($_[0]) if $_[0];
} 
sub _set_args_dump_out {
    my $self = shift;
    $self->tracing($_[0]) if $_[0];
}


# Method modifiers


# Methods


no Moose::Role;
# not for roles?!
#__PACKAGE__->meta->make_immutable;


1; # End of MooseX::Role::TraceMethodDispatch

__END__



=head1 NAME

MooseX::Role::TraceMethodDispatch - Add code tracing and argument dumping to your class

=head1 SYNOPSIS

Consumed as a role for a moose class

    package MyModule;
    
    use pre;
    use Moose;
    with qw(MooseX::Role::TraceMethodDispatch);
    
    # ... methods, attributes and such

Then when using an object of your class

    use MyModule;
    
    # new object, with tracing turned on
    
    my $obj = MyModule->new(tacing => 1);
    
    $obj->method(); # method and all calls from $self interally are traced
    # ##### Entering MyModule::method #####
    # ##### Leaving MyModule::method #####
    
    $obj->dump_args_in(1);
    
    $obj->method2({one => 1}); # dump arguments being passed into methods
    # ##### Entering MyModule::method2 #####
    # *** method2 args ***
    # $VAR1 = [                    
    #           {
    #             'one' => 1
    #           }
    #         ];
    # ##### Leaving MyModule::method2 #####
    
    $obj->tracing(0); # turn tracing off


Note that methods added after tracing is set will not be logged until tracing is
set again. Methods set with *MyModule::method = sub {} will never be seen; use
$meta->add_method instead!

=head1 EXPORT

Nothing exported - just oop here

=head1 Attributes

=over 4

=item tracing (Bool)

Turn tracing on or off by setting this attribute to true.

=item dump_args (Bool)

Dump arguments being passed in and out of every method. Note, argument dumping
will turn on tracing as well.

=item dump_args_in (Bool)

Dump arguments being passed in to a method.

=item dump_args_out (Bool)

Dump arguments being passed out of a method.

=item dump_maxdepth (Maybe[Int])

Maximum depth of argument dump - sets $Data::Dumper::Maxdepth locally.

=item dump_skip_self (Bool)

Do not include $self in dump. Note, this just blindly skips the first argument
in @_!

=back

=head1 METHODS

No public methods

=head1 LICENSE AND COPYRIGHT

Copyright 2010 Sean P Quinlan.

=cut