lib/Sepia/Debug.pm

   1 package Sepia::Debug;
   2 # use Sepia;
   3 use Carp ();                    # old Carp doesn't export shortmess.
   4 use Text::Abbrev;
   5 use strict;
   6 use vars qw($pack $file $line $sub $level
   7             $STOPDIE $STOPWARN);
   8
   9 sub define_shortcut;
  10 *define_shortcut = *Sepia::define_shortcut;
  11
  12 BEGIN {
  13     ## Just leave it on -- with $DB::trace = 0, there doesn't seem
  14     ## to be a perforamnce penalty!
  15     $^P = 0x303;
  16     $STOPDIE = 1;
  17     $STOPWARN = 0;
  18 }
  19
  20 sub peek_my
  21 {
  22     eval { require PadWalker };
  23     if ($@) {
  24         +{ }
  25     } else {
  26         *peek_my = \&PadWalker::peek_my;
  27         goto &peek_my;
  28     }
  29 }
  30
  31 # set debugging level
  32 sub repl_debug
  33 {
  34     debug(@_);
  35 }
  36
  37 sub repl_backtrace
  38 {
  39     for (my $i = 0; ; ++$i) {
  40         my ($pack, $file, $line, $sub) = caller($i);
  41         last unless $pack;
  42         # XXX: 4 is the magic number...
  43         print($i == $level+4 ? "*" : ' ', " [$i]\t$sub ($file:$line)\n");
  44     }
  45 }
  46
  47 # return value from die
  48 sub repl_return
  49 {
  50     if ($Sepia::WANTARRAY) {
  51         @Sepia::REPL_RESULT = $Sepia::REPL{eval}->(@_);
  52     } else {
  53         $Sepia::REPL_RESULT[0] = $Sepia::REPL{eval}->(@_);
  54     }
  55     last repl;
  56 }
  57
  58 use vars qw($DIE_TO @DIE_RETURN $DIE_LEVEL);
  59 $DIE_LEVEL = 0;
  60
  61 sub repl_xreturn
  62 {
  63     ($DB::DIE_TO, $DB::DIE_RETURN[0]) = split ' ', $_[0], 2;
  64     $DB::DIE_RETURN[0] = $Sepia::REPL{eval}->($DB::DIE_RETURN[0]);
  65     last SEPIA_DB_SUB;
  66 }
  67
  68 # { package DB;
  69 #  no strict;
  70 sub sub
  71 {
  72     no strict;
  73     local $DIE_LEVEL = $DIE_LEVEL + 1;
  74     ## Set up a dynamic catch target
  75  SEPIA_DB_SUB: {
  76         return &$DB::sub;
  77     };
  78     # we're dying!
  79     last SEPIA_DB_SUB
  80         if $DIE_LEVEL > 1 && defined $DIE_TO
  81             && $DB::sub !~ /(?:^|::)\Q$DIE_TO\E$/;
  82     undef $DIE_TO;
  83     wantarray ? @DIE_RETURN : $DIE_RETURN[0]
  84 }
  85 # }
  86
  87 sub repl_dbsub
  88 {
  89     my $arg = shift;
  90     if ($arg) {
  91         *DB::sub = \&sub;
  92     } else {
  93         undef &DB::sub;
  94     }
  95 }
  96
  97 sub repl_lsbreak
  98 {
  99     no strict 'refs';
 100     for my $file (sort grep /^_</ && defined %{"::$_"}, keys %::) {
 101         my ($name) = $file =~ /^_<(.*)/;
 102         my @pts = keys %{"::$file"};
 103         next unless @pts;
 104         print "$name:\n";
 105         for (sort { $a <=> $b } @pts) {
 106             print "\t$_\t${$file}{$_}\n"
 107         }
 108     }
 109 }
 110
 111 # evaluate EXPR in environment ENV
 112 sub eval_in_env
 113 {
 114     my ($expr, $env) = @_;
 115     local $Sepia::ENV = $env;
 116     my $str = '';
 117     for (keys %$env) {
 118         next unless /^([\$\@%])(.+)/;
 119         $str .= "local *$2 = \$Sepia::ENV->{'$_'}; ";
 120     }
 121     eval "do { no strict; package $Sepia::PACKAGE; $str $expr }";
 122 }
 123
 124 sub tie_class
 125 {
 126     my $sig = substr shift, 0, 1;
 127     return $sig eq '$' ? 'Tie::StdScalar'
 128         : $sig eq '@' ? 'Tie::StdArray'
 129             : $sig eq '%' ? 'Tie::StdHash'
 130                 : die "Sorry, can't tie $sig\n";
 131 }
 132
 133 ## XXX: this is a better approach (the local/tie business is vile),
 134 ## but it segfaults and I'm not sure why.
 135 sub eval_in_env2
 136 {
 137     my ($expr, $env, $fn) = @_;
 138     local $Sepia::ENV = $env;
 139     my @vars = grep /^([\$\@%])(.+)/, keys %$env;
 140     my $body = 'sub { my ('.join(',', @vars).');';
 141     for (@vars) {
 142         $body .= "Devel::LexAlias::lexalias(\$Sepia::ENV, '$_', \\$_);"
 143     }
 144     $body .= "$expr }";
 145     print STDERR "---\n$body\n---\n";
 146     $body = eval $body;
 147     $@ || $body->();
 148 }
 149
 150 # evaluate EXP LEV levels up the stack
 151 sub repl_upeval
 152 {
 153     eval_in_env(shift, peek_my(4+$level));
 154 }
 155
 156 # inspect lexicals at level N, or current level
 157 sub repl_inspect
 158 {
 159     my $i = shift;
 160     if ($i =~ /\d/) {
 161         $i = 0+$i;
 162     } else {
 163         $i = $level + 3;
 164     }
 165     my $sub = (caller $i)[3];
 166     if ($sub) {
 167         my $h = peek_my($i+1);
 168         print "[$i] $sub:\n";
 169         for (sort keys %$h) {
 170             local @Sepia::res = $h->{$_};
 171             print "\t$_ = ", $Sepia::PRINTER{$Sepia::PRINTER}->(), "\n";
 172         }
 173     }
 174 }
 175
 176 sub debug
 177 {
 178     my $new = Sepia::as_boolean(shift, $DB::trace);
 179     print "debug ", $new ? "ON" : "OFF";
 180     if ($new == $DB::trace) {
 181         print " (unchanged)\n"
 182     } else {
 183         print "\n";
 184     }
 185     $DB::trace = $new;
 186 }
 187
 188 sub breakpoint_file
 189 {
 190     my ($file) = @_;
 191     return \%{$main::{"_<$file"}} if exists $main::{"_<$file"};
 192     if ($file !~ /^\//) {
 193         ($file) = grep /^_<.*\/\Q$file\E$/, keys %main::;
 194         return \%{$main::{$file}} if $file;
 195     }
 196     return undef;
 197 }
 198
 199 sub breakpoint
 200 {
 201     my ($file, $line, $cond) = @_;
 202     my $h = breakpoint_file $file;
 203     if (defined $h) {
 204         $h->{$line} = $cond || 1;
 205         return $cond ? "$file\:$line if $cond" : "$file\:$line";
 206     }
 207     return undef;
 208 }
 209
 210 sub repl_break
 211 {
 212     my $arg = shift;
 213     $arg =~ s/^\s+//;
 214     $arg =~ s/\s+$//;
 215     my ($f, $l, $cond) = $arg =~ /^(.+?):(\d+)\s*(.*)/;
 216     $cond = 1 unless $cond =~ /\S/;
 217     $f ||= $file;
 218     $l ||= $line;
 219     return unless defined $f && defined $l;
 220     my $bp = breakpoint($f, $l, $cond);
 221     print "break $bp\n" if $bp;
 222 }
 223
 224 sub update_location
 225 {
 226     # XXX: magic numberage.
 227     ($pack, $file, $line, $sub) = caller($level + shift);
 228 }
 229
 230 sub show_location
 231 {
 232     print "_<$file:$line>\n" if defined $file && defined $line;
 233 }
 234
 235 sub repl_list
 236 {
 237     my @lines = eval shift;
 238     @lines = $line - 5 .. $line + 5 unless @lines;
 239     printf '%-6d%s', $_, ${"::_<$file"}[$_-1] for @lines;
 240 }
 241
 242 sub repl_delete
 243 {
 244     my ($f, $l) = split /:/, shift;
 245     $f ||= $file;
 246     $l ||= $line;
 247     my $h = breakpoint_file $f;
 248     delete $h->{$l} if defined $h;
 249 }
 250
 251 my ($finish_file, $finish_line);
 252
 253 sub repl_finish
 254 {
 255     print STDERR "finish: ($file, $line)\n";
 256     $finish_file = $file;
 257     $finish_line = $line;
 258     $DB::single = 1;
 259     last repl;
 260 }
 261
 262 sub repl_toplevel
 263 {
 264     local $STOPDIE;
 265     die(bless [], __PACKAGE__);
 266 }
 267
 268 sub add_repl_commands
 269 {
 270     define_shortcut 'delete', \&repl_delete,
 271         'Delete current breakpoint.';
 272     define_shortcut 'debug', \&repl_debug,
 273         'debug [0|1]', 'Enable or disable debugging.';
 274     define_shortcut 'break', \&repl_break,
 275         'break [F:N [E]]',
 276         'Break at file F, line N (or at current position) if E is true.';
 277     define_shortcut 'lsbreak', \&repl_lsbreak,
 278         'List breakpoints.';
 279     # define_shortcut 'dbsub', \&repl_dbsub, '(Un)install DB::sub.';
 280     %Sepia::RK = abbrev keys %Sepia::REPL;
 281 }
 282
 283 sub add_debug_repl_commands
 284 {
 285     define_shortcut quit => \&repl_toplevel,
 286         'quit', 'Quit the debugger, returning to the top level.';
 287     define_shortcut toplevel => \&repl_toplevel,
 288         'toplevel', 'Return to the top level.';
 289     define_shortcut up => sub {
 290         $level += shift || 1;
 291         update_location(4);
 292         show_location;
 293     }, 'up [N]', 'Move up N stack frames.';
 294     define_shortcut down => sub {
 295         $level -= shift || 1;
 296         $level = 0 if $level < 0;
 297         update_location(4);
 298         show_location;
 299     }, 'down [N]', 'Move down N stack frames.';
 300     define_shortcut continue => sub {
 301         $level = 0;
 302         $DB::single = 0;
 303         last repl;
 304     }, 'Yep.';
 305
 306     define_shortcut next => sub {
 307         my $n = shift || 1;
 308         $DB::single = 0;
 309         breakpoint $file, $line + $n, 'next';
 310         last repl;
 311     }, 'next [N]', 'Advance N lines, skipping subroutines.';
 312
 313     define_shortcut step => sub {
 314         $DB::single = shift || 1;
 315         last repl;
 316     }, 'step [N]', 'Step N lines forward, entering subroutines.';
 317
 318     # define_shortcut finish => \&repl_finish,
 319     #     'finish', 'Finish the current subroutine.';
 320
 321     define_shortcut list => \&repl_list,
 322         'list EXPR', 'List source lines of current file.';
 323     define_shortcut backtrace => \&repl_backtrace, 'show backtrace';
 324     define_shortcut inspect => \&repl_inspect,
 325         'inspect [N]', 'inspect lexicals in frame N (or current)';
 326     define_shortcut return => \&repl_return, 'return EXPR', 'return EXPR';
 327     # define_shortcut xreturn => \&repl_xreturn, 'xreturn NAME EXPR',
 328     #     'xreturn NAME EXPR';
 329     define_shortcut eval => \&repl_upeval,
 330         'eval EXPR', 'evaluate EXPR in current frame';      # DANGER!
 331 }
 332
 333 sub repl
 334 {
 335     show_location;
 336     local %Sepia::REPL = %Sepia::REPL;
 337     local %Sepia::REPL_DOC = %Sepia::REPL_DOC;
 338     add_debug_repl_commands;
 339     map { define_shortcut @$_ } @_;
 340     local %Sepia::RK = abbrev keys %Sepia::REPL;
 341     # local $Sepia::REPL_LEVEL = $Sepia::REPL_LEVEL + 1;
 342     local $Sepia::PS1 = "*$Sepia::REPL_LEVEL*> ";
 343     Sepia::repl();
 344 }
 345
 346 sub DB::DB
 347 {
 348     return if $Sepia::ISEVAL;
 349     local $level = 0;
 350     local ($pack, $file, $line, $sub) = caller($level);
 351     ## Don't do anything if we're inside an eval request, even if in
 352     ## single-step mode.
 353     return unless $DB::single || exists $main::{"_<$file"}{$line};
 354     if (defined $finish_file) {
 355         print STDERR "finish = $finish_file:$finish_line\n",
 356             "cur = $file:$line\n";
 357         if ($file eq $finish_file
 358                 && abs($line - $finish_line) < 3) {
 359             $finish_line = $line;
 360         } else {
 361             undef $finish_line;
 362             undef $finish_file;
 363             $DB::single = 0;
 364             return;
 365         }
 366     } elsif ($DB::single) {
 367         return unless --$DB::single == 0;
 368     } else {
 369         my $cond = $main::{"_<$file"}{$line};
 370         if ($cond eq 'next') {
 371             delete $main::{"_<$file"}{$line};
 372         } else {
 373             return unless $Sepia::REPL{eval}->($cond);
 374         }
 375     }
 376     repl();
 377 }
 378
 379 my $MSG = "('\\C-c' to exit, ',h' for help)";
 380
 381 sub die
 382 {
 383     ## Protect us against people doing weird things.
 384     if ($STOPDIE && !$SIG{__DIE__}) {
 385         my @dieargs = @_;
 386         local $level = 0;
 387         local ($pack, $file, $line, $sub) = caller($level);
 388         my $tmp = "@_";
 389         $tmp .= "\n" unless $tmp =~ /\n\z/;
 390         print "$tmp\tin $sub\nDied $MSG\n";
 391         my $trace = $DB::trace;
 392         $DB::trace = 1;
 393         repl(
 394             [die => sub { local $STOPDIE=0; CORE::die @dieargs },
 395              'Continue dying.'],
 396             [quit => sub { local $STOPDIE=0; CORE::die @dieargs },
 397              'Continue dying.']);
 398         $DB::trace = $trace;
 399     } else {
 400         CORE::die(Carp::shortmess @_);
 401     }
 402     1;
 403 }
 404
 405 sub warn
 406 {
 407     ## Again, this is above our pay grade:
 408     if ($STOPWARN && $SIG{__WARN__} eq 'Sepia::sig_warn') {
 409         my @dieargs = @_;
 410         my $trace = $DB::trace;
 411         $DB::trace = 1;
 412         local $level = 0;
 413         local ($pack, $file, $line, $sub) = caller($level);
 414         print "@_\n\tin $sub\nWarned $MSG\n";
 415         repl(
 416             [warn => sub { local $STOPWARN=0; CORE::warn @dieargs },
 417              'Continue warning.'],
 418             [quit => sub { local $STOPWARN=0; CORE::warn @dieargs },
 419              'Continue warning.']);
 420         $DB::trace = $trace;
 421     } else {
 422         ## Avoid showing up in location information.
 423         CORE::warn(Carp::shortmess @_);
 424     }
 425 }
 426
 427 sub oops
 428 {
 429     my $sig = shift;
 430     if ($STOPDIE) {
 431         my $trace = $DB::trace;
 432         $DB::trace = 1;
 433         local $level = 0;
 434         local ($pack, $file, $line, $sub) = caller($level);
 435         print "@_\n\tin $sub\nCaught signal $sig\n";
 436         repl(
 437         [die => sub { local $STOPDIE=0; CORE::die "Caught signal $sig; exiting." },
 438          'Just die.'],
 439         [quit => sub { local $STOPWARN=0; CORE::die "Caught signal $sig; exiting." },
 440          'Just die.']);
 441         $DB::trace = $trace;
 442     } else {
 443         Carp::confess "Caught signal $sig: continue at your own risk.";
 444     }
 445 }
 446
 447 1;