package DB;
+use IO::Handle;
+
# Debugger for Perl 5.00x; perl5db.pl patch level:
-$VERSION = 1.19;
+$VERSION = 1.20;
$header = "perl5db.pl version $VERSION";
# It is crucial that there is no lexicals in scope of `eval ""' down below
# true if $deep is not defined.
#
# $Log: perldb.pl,v $
-
#
# At start reads $rcfile that may set important options. This file
# may define a subroutine &afterinit that will be executed after the
# + fixed missing cmd_O bug
# Changes: 1.19: Mar 29, 2002 Spider Boardman
# + Added missing local()s -- DB::DB is called recursively.
+# Changes: 1.20: Feb 17, 2003 Richard Foley <richard.foley@rfi.net>
+# + pre'n'post commands no longer trashed with no args
+# + watch val joined out of eval()
#
####################################################################
# test if assertions are supported and actived:
BEGIN {
$ini_assertion=
- eval "sub asserting_test : assertion {1}; asserting_test()";
+ eval "sub asserting_test : assertion {1}; 1";
# $ini_assertion = undef => assertions unsupported,
- # " = 0 => assertions supported but inactive
- # " = 1 => assertions suported and active
+ # " = 1 => assertions suported
# print "\$ini_assertion=$ini_assertion\n";
}
-INIT { # We use also INIT {} because test doesn't work in BEGIN {} if
- # '-A' flag is in the perl script source file after the shebang
- # as in '#!/usr/bin/perl -A'
- $ini_assertion=
- eval "sub asserting_test1 : assertion {1}; asserting_test1()";
-}
local($^W) = 0; # Switch run-time warnings off during init.
warn ( # Do not ;-)
for (my $n = 0; $n <= $#to_watch; $n++) {
$evalarg = $to_watch[$n];
local $onetimeDump; # Do not output results
- my ($val) = &eval; # Fix context (&eval is doing array)?
+ my ($val) = join("', '", &eval); # Fix context (&eval is doing array)? - rjsf
$val = ( (defined $val) ? "'$val'" : 'undef' );
if ($val ne $old_watch[$n]) {
$signal = 1;
$start = 1 if $start <= 0;
$incr = $window - 1;
$cmd = 'l ' . ($start) . '+'; };
- # rjsf ->
- $cmd =~ /^([aAbBhlLMoOvwWP])\b\s*(.*)/s && do {
+ # rjsf ->
+ $cmd =~ /^([aAbBhlLMoOPvwW]\b|[<>\{]{1,2})\s*(.*)/so && do {
&cmd_wrapper($1, $2, $line);
next CMD;
};
- # <- rjsf
- $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
- push @$pre, action($1);
- next CMD; };
- $cmd =~ /^>>\s*(.*)/ && do {
- push @$post, action($1);
- next CMD; };
- $cmd =~ /^<\s*(.*)/ && do {
- unless ($1) {
- print $OUT "All < actions cleared.\n";
- $pre = [];
- next CMD;
- }
- if ($1 eq '?') {
- unless (@$pre) {
- print $OUT "No pre-prompt Perl actions.\n";
- next CMD;
- }
- print $OUT "Perl commands run before each prompt:\n";
- for my $action ( @$pre ) {
- print $OUT "\t< -- $action\n";
- }
- next CMD;
- }
- $pre = [action($1)];
- next CMD; };
- $cmd =~ /^>\s*(.*)/ && do {
- unless ($1) {
- print $OUT "All > actions cleared.\n";
- $post = [];
- next CMD;
- }
- if ($1 eq '?') {
- unless (@$post) {
- print $OUT "No post-prompt Perl actions.\n";
- next CMD;
- }
- print $OUT "Perl commands run after each prompt:\n";
- for my $action ( @$post ) {
- print $OUT "\t> -- $action\n";
- }
- next CMD;
- }
- $post = [action($1)];
- next CMD; };
- $cmd =~ /^\{\{\s*(.*)/ && do {
- if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) {
- print $OUT "{{ is now a debugger command\n",
- "use `;{{' if you mean Perl code\n";
- $cmd = "h {{";
- redo CMD;
- }
- push @$pretype, $1;
- next CMD; };
- $cmd =~ /^\{\s*(.*)/ && do {
- unless ($1) {
- print $OUT "All { actions cleared.\n";
- $pretype = [];
- next CMD;
- }
- if ($1 eq '?') {
- unless (@$pretype) {
- print $OUT "No pre-prompt debugger actions.\n";
- next CMD;
- }
- print $OUT "Debugger commands run before each prompt:\n";
- for my $action ( @$pretype ) {
- print $OUT "\t{ -- $action\n";
- }
- next CMD;
- }
- if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) {
- print $OUT "{ is now a debugger command\n",
- "use `;{' if you mean Perl code\n";
- $cmd = "h {";
- redo CMD;
- }
- $pretype = [$1];
- next CMD; };
+ # rjsf <- pre|post commands stripped out
$cmd =~ /^y(?:\s+(\d*)\s*(.*))?$/ && do {
eval { require PadWalker; PadWalker->VERSION(0.08) }
or &warn($@ =~ /locate/
print $OUT "Warning: some settings and command-line options may be lost!\n";
my (@script, @flags, $cl);
push @flags, '-w' if $ini_warn;
- push @flags, '-A' if $ini_assertion;
+ if ($ini_assertion and @{^ASSERTING}) {
+ push @flags, (map { /\:\^\(\?\:(.*)\)\$\)/ ?
+ "-A$1" : "-A$_" } @{^ASSERTING});
+ }
# Put all the old includes at the start to get
# the same debugger.
for (@ini_INC) {
$cmd =~ /^T$/ && do {
print_trace($OUT, 1); # skip DB
next CMD; };
- $cmd =~ /^w\b\s*(.*)/s && do { &cmd_w($1); next CMD; };
- $cmd =~ /^W\b\s*(.*)/s && do { &cmd_W($1); next CMD; };
+ $cmd =~ /^w\b\s*(.*)/s && do { &cmd_w('w', $1); next CMD; };
+ $cmd =~ /^W\b\s*(.*)/s && do { &cmd_W('W', $1); next CMD; };
$cmd =~ /^\/(.*)$/ && do {
$inpat = $1;
$inpat =~ s:([^\\])/$:$1:;
$onetimeDump = undef;
$onetimedumpDepth = undef;
} elsif ($term_pid == $$) {
+ STDOUT->flush();
+ STDERR->flush();
print $OUT "\n";
}
} continue { # CMD:
### returns FALSE on error.
### User-interface functions cmd_* output error message.
-### Note all cmd_[a-zA-Z]'s require $line, $dblineno as first arguments
+### Note all cmd_[a-zA-Z]'s require $cmd, $line, $dblineno as first arguments
my %set = ( #
'pre580' => {
'w' => 'v',
'W' => 'pre580_W',
},
+ 'pre590' => {
+ '<' => 'pre590_prepost',
+ '<<' => 'pre590_prepost',
+ '>' => 'pre590_prepost',
+ '>>' => 'pre590_prepost',
+ '{' => 'pre590_prepost',
+ '{{' => 'pre590_prepost',
+ },
);
sub cmd_wrapper {
# to old (pre580) or other command sets easily
#
my $call = 'cmd_'.(
- $set{$CommandSet}{$cmd} || $cmd
+ $set{$CommandSet}{$cmd} || ($cmd =~ /^[<>{]+/o ? 'prepost' : $cmd)
);
# print "cmd_wrapper($cmd): $CommandSet($set{$CommandSet}{$cmd}) => call($call)\n";
- return &$call($line, $dblineno);
+ return &$call($cmd, $line, $dblineno);
}
sub cmd_a {
+ my $cmd = shift; # a
my $line = shift || ''; # [.|line] expr
my $dbline = shift; $line =~ s/^(\.|(?:[^\d]))/$dbline/;
if ($line =~ /^\s*(\d*)\s*(\S.+)/) {
}
sub cmd_A {
+ my $cmd = shift; # A
my $line = shift || '';
my $dbline = shift; $line =~ s/^\./$dbline/;
if ($line eq '*') {
}
sub cmd_b {
+ my $cmd = shift; # b
my $line = shift; # [.|line] [cond]
my $dbline = shift; $line =~ s/^\./$dbline/;
if ($line =~ /^\s*$/) {
}
sub cmd_B {
+ my $cmd = shift; # B
my $line = ($_[0] =~ /^\./) ? $dbline : shift || '';
my $dbline = shift; $line =~ s/^\./$dbline/;
if ($line eq '*') {
}
sub cmd_h {
+ my $cmd = shift; # h
my $line = shift || '';
if ($line =~ /^h\s*/) {
print_help($help);
sub cmd_l {
my $current_line = $line;
+ my $cmd = shift; # l
my $line = shift;
$line =~ s/^-\s*$/-/;
if ($line =~ /^(\$.*)/s) {
$s = CvGV_name($s);
print($OUT "Interpreted as: $1 $s\n");
$line = "$1 $s";
- &cmd_l($s);
+ &cmd_l('l', $s);
} elsif ($line =~ /^([\':A-Za-z_][\':\w]*(\[.*\])?)/s) {
my $s = $subname = $1;
$subname =~ s/\'/::/;
$subrange =~ s/-.*/+/;
}
$line = $subrange;
- &cmd_l($subrange);
+ &cmd_l('l', $subrange);
} else {
print $OUT "Subroutine $subname not found.\n";
}
} elsif ($line =~ /^\s*$/) {
$incr = $window - 1;
$line = $start . '-' . ($start + $incr);
- &cmd_l($line);
+ &cmd_l('l', $line);
} elsif ($line =~ /^(\d*)\+(\d*)$/) {
$start = $1 if $1;
$incr = $2;
$incr = $window - 1 unless $incr;
$line = $start . '-' . ($start + $incr);
- &cmd_l($line);
+ &cmd_l('l', $line);
} elsif ($line =~ /^((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/) {
$end = (!defined $2) ? $max : ($4 ? $4 : $2);
$end = $max if $end > $max;
}
sub cmd_L {
+ my $cmd = shift; # L
my $arg = shift || 'abw'; $arg = 'abw' unless $CommandSet eq '580'; # sigh...
my $action_wanted = ($arg =~ /a/) ? 1 : 0;
my $break_wanted = ($arg =~ /b/) ? 1 : 0;
}
sub cmd_o {
+ my $cmd = shift; # o
my $opt = shift || ''; # opt[=val]
if ($opt =~ /^(\S.*)/) {
&parse_options($1);
}
sub cmd_v {
+ my $cmd = shift; # v
my $line = shift;
if ($line =~ /^(\d*)$/) {
$start = $1 if $1;
$start -= $preview;
$line = $start . '-' . ($start + $incr);
- &cmd_l($line);
+ &cmd_l('l', $line);
}
}
sub cmd_w {
+ my $cmd = shift; # w
my $expr = shift || '';
if ($expr =~ /^(\S.*)/) {
push @to_watch, $expr;
$evalarg = $expr;
- my ($val) = &eval;
+ my ($val) = join(' ', &eval);
$val = (defined $val) ? "'$val'" : 'undef' ;
push @old_watch, $val;
$trace |= 2;
}
sub cmd_W {
+ my $cmd = shift; # W
my $expr = shift || '';
if ($expr eq '*') {
$trace &= ~2;
&warn("Too late to set up OnlyAssertions mode, enabled on next 'R'!\n") if @_;
}
if (@_) {
- unless (defined $ini_assertion) {
- if ($term) {
- &warn("Current Perl interpreter doesn't support assertions");
+ unless (defined $ini_assertion) {
+ if ($term) {
+ &warn("Current Perl interpreter doesn't support assertions");
+ }
+ return 0;
}
- return 0;
- }
- if (shift) {
- unless ($ini_assertion) {
- print "Assertions will also be actived on next 'R'!\n";
- $ini_assertion=1;
+ if (shift) {
+ unless ($ini_assertion) {
+ print "Assertions will be active on next 'R'!\n";
+ $ini_assertion=1;
+ }
+ $^P&= ~$DollarCaretP_flags{PERLDBf_SUB};
+ $^P|=$DollarCaretP_flags{PERLDBf_ASSERTION};
+ }
+ else {
+ $^P|=$DollarCaretP_flags{PERLDBf_SUB};
}
- $^P&= ~$DollarCaretP_flags{PERLDBf_SUB};
- $^P|=$DollarCaretP_flags{PERLDBf_ASSERTION};
- }
- else {
- $^P|=$DollarCaretP_flags{PERLDBf_SUB};
- }
}
!($^P & $DollarCaretP_flags{PERLDBf_SUB}) || 0;
}
on the first element of the result.
B<m> I<class> Prints methods callable via the given class.
B<M> Show versions of loaded modules.
+B<y> [I<n> [I<vars>]] List lexical variables I<n> levels up from current sub
B<<> ? List Perl commands to run before each prompt.
B<<> I<expr> Define Perl command to run before each prompt.
B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
+B<< *> Delete the list of perl commands to run before each prompt.
B<>> ? List Perl commands to run after each prompt.
B<>> I<expr> Define Perl command to run after each prompt.
B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
+B<>>B< *> Delete the list of Perl commands to run after each prompt.
B<{> I<db_command> Define debugger command to run before each prompt.
B<{> ? List debugger commands to run before each prompt.
B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
+B<{ *> Delete the list of debugger commands to run before each prompt.
B<$prc> I<number> Redo a previous command (default previous command).
B<$prc> I<-number> Redo number'th-to-last command.
B<$prc> I<pattern> Redo last command that started with I<pattern>.
}
sub cmd_pre580_a {
+ my $xcmd = shift; #
my $cmd = shift;
if ($cmd =~ /^(\d*)\s*(.*)/) {
$i = $1 || $line; $j = $2;
}
sub cmd_pre580_b {
+ my $xcmd = shift; #
my $cmd = shift;
my $dbline = shift;
if ($cmd =~ /^load\b\s*(.*)/) {
}
sub cmd_pre580_D {
+ my $xcmd = shift; #
my $cmd = shift;
if ($cmd =~ /^\s*$/) {
print $OUT "Deleting all breakpoints...\n";
}
sub cmd_pre580_h {
+ my $xcmd = shift; #
my $cmd = shift;
if ($cmd =~ /^\s*$/) {
print_help($pre580_help);
}
sub cmd_pre580_W {
+ my $xcmd = shift; #
my $cmd = shift;
if ($cmd =~ /^$/) {
$trace &= ~2;
}
}
+sub cmd_pre590_prepost {
+ my $cmd = shift;
+ my $line = shift || '*'; # delete
+ my $dbline = shift;
+
+ return &cmd_prepost($cmd, $line, $dbline);
+}
+
+sub cmd_prepost { # cannot do &cmd_<(), <, <<, >>, {, {{, etc.
+ my $cmd = shift;
+ my $line = shift || '?';
+
+ my $which = '';
+ my $aref = [];
+ if ($cmd =~ /^\</o) {
+ $which = 'pre-perl';
+ $aref = $pre;
+ } elsif ($cmd =~ /^\>/o) {
+ $which = 'post-perl';
+ $aref = $post;
+ } elsif ($cmd =~ /^\{/o) {
+ if ($cmd =~ /^\{.*\}$/o && unbalanced(substr($cmd,1))) {
+ print $OUT "$cmd is now a debugger command\nuse `;$cmd' if you mean Perl code\n";
+ # $DB::cmd = "h $cmd";
+ # redo CMD;
+ } else {
+ $which = 'pre-debugger';
+ $aref = $pretype;
+ }
+ }
+
+ unless ($which) {
+ print $OUT "Confused by command: $cmd\n";
+ } else {
+ if ($line =~ /^\s*\?\s*$/o) {
+ unless (@$aref) {
+ print $OUT "No $which actions.\n";
+# print $OUT "If you meant to delete them all - use '$cmd *' or 'o commandSet=pre590'\n"; # hint
+ } else {
+ print $OUT "$which commands:\n";
+ foreach my $action (@$aref) {
+ print $OUT "\t$cmd -- $action\n";
+ }
+ }
+ } else {
+ if (length($cmd) == 1) {
+ if ($line =~ /^\s*\*\s*$/o) {
+ @$aref = (); # delete
+ print $OUT "All $cmd actions cleared.\n";
+ } else {
+ @$aref = action($line); # set
+ }
+ } elsif (length($cmd) == 2) { # append
+ push @$aref, action($line);
+ } else {
+ print $OUT "Confused by strange length of $which command($cmd)...\n";
+ }
+ }
+ }
+}
+
package DB::fake;
sub at_exit {
package DB; # Do not trace this 1; below!
1;
-
projects / p5sagit/p5-mst-13.2.git / blobdiff