package Devel::TrackSub;
use 5.006;
use strict;
use warnings;
use Hook::LexWrap;
use Carp;
our $VERSION = 0.02;


sub new {
  my( $class, %arg ) = @_;
  bless { 
    pre => defined $arg{pre} ? $arg{pre} : 'Entering',
    post => defined $arg{post} ? $arg{post} : 'Leaving',
    level => defined $arg{level} ? $arg{level} : '~~',
    prefix => defined $arg{prefix} ? $arg{prefix} : '@ ',
    verbose => $arg{verbose} ? '' : "\n",
    params => $arg{params} ? 1 : 0,
    traced => {},
  }, $class;
}

sub _stack_depth { # compute stack depth
  my @stack;
  while( my $sym = caller(1 + scalar @stack) )
  { push @stack, $sym }
  return wantarray ? @stack : scalar @stack;
}

sub _gen_wrapper { # return a wrapper subroutine
  my( $self ) = ( shift );
  my( $direction, $pkg, $sym, $start ) = @_;
  return sub{
    carp( 
      $self->{level} x $self->_stack_depth(),
      $self->{prefix},
      $direction, ' ',
      $pkg, $sym, $self->{verbose},
      $pkg, $sym, 
      ( $start && $self->{params} 
          ? "( '" . join( "', '", @_[0..$#_-1] ) . "' )" 
          : () 
      ),
      $self->{verbose},
    )
  }
}

sub _warning { # return a warning message
  my( $self ) = ( shift);
  return 'Warning: ', __PACKAGE__, ': ', @_, $self->{verbose}
}

sub trace($;*) { # trace all named subs in given symbols
  no strict 'refs'; # professional driver on a closed course
  my( $self ) = ( shift );

  PACKAGE: for my $pkg ( @_ ) {

    ref $pkg
      and carp $self->_warning( "references not allowed ($pkg)" )
      and next PACKAGE;

    $pkg =~ /^\*/
      and carp $self->_warning( "globs not allowed ($pkg)" )
      and next PACKAGE;

    !defined %{ $pkg }
      and carp $self->_warning( "non-existant package ($pkg)" )
      and next PACKAGE;

    $pkg eq __PACKAGE__ . '::'
      and carp $self->_warning( "Can't ", __PACKAGE__, " myself.",
        " This way lies madness." )
      and next PACKAGE;

    my( $sym, $glob );

    SYMBOL: while ( ($sym, $glob) = each %{ $pkg } ) {

      $pkg eq $sym and next SYMBOL;
      $self->{traced}{ $pkg . $sym } and next SYMBOL;

      if( defined *{ $glob }{CODE} ) {
        my $desc = $pkg . $sym . $self->{verbose};

        $self->{traced}{$pkg . $sym}++;

        Hook::LexWrap::wrap $pkg . $sym,
          pre => $self->_gen_wrapper( $self->{pre}, $pkg, $sym, 1 ),
          post => $self->_gen_wrapper( $self->{post}, $pkg, $sym, 0 );
      }
    }
  }
}

Devel::TrackSub => 'particle';

__END__


=head1 NAME

Devel::TrackSub - Subroutine wrappers for debugging

=head1 VERSION

This document describes version 0.02 of Devel::TrackSub,
released 21 May 2002.

=head1 SYNOPSIS

  package foo;
  sub bar { print "foobar\n" }

  package main;
  use Devel::TrackSub;

  sub foo { print "foo\n"; foo::bar() }

  my $pkg = 'main::';

  my $dbg = Devel::TrackSub->new( pre => '>', post => '<', params => 1 );
  $dbg->trace(
    'foo::',            # valid
    $pkg,               # valid
    'main',             # invalid -- no trailing colons
    'joe::',            # invalid -- non-existant
    $dbg,               # invalid -- references not allowed
    'Debug::SubWrap::', # invalid -- self-reference not allowed
    *main::,            # invalid -- globs not allowed
  );

=head1 DESCRIPTION

Devel::TrackSub allows you to track the entry and exit of subroutines in a list of namespaces you specify. It returns the proper stack depth, and can be configured to return the parameters passed. Error checking prevents silent failures, and unexpected errors. It takes advantage of Hook::LexWrap's do the dirty work of wrapping the subs and return the proper caller context.

=head2 EXPORT

None. Give a hoot, don't pollute!


=head1 AUTHOR

particle, E<lt>particle@artfromthemachine.comE<gt>

=head1 SPECIAL THANKS

Jenda, http://perlmonks.org/index.pl?node_id=105128 for providing a patch to allow the return of subroutine params

=head1 SEE ALSO

L<Hook::LexWrap>.

=cut