File Coverage

blib/lib/Devel/RingBuffer/Ring.pm

Criterion	Covered	Total	%
statement	94	117	80.3
branch	10	24	41.6
condition	4	9	44.4
subroutine	38	47	80.8
pod	0	25	0.0
total	146	222	65.7

#/**
# A single shared memory ring buffer for diagnosis/debug of Perl scripts.
# Uses IPC::Mmap to create/access/manage a memory mapped file (or namespace
# on Win32) as a ring buffer structure that can be used by "applications
# under test" that use an appropriate debug module (e.g., Devel::STrace)
# along with an external monitoring application
# (e.g., Devel::STrace::Monitor).
#
# Note that significant functionality is written in XS/C in order to minimize
# tracing/debugging overhead.
#
# Permission is granted to use this software under the same terms as Perl itself.
# Refer to the Perl Artistic License
# for details.
#
# @author D. Arnold
# @since 2006-05-01
# @self $self
#*/
package	Devel::RingBuffer::Ring;

#use threads;
use Time::HiRes qw(time);
use Exporter;

BEGIN {
our @ISA = qw(Exporter);
#
#	consts for member indexes
#
use constant RINGBUF_RING_BUFFER => 0;
use constant RINGBUF_RING_SLOTS => 1;
#
# !!!+++!+!+!+!+!+!+!+!+!+!+!+
#	!!!DON'T CHANGE THIS INDEX UNLESS YOU CHANGE THE XS CODE TOO!!!!
# !!!+++!+!+!+!+!+!+!+!+!+!+!+
#
use constant RINGBUF_RING_ADDR => 2;

use constant RINGBUF_RING_PID => 3;
use constant RINGBUF_RING_TID => 4;
use constant RINGBUF_RING_SLOT => 5;
use constant RINGBUF_RING_DEPTH => 6;
use constant RINGBUF_RING_INDEX => 7;
use constant RINGBUF_RING_MSGSZ => 8;
use constant RINGBUF_RING_HDRSZ => 9;
use constant RINGBUF_BASE_ADDR => 10;

use constant RINGBUF_RING_WAIT => 0.3;

our @EXPORT = ();
our @EXPORT_OK = ();
our %EXPORT_TAGS = (
	ring_members => [
	qw/RINGBUF_RING_BUFFER RINGBUF_RING_SLOTS RINGBUF_RING_ADDR
		RINGBUF_RING_PID RINGBUF_RING_TID RINGBUF_RING_SLOT RINGBUF_RING_DEPTH
		RINGBUF_RING_INDEX RINGBUF_RING_MSGSZ RINGBUF_RING_HDRSZ
		RINGBUF_BASE_ADDR/
	],
);

Exporter::export_tags(keys %EXPORT_TAGS);

};

use Config;
use Devel::RingBuffer;	# to bootstrap
use Devel::RingBuffer qw(:ringbuffer_consts);

our $hasThreads;

BEGIN {
	if ($Config{useithreads} && (!$ENV{DEVEL_RINGBUF_NOTHREADS})) {
		require Devel::RingBuffer::ThreadFacade;
		$hasThreads = 1;
	}
}

use strict;
use warnings;

our $VERSION = '0.31';
#/**
# Constructor. Allocates a ring buffer, and initializes its header
# and control variables.
#
# @param $ringbuffer	the Devel::RingBuffer object
# @param $ringaddr		the base address of this ring
# @param $baseaddr		base address of the complete ring buffer structure
# @param $ringnum		the number (i.e., positional index) of this ring
# @param $slots			number of slots per ring
# @param $msgareasz		size of the per-thread message area
#
# @return Devel::RingBuffer::Ring object on success; undef on failure
#*/
sub new {
	my ($class, $ringbuffer, $ringaddr, $baseaddr, $ringnum, $slots, $msgareasz) = @_;

	my $tid = ($hasThreads ? Devel::RingBuffer::ThreadFacade->tid() : 0);
	_init_ring($ringaddr, $$, $tid, $baseaddr);

	return bless [
		$ringbuffer,
		$slots,
		$ringaddr,
		$$,
		$tid,
		-1,
		0,
		$ringnum,
		$msgareasz,
		RINGBUF_BUFHDR_SZ + $msgareasz,
		$baseaddr
	], $class;
}
#/**
# Constructor. Allocates a ring buffer, and initializes its header
# and control variables. Called when the AUT object (e.g., DB)
# is CLONE'd, so that a new ring can be assigned to the new thread
#
# @return	the Devel::RingBuffer::Ring object
#*/
sub clone {
	my $self = shift;

	my $tid = ($hasThreads ? Devel::RingBuffer::ThreadFacade->tid() : 0);
	my ($ringnum, $ringaddr) = $self->[RINGBUF_RING_BUFFER]->reallocate();
	return undef unless defined($ringnum);
	$self->[RINGBUF_RING_ADDR] = $ringaddr;
	$self->[RINGBUF_RING_INDEX] = $ringnum;
	_init_ring($ringaddr, $$, $tid, $self->[RINGBUF_BASE_ADDR]);
	return $self;
}
#/**
# Constructor. Opens an existing ring buffer for read-only access.
#
# @param $ringbuffer	the Devel::RingBuffer object
# @param $ringaddr		the base address of this ring
# @param $baseaddr		base address of the complete ring buffer structure
# @param $ringnum		the number (i.e., positional index) of this ring
# @param $slots			number of slots per ring
# @param $msgareasz		size of the per-thread message area
#
# @return Devel::RingBuffer::Ring object on success; undef on failure
#*/
sub open {
	my ($class, $ringbuffer, $ringaddr, $baseaddr, $ringnum, $slots, $msgareasz) = @_;

	my ($pid, $tid, $slot, $depth) = _get_header($ringaddr);

	return bless [
		$ringbuffer,
		$slots,
		$ringaddr,
		$pid,
		$tid,
		$slot,
		$depth,
		$ringnum,
		$msgareasz,
		RINGBUF_BUFHDR_SZ + $msgareasz,
		$baseaddr
	], $class;
}
#/**
# Update the current slot. Only updates linenumber and timestamp.
# May be called as either object or class method; in the latter case,
# caller must supply the ring's base address (used within DB::DB()
# to optimize access speed)
#
# @param $address		class method calls only: base address of the ring
# @param $linenumber	linenumber of current statement
#
# @return the Devel::RingBuffer::Ring object
#*/
# @xs updateSlot

