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