3 use Carp
(); # old Carp doesn't export shortmess.
5 # uncomment for development
7 # use vars qw($pack $file $line $sub $level
9 # $DIE_TO @DIE_RETURN $DIE_LEVEL);
11 *define_shortcut
= *Sepia
::define_shortcut
;
14 ## Just leave it on -- with $DB::trace = 0, there doesn't seem
15 ## to be a performance penalty!
17 ## Flags we use are (see PERLDBf_* in perl.h):
18 ## 0x1 Debugging sub enter/exit (call DB::sub if defined)
19 ## 0x2 per-line debugging (keep line numbers)
20 ## 0x8 "preserve more data" (call DB::postponed??)
21 ## 0x10 keep line ranges for sub definitions in %DB::sub
22 ## 0x100 give evals informative names
23 ## 0x200 give anon subs informative names
24 ## 0x400 save source lines in %{"_<$filename"}
25 $^P
= 0x01 | 0x02 | 0x10 | 0x100 | 0x200;
32 eval q{ require PadWalker };
36 *peek_my
= \
&PadWalker
::peek_my
;
49 for (my $i = 0; ; ++$i) {
50 my ($pack, $file, $line, $sub) = caller($i);
52 $Sepia::SIGGED
&& do { $Sepia::SIGGED
--; last };
53 # XXX: 4 is the magic number...
54 print($i == $level+4 ?
"*" : ' ', " [$i]\t$sub ($file:$line)\n");
58 # return value from die
61 if ($Sepia::WANTARRAY
) {
62 @Sepia::REPL_RESULT
= $Sepia::REPL
{eval}->(@_);
64 $Sepia::REPL_RESULT
[0] = $Sepia::REPL
{eval}->(@_);
73 eval q{ use Scope::Upper ':all' };
75 print "xreturn requires Sub::Uplevel.\n";
78 *xreturn
= eval <<'EOS';
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;
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]);
108 local $DIE_LEVEL = $DIE_LEVEL + 1;
109 ## Set up a dynamic catch target
115 if $DIE_LEVEL > 1 && defined $DIE_TO
116 && $DB::sub !~ /(?:^|::)\Q$DIE_TO\E$/;
118 wantarray ?
@DIE_RETURN : $DIE_RETURN[0]
135 for my $file (sort grep /^_</ && *{"::$_"}{HASH
}, keys %::) {
136 $Sepia::SIGGED
&& do { $Sepia::SIGGED
--; last };
137 my ($name) = $file =~ /^_<(.*)/;
138 my @pts = keys %{"::$file"};
141 for (sort { $a <=> $b } @pts) {
142 print "\t$_\t${$file}{$_}\n"
147 # evaluate EXPR in environment ENV
150 my ($expr, $env) = @_;
151 local $Sepia::ENV
= $env;
154 next unless /^([\$\@%])(.+)/;
155 $str .= "local *$2 = \$Sepia::ENV->{'$_'}; ";
157 $str = "do { no strict; package $Sepia::PACKAGE; $str $expr }";
158 return $Sepia::WANTARRAY ?
eval $str : scalar eval $str;
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";
171 ## XXX: this is a better approach (the local/tie business is vile),
172 ## but it segfaults and I'm not sure why.
175 my ($expr, $env, $fn) = @_;
176 local $Sepia::ENV
= $env;
177 my @vars = grep /^([\$\@%])(.+)/, keys %$env;
178 my $body = 'sub { my ('.join(',', @vars).');';
180 $body .= "Devel::LexAlias::lexalias(\$Sepia::ENV, '$_', \\$_);"
183 print STDERR
"---\n$body\n---\n";
188 # evaluate EXP LEV levels up the stack
190 # NOTE: We need to act like &repl_eval here and consider e.g. $WANTARRAY
193 # if ($Sepia::WANTARRAY) {
194 return eval_in_env
(shift, peek_my
(4+$level));
196 # return scalar eval_in_env(shift, peek_my(4+$level));
200 # inspect lexicals at level N, or current level
209 my $sub = (caller $i)[3];
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";
222 my $new = Sepia
::as_boolean
(shift, $DB::trace
);
223 print "debug ", $new ?
"ON" : "OFF";
224 if ($new == $DB::trace
) {
225 print " (unchanged)\n"
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;
245 my ($file, $line, $cond) = @_;
246 my $h = breakpoint_file
$file;
248 $h->{$line} = $cond || 1;
249 return $cond ?
"$file\:$line if $cond" : "$file\:$line";
259 my ($f, $l, $cond) = $arg =~ /^(.+?):(\d+)\s*(.*)/;
260 $cond = 1 unless $cond =~ /\S/;
263 return unless defined $f && defined $l;
264 my $bp = breakpoint
($f, $l, $cond);
265 print "break $bp\n" if $bp;
270 # XXX: magic numberage.
271 ($pack, $file, $line, $sub) = caller($level + shift);
276 print "_<$file:$line>\n" if defined $file && defined $line;
281 my @lines = eval shift;
282 @lines = $line - 5 .. $line + 5 unless @lines;
283 printf '%-6d%s', $_, ${"::_<$file"}[$_-1] for @lines;
288 my ($f, $l) = split /:/, shift;
291 my $h = breakpoint_file
$f;
292 delete $h->{$l} if defined $h;
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');
307 print STDERR
"yikes: @{[keys %DB::sub]}\n";
314 die(bless [], __PACKAGE__
);
317 sub add_repl_commands
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
,
325 'Break at file F, line N (or at current position) if E is true.';
326 define_shortcut
'lsbreak', \
&repl_lsbreak
,
328 # define_shortcut 'dbsub', \&repl_dbsub, '(Un)install DB::sub.';
329 %Sepia::RK
= abbrev
keys %Sepia::REPL
;
332 sub add_debug_repl_commands
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;
342 }, 'up [N]', 'Move up N stack frames.';
343 define_shortcut down
=> sub {
344 $level -= shift || 1;
345 $level = 0 if $level < 0;
348 }, 'down [N]', 'Move down N stack frames.';
349 define_shortcut
continue => sub {
355 define_shortcut
next => sub {
358 breakpoint
$file, $line + $n, 'next';
360 }, 'next [N]', 'Advance N lines, skipping subroutines.';
362 define_shortcut step
=> sub {
363 $DB::single
= shift || 1;
365 }, 'step [N]', 'Step N statements forward, entering subroutines.';
367 define_shortcut finish
=> \
&repl_finish
,
368 'finish', 'Finish the current subroutine.';
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!
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*> ";
397 return if $Sepia::ISEVAL
;
399 local ($pack, $file, $line, $sub) = caller($level);
400 ## Don't do anything if we're inside an eval request, even if in
402 return unless $DB::single
|| exists $main::{"_<$file"}{$line};
404 return unless --$DB::single
== 0;
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};
415 return unless $Sepia::REPL
{eval}->($cond);
421 my $MSG = "('\\C-c' to exit, ',h' for help)";
425 ## Protect us against people doing weird things.
426 if ($STOPDIE && !$SIG{__DIE__
}) {
429 local ($pack, $file, $line, $sub) = caller($level);
431 $tmp .= "\n" unless $tmp =~ /\n\z/;
432 print "$tmp\tin $sub\nDied $MSG\n";
433 my $trace = $DB::trace
;
436 [die => sub { local $STOPDIE=0; CORE
::die @dieargs },
438 [quit
=> sub { local $STOPDIE=0; CORE
::die @dieargs },
442 CORE
::die(Carp
::shortmess
@_);
449 ## Again, this is above our pay grade:
450 if ($STOPWARN && $SIG{__WARN__
} eq 'Sepia::sig_warn') {
452 my $trace = $DB::trace
;
455 local ($pack, $file, $line, $sub) = caller($level);
456 print "@_\n\tin $sub\nWarned $MSG\n";
458 [warn => sub { local $STOPWARN=0; CORE
::warn @dieargs },
459 'Continue warning.'],
460 [quit
=> sub { local $STOPWARN=0; CORE
::warn @dieargs },
461 'Continue warning.']);
464 ## Avoid showing up in location information.
465 CORE
::warn(Carp
::shortmess
@_);
473 my $trace = $DB::trace
;
476 local ($pack, $file, $line, $sub) = caller($level);
477 print "@_\n\tin $sub\nCaught signal $sig\n";
479 [die => sub { local $STOPDIE=0; CORE
::die "Caught signal $sig; exiting." },
481 [quit
=> sub { local $STOPWARN=0; CORE
::die "Caught signal $sig; exiting." },
485 Carp
::confess
"Caught signal $sig: continue at your own risk.";