view release on metacpan or  search on metacpan

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

			$$handler->{ steps_left } =  $1;
		}


		# Do not stop if subcall is maden
		my $handler =  DB::reg( 'frame', 'step_over' );
		# FIX: move handler code to upper frames if we leave current one
		$$handler->{ code } =  sub{ $_[1]{ single } =  0; 1 };
		$handler =  DB::reg( 'stop', 'step_over' );
		$$handler->{ code } =  sub{
			DB::unreg( 'stop', 'step_over' );
			DB::unreg( 'frame', 'step_over' );
			1;
		};

		my $stack =  DB::state( 'stack' );
		# If the current OP is last OP in this sub we stop at *some* outer frame
		$_->{ single } =  2   for @$stack;

		return;
	}

	# Quit from the debugger
	,q => sub {
		for( @$DB::state ) {
			for( @{ $_->{ stack } } ) { # TODO: implement interface to debugger instance
				$_->{ single } =  0;
			}
		}

		exit;
	}

	# TODO: print list of vars which refer this one
	,vars => sub {
		my( $level, $type, $var ) =
			(' '.shift) =~ m/^(?:\s+-(\d+))?(?:\s+([amogucs]+))?(?:\s+([\$\%\*\&].*))?$/;

		for( split '', $type ) {
			$type |= ~0   if /^a|all$/;
			$type |= 1    if /^m|my$/;
			$type |= 2    if /^o|our$/;
			$type |= 4    if /^g|global$/;
			$type |= 8    if /^u|used$/;
			$type |= 16   if /^c|closured$/;
			$type |= 24   if /^s|sub$/;       #u+c
		}
		$level //=  DB::state( 'list.level' );
		$type  //=  DB::state( 'vars.type' ) // 3   unless $var;


		my $dbg_frames =  0;
		{ # Count debugger frames
			my @frame;
			1 while( @frame =  caller( $dbg_frames++ )  and  $frame[3] ne 'DB::DB' );
			$dbg_frames--;
		}


		#FIX: When we debug debugger we can not 'go <line>' we always stops at
		#require at third line at PadWalker.pm. Debug who set $DB::state = 1
		require 'PadWalker.pm';
		require 'Package/Stash.pm'; # BUG? spoils DB:: by emacs, dbline

		my $my =   PadWalker::peek_my(  $level +$dbg_frames );
		my $our =  PadWalker::peek_our( $level +$dbg_frames );

		if( $type & 1 ) {
			# TODO: for terminals which support color show
			# 1. not used variables as grey
			# 2. closed over variables as green or bold
			print $DB::OUT "\nMY:\n", join( ', ', sort keys %$my ), "\n";
		}

		if( $type & 2 ) {
			print $DB::OUT "\nOUR:\n", join( ', ', sort keys %$our ), "\n";
		}

		if( $type & 4 ) {
			my $stash =  Package::Stash->new( DB::state( 'package' ) )->get_all_symbols();
			# Show only user defined variables
			# TODO? implement verbose flag
			if( DB::state( 'package' ) eq 'main' ) {
				for( keys %$stash ) {
					delete $stash->{ $_ }   if /::$/;
					delete $stash->{ $_ }   if /^_</;
					delete $stash->{ $_ }   if /^[\x00-0x1f]/; #Remove $^ variables
				}

				delete @$stash{ qw# STDERR stderr STDIN stdin STDOUT stdout # };
				delete @$stash{ qw# SIG INC F ] ENV ; > < ) ( $ " _ # }; # a b
				delete @$stash{ qw# - + ` & ' #, 0..99 };
				# BUG? warning still exists despite on explicit escaping of ','
				delete @$stash{ qw# ARGV ARGVOUT \, . / \\ | # };
				delete @$stash{ qw# % - : = ^ ~ # };
				delete @$stash{ qw# ! @ ? # };
			}
			delete $stash->{ sub }   if DB::state( 'package' ) eq 'DB';

			my @globals =  ();
			my %sigil =  ( SCALAR => '$', ARRAY => '@', HASH => '%' );
			for my $key ( keys %$stash ) {
				my $glob =  $stash->{ $key };
				for my $type ( keys %sigil ) {
					next   unless defined *{ $glob }{ $type };
					next   if $type eq 'SCALAR'  &&  !defined $$glob;
					next   if $key =~ /::/;
					push @globals, $sigil{ $type } .$key;
				}
			}

			print $DB::OUT "\nGLOBAL:\n", join( ', ', sort @globals ), "\n";
		}

		if( $type & 8 ) {
			print $DB::OUT "\nUSED:\n";

			# First element starts at -1 subscript
			# FIX: When debug debugger and we step over this statement
			# the $sub contain reference ot &vars instead of name of last
			# client's sub
			my $sub =  DB::state( 'stack' )->[ -$level -1 ]{ sub };
			if( !defined $sub ) {
				# TODO: Mojolicious::__ANON__[/home/feelsafe/perl_lib/lib/perl5/Mojolicious.pm:119]
				# convert this to subroutine refs
				# print $DB::OUT "Not in a sub: $sub\n";
				print $DB::OUT "Not in a sub\n";
			}
			else {
				$sub =  \&$sub;
				print $DB::OUT join( ', ', sort keys %{ PadWalker::peek_sub( $sub ) } ), "\n";
			}
		}

		if( $type & 16 ) {
			print $DB::OUT "\nCLOSED OVER:\n";

			# First elements starts at -1 subscript
			my $sub =  DB::state( 'stack' )->[ -$level -1 ]{ sub };
			if( !defined $sub ) {
				print $DB::OUT "Not in a sub\n";
				# print $DB::OUT (ref $sub ) ."Not in a sub: $sub\n";
			}
			else {
				$sub =  \&$sub;
				print $DB::OUT join( ', ', sort keys %{ (PadWalker::closed_over( $sub ))[0] } ), "\n";
			}
		}

		if( $var ) {
			my( $sigil, $name, $extra ) =  $var =~ m/^(.)(\w+)(.*)$/;

			$var =  $sigil .$name;
			unless( exists $my->{ $var } || exists $our->{ $var } ) {
				print $DB::OUT "Variable '$var' does not exists at this scope\n";
				return -1;
			}

			my $value =  $my->{ $var }  ||  $our->{ $var };
			$value =  $$value   if $sigil eq '$';
			eval "\$value =  \$value$extra; 1"   or die $@;
			print $DB::OUT dd( $value ), "\n";
		}

		1;
	}
	,B => sub {
		my( $args, $opts ) =  @_;
		$opts->{ verbose } //=  1;

		if( $_[0] eq '*' ) {
			#TODO: implement removing all traps
			#B 3:* - remove all traps from file number 3
		}


		my( $file, $line, $subname ) =  shift =~ m/^${file_line}|([\w:]+|&)$/;


		if( defined $subname ) {
			if( $subname eq '&' ) {
				$subname =  DB::state( 'goto_frames' )->[ -1 ][ 3 ];
				return -1   if ref $subname; # can not set trap on coderef
			}

			DB::unreg( 'call', 'breakpoint', $subname );
			# Q: Should we remove all matched keys?
			# A: No. You may remove required keys. Maybe *subname?
		}
		else {
			#FIX: this is copy/paste block. see above
			$line     =  DB::state( 'line' )   if $line eq '.';
			my $traps =  DB::traps( file( $file, 1 ) );
			return -1   unless exists $traps->{ $line };

			# TODO: remove only one action
			DB::unreg( 'trap', 'breakpoint', $file, $line );
		}


		#TODO? use &DB::process
		$DB::commands->{ b }->()   if $opts->{ verbose };

		1;
	}