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