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 dept
+h, and can be configured to return the parameters passed. Error check
+ing prevents silent failures, and unexpected errors. It takes advanta
+ge of Hook::LexWrap's do the dirty work of wrapping the subs and retu
+rn 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 pa
+tch to allow the return of subroutine params

=head1 SEE ALSO

L<Hook::LexWrap>.

=cut