view release on metacpan or  search on metacpan

lib/B/Debugger.pm  view on Meta::CPAN

use constant DBG_NEXT => 3;
use constant DBG_QUIT => 4;
our ($next_op, %break_op, @ops, %opnames, %opt, $last_in);

sub debugger_banner {
  our $maxo = Opcode::opcodes();
  for my $o (grep(/^-/, @_)) { $opt{$o}++; }
  print "\nB::Debugger $XS_VERSION - optree debugger. h for help\n";
}
sub debugger_help {
  print "Usage:\n";
  my @left = (
	      "n [n] next op",			#1
	      "c [n] continue (until)",		#2
	      "b <n> break at op",		#3
	      "s     step into kids",		#4
	      "sib   step to next sibling",	#5
	      "u [n] up",			#6
	      "g <n> goto",			#7
	      "h     help",			#8
	      "q     quit debugger, execute",	#9
	      );
  my @right = (
	       "l [n|x-y]     list ops",	#1
	       "d|Debug       op",		#2
	       "o|Concise     op",		#3
	       "f|Flags       op",		#4
	       "x|eval expr",			#5
	       "[sahpicg]v<n> n-th global var: sv1,",	#6
	       "pad <n>       n-th pad variable (my)",	#7
	       "",					#8
	      "exit           quit with no execution",	#9
	       );
  my $max = $#left > $#right ? $#left : $#right;
  for my $i (0 .. $max) {
    print sprintf("%-35s %s\n", $left[$i], $right[$i]);
  }
}

# numeric in the valid range 0..PL_maxo or a valid opname
sub valid_breakpoint {
  $b = shift;
  return $b if $b =~ /^\d+$/ and $op >= 0 and $op <= $maxo;
  unless (%opnames) {
    for my $opnum (0 .. $maxo ) {
      my $ppname = B::ppname($opnum); # pp_{name}
      $opnames{substr($ppname,3)} = $opnum;
    }
  }
  return exists $opnames{lc($b)} ? lc($b) : undef;
}

sub debugger_prompt {
  my $op = $_[0]; # need to manipulate it
  print "op $opidx ",$op->name,"\n"; # ?: full concise, size, flags?
  print "> ";
  my $in = readline(*STDIN);
  chomp $in;
  $in = $last_in unless $in;
  $last_in = $in;
  # $in =~ s/[:cntrl:]//g; # strip control chars, cursor keys
  if ($in =~ /^(h|help)$/) { debugger_help; return DBG_SAME; }
  elsif ($in =~ /^(q|quit)$/) { print "quit\nexecuting...\n"; return DBG_QUIT; }
  elsif ($in =~ /^exit$/) { print "exit\n"; exit; } # FIXME! Add an exit hook into INIT?
  elsif ($in =~ /^(x|eval)\s+(.+)$/) { print (eval "$2"),"\n"; return DBG_SAME; }
  elsif ($in =~ /^(n|next)$/) {
    print "..next\n" if $opt{debug};
    return DBG_NEXT;
  }
  elsif ($in =~ /^(n|next)\s+(\w+)$/) { # count
    my $count = valid_breakpoint($2);
    print "..next $count\n" if $opt{debug};
    $count = ($count and $count =~ /^\d$/);
    unless ($count) { print "invalid count \"$count\"\n"; return DBG_NEXT; }
    $break_op{$opidx + $count} = 2;
    return DBG_CONT;
  }
  elsif ($in =~ /^(b|break)\s+?(\w+)?$/) { # opidx or name?
    my $b = valid_breakpoint($2);
    unless ($b) { print "invalid breakpoint \"$b\"\n"; return DBG_SAME; }
    if (exists $break_op{$b}) { undef $break_op{$b};
				 print "breakpoint $b removed\n"; }
    else { $break_op{$b} = 1; print "breakpoint $b added\n"; }
    return DBG_SAME;
  }
  elsif ($in =~ /^(c|cont)$/) {
    return DBG_CONT;
  }
  elsif ($in =~ /^(c|cont)\s+(\w+)$/) { # arg <opidx> or next matching name?
    my $b = valid_breakpoint($2);
    print "..cont $b\n" if $opt{debug};
    unless ($b) { print "invalid breakpoint \"$b\"\n"; return DBG_SAME; }
    $break_op{$b} = 2 if $b; # 2: delete this op at the next break
    return DBG_CONT;
  }
  elsif ($in =~ /^(u|up)\s*(\w+)?$/) {
    if ($2 and valid_breakpoint($2)) {
      my $b = valid_breakpoint($2);
      unless ($b) { print "invalid opidx \"$b\"\n"; return DBG_SAME; }
      $opidx = $b;
    } else {
      $opidx--;
    }
    if (exists $ops[$opidx]) { $_[0] = $ops[$opidx]; } # rewind
    print "up to $opidx\n" if $opt{debug};
    return DBG_SAME;
  }
  elsif ($in =~ /^(g|goto)\s+(\w+)$/) { # arg <opidx>
    my $b = valid_breakpoint($2);
    unless ($b) { print "invalid breakpoint \"$b\"\n"; return DBG_SAME; }
    $break_op{$b} = 2; # 2: delete this op at the next break
    return DBG_CONT;
  }
  elsif ($in =~ /^(s|step)$/) {
    if ($op->flags & OPf_KIDS) {
      $opidx++;
      print "..step into kids: $op->first->name\n" if $opt{debug};
      return debugger_walkoptree($op->first, \&debugger_prompt, [ $op->first ])
    } else {
      print "no kids\n";
      return DBG_SAME;