view release on metacpan or  search on metacpan

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

	my( $one, $count, $format ) =  shift =~ m/^(-?)(\d+)(?:\s+(\w*))?$/;
	$format //=  'oneline'; # TODO: Get default format from options

	# TODO: Clarify code
	my $frames =  DB::frames( defined $count? $count +($one?1:0) : () );
	my $fn =  0; # frame number
	if( $one ) { # At this case $count means target frame
		return get_command 'interact'   unless $count <= @$frames;
		$fn     =  $count;
		$frames =  [ $frames->[ $fn ] ];
	}

	for my $frame ( @$frames ) {
		my( $package, $file, $line, $subname ) =  @$frame[1..4];
		$fn =  0   if $subname eq 'DB::DB';
		my $args    =  $frame->[5] ? $frame->[0] : '';
		my $context =  $frame->[6]? '@' : defined $frame->[6]? '$' : ';';

		if( $args ) {
			$args =  join ', ', map{ defined $_ ? $_ : 'undef' } @$args;
			$args = "($args)";
		}

		DB::say eval $trace_format->{ $format };
		DB::say $@   if $@;
		$fn++;
	}

	return get_command 'interact';
}



sub cmd_debug_expr {
	my( $expr ) =  @_;

	$expr =~ s/(?<!\\);/;\n/;
	$expr =~ s/\\;/;/;

	return [ stay {
		DB::say "Debug result: @{ $_[0] }";
	}
		,"\$^D |= (1<<30);\$DB::single= 1;\n" .$expr
	]
}



sub get_stash {
    require 'Package/Stash.pm'; # BUG? spoils DB:: by emacs, dbline

    my $pkg =  DB::state( 'package' );
    my $stash =  Package::Stash->new( $pkg )->get_all_symbols();

    return $stash, $pkg;
}



sub get_variables {
    require 'PadWalker.pm';
    # my @subs;
    # my $package_name =  caller( DB::state( 'level.frame' ) )[0];
    # foreach $name ( keys %{$package_name .'::'} ) {
    #   push @subs, $name;
    # }

    my $my  =  PadWalker::peek_my ( DB::state( 'level.frame' ) );
    my $our =  PadWalker::peek_our( DB::state( 'level.frame' ) );



    return $my, $our;
}



sub cmd_variables {
	my( $level, $flags, $expr ) =
		(' '.shift) =~ m/^(?:\s+-(\d+))?(?:\s+([amogucs]+))?(?:\s+(.*))?$/;

	$flags //=  '';

	my $type =  0;
	for( split '', $flags ) {
		$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' ) // 0;
	$type  ||=  DB::state( 'vars.type' ) || 3   unless $expr;

	my( $frames, $evals ) =  ( 0, 0 );
	{ # Count debugger and eval frames
		my @frame;
		while( @frame =  caller( $frames++ )  and  $frame[3] ne 'DB::DB' ) {
			$evals++   if $frame[3] eq '(eval)';
		}
		while( @frame =  caller( $frames++ )  and  $level-- > 0 ) {
			$evals++   if $frame[3] eq '(eval)';
		}
		$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';

	my $my  =  PadWalker::peek_my ( $frames -$evals );
	my $our =  PadWalker::peek_our( $frames -$evals );

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

	if( $type & 2 ) {
		DB::say "OUR:", join( ', ', sort keys %$our );
	}

	if( $type & 4 ) {
		require 'Package/Stash.pm'; # BUG? spoils DB:: by emacs, dbline

		my $pkg =  DB::state( 'package' );
		my $stash =  Package::Stash->new( $pkg )->get_all_symbols();
		# Show only user defined variables
		# TODO? implement verbose flag
		# Probably, as MST adviced, we can capture the contents of 'main'
		# *before* you evaluate anything
		if( $pkg eq 'main' ) {
			for( keys %$stash ) {
				delete $stash->{ $_ }   if /::$/;
				delete $stash->{ $_ }   if /^_</;
				delete $stash->{ $_ }   if /^[\x00-\x1f]/; #Remove $^ variables
			}

			delete @$stash{ qw# STDERR stderr STDIN stdin STDOUT stdout # };
			delete @$stash{ qw# BEGIN INIT CHECK END # };
			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 $pkg 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;
			}
		}

		DB::say "GLOBAL:", join( ', ', sort @globals );
	}

	if( $type & 8 ) {
		DB::say "USED:";

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

	if( $type & 16 ) {
		DB::say "CLOSED OVER:";

		# First elements starts at -1 subscript
		my $sub =  DB::frames( $level +2 )->[-1][4];
		if( !defined $sub ) {
			DB::say "Not in a sub: $sub";
		}
		else {
			$sub =  \&$sub;
			DB::say join( ', ', sort keys %{ (PadWalker::closed_over( $sub ))[0] } );
		}
	}

	if( $expr ) {
		(my $vars, $expr) =  split ';', $expr, 2;                          # We can explicitly define variables by enumerating them
		my @vars =  ( $vars || $expr ) =~ m/([\$\%\@]\w+)/g;               # Extract variables from varlist or expression
		$expr //=  $vars;                                                  # By default just dump variables
		@vars =  keys %{{ map{ $_ => 1 } @vars }};                         # Make vars uniq

		# PadWalder returns references to variables. We derefference them at
		# our subroutine. Thus we able to evalutate @array, %hash variables
		# along with $scalar
		$vars =  ''; my $idx =  0;
		for( @vars ) {
			m/^([\$\@\%])/;
			# TODO: Create alias'es instead of new variables
			$vars .=  "\tmy $_ =  $1\{ \$_[$idx] };\n";
			$idx++;
		}

		# TODO: We should eval at user's package to make sub_name( ... ) work
		# Currently we must use Package::Name::sub_name( ... )
		my $result =  eval "return sub{ \n$vars\t$expr\n }";
		DB::say( $@ ), return 1   if $@;


		# Replace variables by theirs values
		for( @vars ) {
			($_ =  $my ->{ $_ }), next   if exists $my ->{ $_ };
			($_ =  $our->{ $_ }), next   if exists $our->{ $_ };

			DB::say "Variable '$_' does not exists at this scope";
			$_ =  \undef;
		}

		DB::say DB::dumper $_   for $result->( @vars );
	}

	return 1;
}



sub cmd_edit_file {
	die 'You should setup EDITOR environment variable'   unless $ENV{ EDITOR };

	## INIT
	my( $file, $line, $editor_args ) =  shift =~ m/^${file_line}?(.*)$/;
	$editor_args //=  '';

	if( !defined $line ) {
		$line =  DB::state( 'list.line' ) -1;

		# Put cursor at required line. EDITOR should center scroll to this line
		$line -=  defined DB::state( 'list.level' )? $lines_before : $lines_after;
	}
	$line =  ':' .$line;

	$file =  current_file( $file ) =~ s/^~/$DB::options{ pwd }/r;
	$file =  `realpath --relative-base $ENV{ PWD } $file`;# Get relative to current symlink