view release on metacpan or  search on metacpan

lib/Devel/DebugHooks.pm  view on Meta::CPAN

			# this makes confusion
			my $filename =  shift // state( 'file' );

			return   unless file( $filename );

			# Keep list of $filenames we perhaps manipulate traps
			$DB::_tfiles->{ $filename } =  1;

			*dbline =  $main::{ "_<$filename" }; #WORKRAOUND RT#119799 (see commit)

			return \%{ "::_<$filename" };
		}



		# Returns TRUE if we can set trap for $file:line
		sub can_break {
			my( $file, $line ) =  @_;

			($file, $line) =  split ':', $file
				unless defined $line;

			return   unless defined( $file =  file( $file ) );

			# TODO: testcase for negative lines
			return ($line<0?-$line-1:$line) <= $#{ "::_<$file" }
				&& ${ "::_<$file" }[ $line ] != 0;

			# http://perldoc.perl.org/perldebguts.html#Debugger-Internals
			# Values in this array are magical in numeric context:
			# they compare equal to zero only if the line is not breakable.
		}
	}



	sub eval_cleanup {
		DB::state( 'inDB', 1 );
		DB::state( 'eval', undef );
	}
	mutate_sub_is_debuggable( \&eval_cleanup, 0 );



	# We put code here to execute it only once
	(my $usercontext =  <<'	CODE') =~ s#^\t\t##gm;
		BEGIN{
			( $^H, ${^WARNING_BITS}, my $hr ) =  @DB::context[1..3];
			%^H =  %$hr   if $hr;
		}
		# $@ is cleared when compiller enters *eval* or *BEGIN* block
		$@ =  $DB::context[4];
	CODE
	# http://perldoc.perl.org/functions/eval.html
	# We may define eval in other package if we want to place eval into other
	# namespace. It will still "doesn't see the usual surrounding lexical scope"
	# because "it is defined in the DB package"
	# sub My::eval {
	sub eval {
		my( $expr ) =  @_;
		# BUG: PadWalker does not show DB::eval's lexicals
		# Q? It is better that PadWalker return undef instead of warn when out of level

		print $DB::OUT "Evaluating '$expr'...\n"   if DB::state( 'ddd' );

		establish_cleanup \&eval_cleanup;
		DB::state( 'eval', 1 );

		my $package =  DB::state( 'package' );
		DB::state( 'inDB', undef );


		# Read BEWARE at DebugHooks.pod about localization of globals
		local $^D;
		local $_ =  $DB::context[5];
		local @_ =  @{ $DB::context[0] };
		eval "$usercontext; package $package;\n#line 1\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
	}



	# Returns the location where $subname is defined in the form:
	# filename:startline-endline
	sub location {
		my $subname =  shift;

		return   unless $subname;
		return   ">>$subname<<"   if ref $subname; # The subname maybe a coderef

		# The subs from DB::* are not placed here. Why???
		# A? Maybe they are placed after module loaded?
		return $DB::sub{ $subname };
	}



	# Returns list of all defined not ANON subs.
	# We may limit the list by supplying regex
	sub subs {
		return keys %DB::sub   unless @_;

		my $re =  shift;
		return grep { /$re/ } keys %DB::sub;
	}



	# Returns caller frame info with arguments at given level
	# or all call stack with goto frames
	sub frames {
		my $level =  shift;

		if( defined $level ) {
			# https://rt.perl.org/Public/Bug/Display.html?id=126872#txn-1380132
			# Note that we should ignore our frame, so +1
			my @frame =  caller( $level +1 );
			return ( [ @DB::args ], @frame );