#/**
# @xs nextSlot
# Allocate and initialize the next slot. If the stack depth is
# greater than the configured number of slots, the oldest
# in-use slot is used, overwriting its current contents.
# May be called as either object or class method; in the latter case,
# caller must supply the ring's base address (used within DB::sub()
# to optimize access speed)
#
# Note: In future, this should return prior contents so we can restore
#	on de-wrapping.
#
# @param $address		class method calls only: base address of the ring
# @param $entry		subroutine name (from $DB::sub)
#
# @return the stack depth after the slot is allocated.
#*/
# @xs nextSlot

#/**
# @xs freeSlot
# Free the current slot and invalidates its contents.
# May be called as either object or class method; in the latter case,
# caller must supply the ring's base address (used within DB::sub()
# to optimize access speed)
#
# @param $address		class method calls only: base address of the ring
#
# @return the stack depth after the slot is freed.
#*/
# @xs freeSlot

#/**
# Get the ring header values. Header fields returned are
#
#
# pid - PID of the ring owner
# tid - TID of the ring owner
# currSlot - current top slot
# depth - current stack depth
#
#
# @return list of header values
#*/
sub getHeader {
	return _get_header($_[0]->[RINGBUF_RING_ADDR]);
}

#/**
# Get the ring number (i.e., positional index)
#
# @return the ring number
#*/
sub getIndex { return $_[0]->[RINGBUF_RING_INDEX]; }

#/**
# Get the ring base address
#
# @return the ring base address
#*/
sub getAddress { return $_[0]->[RINGBUF_RING_ADDR]; }

#/**
# Get the contents of the specified slot.
#
# @param $slot the number of the slot to return
#
# @return the line number, timestamp, and subroutine name from the slot
#*/
sub getSlot {
	my ($self, $slot) = @_;

	return (-1, 0, '(Invalid slot; ring has been wrapped)')
		if ($slot < 0) || ($slot > $self->[RINGBUF_RING_SLOTS]);

	return _get_slot($self->[RINGBUF_RING_ADDR], $slot);
}
#/**
# Get the ring's trace flag
#
# @return the ring's trace flag
#*/
sub getTrace {
	return _get_trace($_[0]->[RINGBUF_RING_ADDR]);
}

#/**
# Set the ring's trace flag
#
# @param $trace the value to set
#
# @return the prior value of the ring's trace flag
#*/
sub setTrace {
	return _set_trace($_[0]->[RINGBUF_RING_ADDR], $_[1]);
}

#/**
# Get the ring's signal flag
#
# @return the ring's signal flag
#*/
sub getSignal {
	return _get_single($_[0]->[RINGBUF_RING_ADDR]);
}

#/**
# Set the ring's signal flag
#
# @param $signal the value to set
#
# @return the prior value of the ring's signal flag
#*/
sub setSignal {
	return _set_signal($_[0]->[RINGBUF_RING_ADDR], $_[1]);
}

#/**
# Post a command to the ring's command/message area
#
# @param $command the command value to set; must be no more than 3 bytes
# @param $msg	an optional message associated with the command; max length
#				is determined by configuration settings
#
# @return the ring object
#*/
sub postCommand { return postCmdEvent(@_, 1); }

#/**
# Post a response to the ring's command/message area
#
# @param $response the response value to set; must be no more than 3 bytes
# @param $msg	an optional message associated with the response; max length
#				is determined by configuration settings
#
# @return the ring object
#*/
sub postResponse { return postCmdEvent(@_, 0); }

