view release on metacpan or  search on metacpan

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

}



# 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;
	}
	# $@ is cleared when compiller enters *eval* or *BEGIN* block
	$@ =  (DB::state( 'context' ))[2];
CODE
}
sub eval {
	my $expr =  shift // return;

	DB::state( last_eval => $expr );

	my $ctx =  DB::state( 'context' );
	my $pkg =  $ctx->[0][0];
	# Read BEWARE at DebugHooks.pod about localization of globals
	local $^D;
	local $_ =  $ctx->[3];
	local @_ =  @{ $ctx->[1] };
	# TODO: Beware that using eval neither silences Perl from printing warnings to STDERR,
	# nor does it stuff the text of warning messages into $@
	# How to reproduce: $expr = '234asd';
	eval "$usercontext; package $pkg;\n$expr";
	#NOTICE: perl implicitly add semicolon at the end of expression
	#HOWTO reproduce. Run command: X::X;1+2
	#
	# print $DB::OUT "Error occur while evaluating: $@"   if $@
	# But if we do this we return wrong value
}

# In theory &save_context should be called as soon, as possible.
sub save_context {
	# TODO: What to save:
	# https://metacpan.org/source/OPI/Perl-AtEndOfScope-0.03/lib/Perl/AtEndOfScope.pm
	# also see perl5db.pl
	# TODO: Debugger destroyes $1, $2 etc variables in scope