view release on metacpan or  search on metacpan

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

	}

	# 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

	my $ctx =  [ [caller 1], \@_, $@, $_ ]; # The benefit of this is access to stored global values
	DB::say '', "Context is stored for $DB::_fix_caller"   if DB::state( 'ddd' ) &64;

	# Replace __ANON__[lib/DB/Hooks.pm:-2] with target sub
	$ctx->[0][3] =  $DB::_fix_caller   if $DB::_fix_caller;
	$ctx->[0][1] =~  s/$DB::options{ pwd }/~/;

	return $ctx;
}



# WORKAROUND: &restore_context is called outside of DB::DB, so we should stop debugging it
# to prevent $file:$line updated in unexpected way
# mutate_sub_is_debuggable( \&restore_context, 0 );

sub restore_context {
	my $ctx =  shift;
	# $_ is implicitly localized at &emit by 'for'
	# But we still beware about it in &DB::interact if you change it there
	# then it will broke the user's context. TODO: IT
	( $@ ) =  @$ctx[ 2 ];
	DB::say 'Context is restored'   if DB::state( 'ddd' ) &64;
}