sub postCmdEvent {
	my ($self, $cmd, $msg, $state) = @_;
	_post_cmd_msg($self->[RINGBUF_RING_ADDR], $cmd, $msg, $state);

	return $self;
}

#/**
# Wait indefinitely for a command to be posted to the ring's command/message area.
#
# @return the posted command and message
#*/
sub waitForCommand {
	return waitForCmdEvent(@_, 1);
}

#/**
# Wait indefinitely for a response to be posted to the ring's command/message area.
#
# @return the posted response and message
#*/
sub waitForResponse {
	return waitForCmdEvent(@_, 0);
}

sub waitForCmdEvent {
	my ($cmd, $msg);
	while (1) {
		($cmd, $msg) = _check_for_cmd_msg($_[0]->[RINGBUF_RING_ADDR], $_[1]);
		last if defined($cmd);
		sleep RINGBUF_RING_WAIT;
	}
	return ($cmd, $msg);
}

#/**
# Test if a command is available in the ring's command/message area.
#
# @return if available, the posted command and message; otherwise an empty list
#*/
sub checkCommand {
	return checkCmdEvent(@_, 1);
}

#/**
# Test if a response is available in the ring's command/message area.
#
# @return if available, the posted response and message; otherwise an empty list
#*/
sub checkResponse {
	return checkCmdEvent(@_, 0);
}

sub checkCmdEvent {
	return _check_for_cmd_msg($_[0]->[RINGBUF_RING_ADDR], $_[1]);
}
#/**
# Allocate and initialize a watchlist entry. Sets the watch expression.
#
# @param $expr	expression to set
#
# @return allocated watchlist entry number on success; undef on failure
#*/
sub addWatch {
	return _add_watch_expr($_[0]->[RINGBUF_RING_ADDR], $_[1]);
}

#/**
# Free a watchlist entry.
#
# @param $watch	the watchlist entry number to free
#
#*/
sub freeWatch {
	return _free_watch_expr($_[0]->[RINGBUF_RING_ADDR], $_[1]);
}

#/**
# Get a watchlist expression entry.
#
# @param $watch	the watchlist entry number to get
#
# @return the expression in the watchlist entry, if any; undef otherwise
#*/
sub getWatchExpr {
	return $_[0]->[RINGBUF_RING_BUFFER] ?
		_get_watch_expr($_[0]->[RINGBUF_RING_ADDR], $_[1]) :
		undef;
}

#/**
# Set a watchlist result entry.
#
# @param $watch	the watchlist entry number to set
# @param $result the result of the expression evaluation
# @param $error error string if expression evaluation fails
#*/
sub setWatchResult {
	my ($self, $watch, $result, $error) = @_;

	return $self->[RINGBUF_RING_BUFFER] ?
		_set_watch_result($self->[RINGBUF_RING_ADDR], $watch, $result, $error) :
		undef;
}
#/**
# Get a watchlist expression entry. If the length of the result exceeds
# the configured message size, the result is truncated. If the result is
# undef, the length will zero, and both the result and error will be undef.
# If the evaluation caused a failure, the length indicates the length of
# the error string, and result will be undef.
#
# @param $watch	the watchlist entry number to get
#
# @return the complete length of the result, the (possibly truncated) result value,
#			and the (possibly truncated) error message (if the evaluation failed).
#*/
sub getWatchResult {
	return $_[0]->[RINGBUF_RING_BUFFER] ?
		_get_watch_result($_[0]->[RINGBUF_RING_ADDR], $_[1]) :
		(undef, undef, undef);
}
#/**
#	Destructor. Updates the Devel::RingBuffer container object's free ring map,
#	but only if executed in the same process/thread that it was allocated'd in.
# (Note that due to threads CLONE, a ring object may be cloned with PID/TID
# of another thread, and thus DESTROY() could cause an invalid destruction)
#
#	A future enhancement will add a flag to indicate to preserve
#	the ring on exit for post-mortem analysis
#*/
sub DESTROY {
#
#	for some reason we're getting leakage of ring objects into
#	the root thread, so only destroy in the thread its created
#
#	return unless defined($_[0]->[RINGBUF_RING_BUFFER]) &&
#		($_[0]->[RINGBUF_RING_PID] == $$) &&
#		($_[0]->[RINGBUF_RING_TID] == threads->self()->tid());
	return unless defined($_[0]->[RINGBUF_RING_BUFFER]);
	my @hdr = _get_header($_[0]->[RINGBUF_RING_ADDR]);
	my $tid = ($hasThreads ? Devel::RingBuffer::ThreadFacade->tid() : 0);

	return
		unless ($hdr[0] == $$) && ($hdr[1] == $tid);
	$_[0]->[RINGBUF_RING_BUFFER]->free($_[0]->[RINGBUF_RING_INDEX]);
}

1;