use strict;         
use warnings;
    
BEGIN {
  *CORE::GLOBAL::caller = sub {
    my $sub   = (CORE::caller(1))[3];
    my $depth = ($_[0] || 0)
              + (UNIVERSAL::isa(\&$sub, 'Hook::PackageWrap') ? 2 : 1);
    return CORE::caller($depth);
  };
} 
  
{ 
  package Hook::PackageWrap;
  
  use overload ();
  use Carp 'croak';

  sub _init {
    my($self, %args) = @_;
  
    $args{handler}  = \&trace
      unless exists $args{handler}
         and UNIVERSAL::isa($args{handler}, 'CODE');
    $args{pre}      = \&_pre
      unless exists $args{pre}
         and UNIVERSAL::isa($args{pre}, 'CODE');
    $args{post}  = \&_post
      unless exists $args{post}
         and UNIVERSAL::isa($args{post}, 'CODE');

    $args{skip} = []
      unless defined $args{skip}
         and UNIVERSAL::isa($args{skip}, 'ARRAY');

    return bless {
      handler => $args{handler},
      pre     => $args{pre},
      post    => $args{post},
      skip    => join('|', __PACKAGE__, @{$args{skip}}),
    }, $self;
  }

  sub wrap_subs {
    my($self, %args) = @_;
    
    croak("No package was provided")
      unless exists $args{package};

    $self->_init(%args)->_wrap($args{package});
  }

  sub _wrap {
    my($self, $t) = @_;
    
    for(keys %$t) {
      ## avoid potential minefield of magical/recursive looking subs
      ## almost certainly needs to be tightened up
      next
        if /  __ANON__
            | ^(?:strict|warnings|overload|attributes|diagnostics|main)::
            | ^[A-Z]+$

            | ^(?:isa|can|VERSION|caller)$
           /x or ( $self->{skip} and $t->{$_} =~ /^\*?(?:$self->{skip})::/ );
  
      $self->_wrap(\%{$t->{$_}}), next
        if /[^:]::$/;

      my $c;
      next
        unless    ref(\$t->{$_}) eq 'GLOB'
               && defined( $c = *{$t->{$_}}{CODE} );

      next if *{$t->{$_}}{CODE} eq $self->{handler};

      my($n,$pre,$post) = (substr($t->{$_}, 1), @$self{qw/pre post/});
      no warnings;
      $t->{$_} = bless sub {
        unshift @_, {
          name => $n,
          code => $c,
          pre  => $pre,
          post => $post,
        };
        goto &{ $self->{handler} };
      }, 'Hook::PackageWrap';
    }
  }

  sub _pre {
    my $info = shift;

    ## avoid the infinite recursion of overloaded vars
    my @args = map {
      ref $_ && overload::Overloaded($_) ? overload::StrVal($_) : $_
    } @_;
    print "## pre $info->{name}",(@args ? ", called with @args\n" : "\n");
  }

  sub _post {
    my $info = shift;

    ## avoid the infinite recursion of overloaded vars
    my @retout = map {
      ref $_ && overload::Overloaded($_) ? overload::StrVal($_) : $_
    } @_;

    print "## post $info->{name} returning: ",@retout,"\n";
  }

  sub trace {
    my $info = shift;


    no warnings 'uninitialized';

    my $pre  = $info->{pre};
    my $post = $info->{post};

    &$pre($info => @_);

    ## might mess with the likes of Want
    my(@ret,$ret);
    if(wantarray)            { @ret = $info->{code}->( @_ ) }
    elsif(defined wantarray) { $ret = $info->{code}->( @_ ) }
    else                     {        $info->{code}->( @_ ) }

    &$post($info => wantarray         ? @ret :
                    defined wantarray ? $ret : ('void context') );

    return wantarray ? @ret : defined wantarray ? $ret : ();
  }
}

sub foo {
  print "calling bar\n";
  bar(qw/ some args /);
  print "done with bar\n";

  my $o = wraptest->new;
  $o->test;
  print $o->list,$/;
  print $o->list.$/;
  $o->cani();
}

sub bar {
  print "I was called by - ", (caller 1)[3],$/;
  print "I'm bar() and I got: @_\n";
}

=head2 wrap_subs

B<Arguments>

A key =E<gt> value list e.g

  Hook::PackageWrap->wrap_subs(package => \%Your::Class::);

=over 4

=item package

A reference to the package to be wrapepd

=item handler

A subroutine that will be called for every sub wrapped

=item pre

A sub that will be called before the wrapped sub is called if C<handler> hasn't
been provided. It is passed the C<$info> hash as the first argument and the
rest of C<@_> will contain the wrapped sub's arguments.

=item pre

A sub that will be called after the wrapped sub is called if C<handler> hasn't
been provided. It is passed the C<$info> hash as the first argument and the
rest of  will contain the wrapped sub's return values, or 'void context' if it
was called in a void context.

=item skip

An array of package names not to wrap.

=back

=cut

Hook::PackageWrap->wrap_subs(
  package => \%main::,
  pre     => sub { print "-- $_[0]->{name}( @_[1 .. $#_] )\n" },
);

foo();
print "\n";
eval q<sub cheat { print "but *I* was called by: ",(caller 1)[3],$/ }sub ha { cheat() }>;
ha();

{
  package wrap_isatest;
    
  sub meh  { print "yep I'm here: $_[0]\n" }
      
  package wraptest;
  BEGIN { our @ISA = 'wrap_isatest' }
    
  sub new  { bless [], shift }
  sub test { print "i'm a test $_[0]\n"    }
  sub list { return qw/ a list of values / }
  sub cani { $_[0]->SUPER::meh             }
}

__output__

-- main::foo(  )
calling bar
-- main::bar( some args )
I was called by - main::foo
I'm bar() and I got: some args
## post main::bar returning: void context
done with bar
-- wraptest::new( wraptest )
## post wraptest::new returning: wraptest=ARRAY(0x8108c4c)
-- wraptest::test( wraptest=ARRAY(0x8108c4c) )
i'm a test wraptest=ARRAY(0x8108c4c)
## post wraptest::test returning: void context
-- wraptest::list( wraptest=ARRAY(0x8108c4c) )
## post wraptest::list returning: alistofvalues
alistofvalues
-- wraptest::list( wraptest=ARRAY(0x8108c4c) )
## post wraptest::list returning: values
values
-- wraptest::cani( wraptest=ARRAY(0x8108c4c) )
-- wrap_isatest::meh( wraptest=ARRAY(0x8108c4c) )
yep I'm here: wraptest=ARRAY(0x8108c4c)
## post wrap_isatest::meh returning: void context
## post wraptest::cani returning: void context
## post main::foo returning: void context

but *I* was called by: main::ha