#/**
# Provides a minimal strace/truss-like utility for
# Perl scripts. Using <a href='http://search.cpan.org/perldoc?Devel::RingBuffer'>
# Devel::RingBuffer</a>, each new subroutine call is logged to an mmap'ed shared memory
# region (as provided by <a href='http://search.cpan.org/perldoc?IPC::Mmap'>IPC::Mmap</a>).
# As each statement is executed, the line number and Time::HiRes:;time() timestamp
# are written to the current ringbuffer slot. An external application can
# then monitor a running application by inspecting the mmap'ed area (see
# <a href='http://search.cpan.org/perldoc?Devel::STrace::Monitor'>Devel::STrace::Monitor</a>
# and the associated plstrace.pl application for an example).
# <p>
# Permission is granted to use this software under the same terms as Perl itself.
# Refer to the <a href='http://perldoc.perl.org/perlartistic.html'>Perl Artistic License</a>
# for details.
#
# @author D. Arnold
# @since 2006-05-01
# @see <a href='http://search.cpan.org/perldoc?Devel::RingBuffer'>Devel::RingBuffer</a>
# @see <a href='http://search.cpan.org/perldoc?IPC::Mmap'>IPC::Mmap</a>
# @see <a href='http://search.cpan.org/perldoc?Devel::STrace::Monitor'>Devel::STrace::Monitor</a>
# @see <a href='http://perldoc.perl.org/perldebguts.html'>perdebguts</a>
# @self $self
#*/
package Devel::STrace;
require 5.008;
package DB;
#use threads;
use Config;
use Time::HiRes qw(time);
use Devel::RingBuffer;
use Devel::RingBuffer qw(:ringbuffer_consts);
$Devel::STrace::VERSION = '0.31';
# disable DB single-stepping
BEGIN {
if ($Config{useithreads} && (!$ENV{DEVEL_RINGBUF_NOTHREADS})) {
require Devel::RingBuffer::ThreadFacade;
$hasThreads = 1;
}
else {
$hasThreads = undef;
}
$single = 0;
$subtrace = 1;
$tid = -1;
$pid = -1;
$ringbuffer = undef;
$myring = undef;
$depth = 0;
$single = 1;
$inited = 0;
#
# DESTROY occasionally attempts to retie
# after we've lost the objects we get our fixed
# addresses from, so use local vars for them
#
$ringaddr = undef;
local ($pkg, $filename, $line);
}
#/**
# Threads clone method. Allocates a new ring, and
# and populates the existing cloned ring object with
# the newly allocate ring information.
#
# @static
#*/
sub CLONE {
# print STDERR " ++++ In CLONE for ", Devel::RingBuffer::ThreadFacade->tid(), "\n";
my ($oldtrace, $oldsingle) = ($subtrace, $single);
$pid = $$;
$tid = $hasThreads ? Devel::RingBuffer::ThreadFacade::tid() : 0;
$subtrace = 0;
$single = 0;
if (defined($myring)) {
$myring->clone();
$ringaddr = $myring->getAddress();
# print STDERR "\n$tid Allocd ring ", $myring->getIndex(), "\n";
}
else {
$ringaddr = undef;
}
($single, $subtrace) = (1, $oldtrace);
# print STDERR " ++++ Exit CLONE for ",
# Devel::RingBuffer::ThreadFacade->tid(), " with $ringaddr\n";
}
#/**
# Debug a single statement. Creates a ringbuffer if none exists.
# Allocates a new ring if executed in a new process. Updates
# the ring's current slot with the current line number and timestamp.
#
# @static
#*/
sub DB {
#
# if subtracing is disabled OR
# we're tracing one of our debugger modules OR
# we've init'd but theres no ringbuffer
# (meaning we're in global DESTROY),
# then skip out of this
#
return if (! $subtrace) || ($inited && (! $ringbuffer)) ||
($sub && (substr($sub, 0, 19) eq 'Devel::RingBuffer::'));
$subtrace = 0;
$single = 0; # no effect if tied
#print STDERR "In DB::DB\n";
unless (defined($ringbuffer)) {
#print STDERR "DB::DB initing the ringbuffer\n";
$ringbuffer = Devel::RingBuffer->new(TraceOnCreate => 1);
#
# alloc the root's ringbuffer so we can tie to it
#
$pid = $$;
$tid = ($hasThreads ? Devel::RingBuffer::ThreadFacade->tid() : 0);
$myring = $ringbuffer->allocate();
die "Can't get a ring!!!!\n"
unless $myring;
$depth = 0;
$ringaddr = $myring->getAddress();
print STDERR "\n*** Ringbuffer file is ", $ringbuffer->getName(), "\n";
# print STDERR "\n$tid Allocd ring ", $myring->getIndex(), "\n";
$inited = 1;
}
#
# check our pid; CLONE will handle threads for us
#
if ($pid != $$) {
#
# we keep the existing realdepth, since we may pop out
# of the fork level
#
$pid = $$;
$tid = ($hasThreads ? Devel::RingBuffer::ThreadFacade->tid() : 0);
$myring = $myring->clone();
$depth = 0;
#
# if we can't get a ring buffer, exit
#
$single = 0,
print STDERR "Can't get a ring!!!!\n" and
return
unless $myring;
$ringaddr = $myring->getAddress();
}
#
# update the current slot's line number and timestamp;
# note the update is suppressed in updateSlot if trace flag off
# (tho it doesn't contribute much optimization)
#
($pkg, $filename, $line) = caller;
Devel::RingBuffer::Ring::updateSlot($ringaddr, $line);
$single = 1;
$subtrace = 1;
}
#/**
# Debug a subroutine call. If trace is enabled
# in the ring, the next slot is allocated and the called
# subroutine (from $DB::sub) is written to it. The subroutine
# is then called with the caller's return context, and then
# the slot is freed before returning. Note that this method
# requires additional control to handle re-entrancy when
# DB::DB() or DB::sub() make calls to the various support
# functions.
#
# @static
# @return The subroutine's return value(s), if the
# caller is not in void context.
#*/
sub sub {
#
# alloc next slot
# fill with info
# call &$sub
# clear slot
# free it up
#
# !!!TODO: return the current slot contents prior to writing over
# it; that way we can restore it after we return!!!
#
# !!!NOTE NOTE NOTE!!!
# we need to untie when realdepth goes to zero, and tie when it goes
# to one
#
my @ret;
my $ret;
my $wassingle = defined($myring) ? Devel::RingBuffer::Ring::getFlags($ringaddr) : $single;
unless ($subtrace && ($wassingle & 3) && defined($myring) &&
(substr($sub, 0, 19) ne 'Devel::RingBuffer::')) {
if (wantarray) {
@ret = &$sub;
}
elsif (defined(wantarray)) {
$ret = &$sub;
}
else {
&$sub;
}
return (wantarray) ? @ret : defined(wantarray) ? $ret : undef;
}
$subtrace = 0;
# print STDERR "In $$:$tid DB::sub for $sub $depth\n";
my $tsub ="$sub";
$tsub = 'main' unless $tsub;
#
# If $sub ends with '::AUTOLOAD', note we've traced into AUTOLOAD
#
$tsub .= " for $$tsub"
if (( length($tsub) > 10) && (substr( $tsub, -10, 10 ) eq '::AUTOLOAD' ));
#
# now log the info in the slot; note that we rely on
# DB::DB to set the lineno
# !!!NOTE: we need to extract startlines of subs
#
$depth = Devel::RingBuffer::Ring::nextSlot($ringaddr, $tsub);
# print STDERR "In $$:$tid got depth of $depth\n"
# if $depth && (($depth < 0) && ($depth > 20));
$subtrace = 1;
#
# call it in proper context, then unwind
#
if (wantarray) {
@ret = &$sub;
}
elsif (defined wantarray) {
$ret = &$sub;
}
else {
&$sub;
}
if (defined($depth) && ($depth >= 0)) {
$subtrace = 0;
$depth = Devel::RingBuffer::Ring::freeSlot($ringaddr);
$subtrace = 1;
# print STDERR "*** $$:$tid return from $sub $depth\n";
_traceback() if ($depth < 0);
}
return (wantarray) ? @ret : defined(wantarray) ? $ret : undef;
}
sub _traceback {
my $i = 2;
while (1) {
my @t = caller($i++);
last unless $t[2] || $t[3];
print STDERR "\t*** called from $t[3]:$t[2]\n";
}
}
1;