view release on metacpan or  search on metacpan

lib/DB/Hooks.pm  view on Meta::CPAN

		$msg[1] .=  " D>$rand";
		DB::say @msg;
	}

	my @res;
	{
		# IT: 2+2;e;
		# This will require Data::Dump which triggers postpone method to be called
		# and reenter the debugger. So we should check recurse when DB::dbcall is made:
		# TODO? Should we move this into DB::new?
		DB::start_dd   if DB::state( 'dbcall' );


		# NOTICE: Old value of $DB::single/trace/signal is stored by constructor
		# and restored when we leave this block
		my $dd_frame =  DB::new( $ctx );


		# Here we control debugger debugging (also see DB::process)
		$^D |= (1<<30)   if DB::state( 'dd' );

		DB::state( dbcall => 1 +$level );
		defined wantarray? @res= &$sub : &$sub;
		DB::state( dbcall => undef );

		# $^D &= ~(1<<30)   if DB::state( 'dd' ); # TODO??? Should we turn off flag at the end
	}

	($DB::after_dbcall->(), undef $DB::after_dbcall)   if $DB::after_dbcall;

	DB::say '<-- dbcall'. " " .DB::_c( DB::flags, '1;90' ) ." D<$rand"   if $ddd &32;
	return defined wantarray? @res : ();
}


# NOTICE:
# In theory any additional pakcage usage may break user's code
# because this usage cause packages to be loaded in different order under debugger
# in compare to the order they are loaded without it
use Sub::Metadata qw/ mutate_sub_is_debuggable /;


## The debugger instance
mutate_sub_is_debuggable( \&state, 0 );
sub state {
	my( $name, $value ) =  @_;
	# During a global destruction if something was loaded before the debugger it will be
	# destroyed after the debugger. Calls to `DESTROY` will still fire DB::sub, but the
	# debugger does not exists already, thus @DB::state is empty
	# TODO: We can undefine DB::sub if last instance was destroyed instead of frequently
	# checks here
	return @_>1 ? $DB::state[-1]{ ddd } =  $value : $DB::state[-1] && $DB::state[-1]{ ddd } // 0
	   if $name eq 'ddd';

	my $hash =  $DB::state[$DB::instance];

	my $ddd =  $hash->{ ddd } // 0;
	# Track changes to DB::state  OR  reads from DB::state
	if( $ddd&4 && @_>1  ||  $ddd&8 && @_<=1 ) {
		my( $sub ) =  (caller(1))[3];
		my( $file, $line ) =  (caller)[1,2];
		my $old_value =  vis_undef( $hash->{ $name } );
		my $new_value =  @_ > 1 ? ' -> ' .vis_undef( $value ) : '';

		DB::say "Access from $sub ($file:$line) to "
			.DB::_c( $name, 36 ) ." state($DB::instance): "
			.DB::_c( "$old_value$new_value", '3;37' )
	}

	return $hash->{ $name }   unless @_ > 1;
	delete $hash->{ $name }, return   unless defined $value;

	$DB::trace = $value   if $name eq 'trace';
	return $hash->{ $name } =  $value;

	$name =  '*'   unless exists $DB::variables{ $name };
	return $DB::variables{ $name }( @_ );
}



sub int_vrbl {
	my( $name, $value ) =  @_;

	if( @_ > 1 ) {
		${ "DB::$name" } =  $value;
	}

	return dbg_vrbl( @_ );
}



sub dbg_vrbl {
	my( $name, $value ) =  @_;

	# TODO: Assert the change to saved 'context'
	# We should not rewrite saved context otherwise we restore to wrong context
	# Access to context(0) state: ARRAY -> ARRAY

	my $hash =  $DB::state[-1];
	if( @_ > 1 ) {
		defined $value
			? $hash->{ $name } =  $value
			: delete $hash->{ $name };
	}

	return $hash->{ $name };
}



sub new {
	my $ctx =  shift;

	my( $ddd, $t, $dd ) =  0;
	if( @DB::state ) { # There is no debugger states if debugger loading is in progress
		# Save internal flags when we enter debugger
		DB::state( context =>  $ctx        );
		DB::state( single  =>  $DB::single );
		DB::state( trace   =>  $DB::trace  );

lib/DB/Hooks.pm  view on Meta::CPAN

	# Find testcase for this condition
	if( @DB::state ) { # There is no debugger states if main script was terminated
		$DB::single =  DB::state( 'single' ) // 0;
		$DB::trace  =  DB::state( 'trace'  ) // 0;
		DB::say 'Debug flag is restored: $single =  ' .$DB::single   if $ddd &32;

		my $ctx =  DB::state( 'context' );
		# WARNING: Do not keep any references to user's data eg. @_
		# Otherwise we postpone object desctruction process.
		DB::state( context => undef ); # $ctx->[0] =  undef # TODO: IT
		DB::finish_dd       if DB::state( 'xx' );
		# TODO: Flag should be restored from main frame if we do not continue debugging
		# TODO: IT; Compare with 090da7c: NOTICE: Create debugger instance only ...
		restore_context( $ctx );
	}
}



# Parse x=y pairs. Options in different format are skipped. Eg. ::Name will be handled
# later by ::import.
sub parse_options {
	my @opts =  split ' ', $ENV{ PERLDB_OPTS }   if defined $ENV{ PERLDB_OPTS };

	for( @opts, @_ ) {
		if( /^([:\w]+)=(.*)/ ) {
			$DB::options{ $1 } =  $2;
		}
		else {
			$DB::options{ $_ } =  1;
		}
	}
}



# This sub applies options from $DB::options to DB::state
# NOTICE: This sub is called twice: at compile time and before run time of 'main' package
sub apply_options {
	$DB::options{ DumpObjects } //=  1;
	if( $DB::options{ DumpObjects } ) {
		require Scalar::Util;
		Scalar::Util->import(qw/ reftype blessed /);
		mutate_sub_is_debuggable( \&DB::reftype, 0 );
		mutate_sub_is_debuggable( \&DB::blessed, 0 );
	}


	my $ct =  shift // '';
	# { ddd } flag should be first to see debugging messages for next
	for( qw/ ddd dd trace TraceLoad TraceGoto TraceCall TraceStack TraceReturn / ) {
		DB::state( $_ =>  $DB::options{ "${ct}$_" } );
	}

	# When we are going to work at white_box we must activate black_box
	# because white_box can be activated only from black_box (see DB::sub)
	if( $DB::options{ "${ct}white_box" } ) {
		DB::state( black_box_active => 1 );
	}

	# We may check if (caller)[3] eq 'import' to distinguish CT and RT
	$^P &= ~0x20               if $DB::options{ NonStop };
	DB::state( 'single', 1 )   if $DB::options{ Stop }; # IT: commit:1191c38
}



sub _leave {
	my $class =  shift;

	# Now debugger and all required modules are loaded (except Descendant).
	# We should inspect %DB::options and setup corresponding perl debugger
	# *internal* values
	# When <DEBUGGER>::import returns the next OP will be first OP from main::

	# We are leaving debugger
	my $handler; $handler =  DB::on( return => sub{
		#TODO? Should be call this from 'postpone'?
		return   unless $_[0] eq $class .'::import';

		DB::unsubscribe( return => $handler );
		$DB::after_dbcall = sub{
			my $dbg =  DB::new;              # Create RT debugger
			$DB::instance++;
			# NOTICE: Circular reference is here.
			# The debugger instance exists until main script is terminated
			DB::state( debugger => $dbg );   # Make debugger instance accessable via state
			#TODO? Probably we want apply options as soon as possible, but keep an eye to
			# DB::instance, because we may apply them to a wrong instance.
			apply_options();

			# TODO: Because RT and CT options are differ on command line
			# We may leave CT debugger alive for history reasons
			# Delete CT debugger
			push @DB::state, shift @DB::state; # Swap RT and CT debuggers
			DB::state( debugger => undef );
			$DB::instance--;


			no strict 'refs'; no warnings 'redefine';
			*{ "DB::on" }          =  \&{ "DB::RT_on" };
			*{ "DB::unsubscribe" } =  \&{ "DB::RT_unsubscribe" };

			DB::say DB::c_( "RT debugger initialized:" , '1;32' ), DB::dumper \@DB::state
			   if DB::state( 'ddd' ) &16;
		};

		return;
	});
}



## Evaluation in usercontext
# We put code here to execute it only once
my $usercontext; BEGIN {
($usercontext =  <<'CODE') =~ s#^\t##gm;
	BEGIN {
		( $^H, ${^WARNING_BITS}, my $hr ) =  @{ DB::state( 'context' )->[0] }[8..10];
		%^H =  %$hr   if $hr;
	}