X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fperl5db.pl;h=7c8507c066c02bc552b2a89281807a277ecbc8a4;hb=0ea4badca0069846e0da75feed0fdb587e8fc275;hp=158510dfebf9bae84a3bc2201ffbce22257c14e0;hpb=3a4b996c622ca8a2cd8d468317fb869865ee25b2;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 158510d..7c8507c 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -1,7 +1,7 @@ package DB; # Debugger for Perl 5.00x; perl5db.pl patch level: -$VERSION = 1.17; +$VERSION = 1.20; $header = "perl5db.pl version $VERSION"; # It is crucial that there is no lexicals in scope of `eval ""' down below @@ -79,7 +79,6 @@ sub eval { # 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 @@ -316,12 +315,29 @@ sub eval { # + m(methods), M(modules) # ... (was m,v) # + o(option) # lc (was O) # + v(view code), V(view Variables) # ... (was w,V) +# Changes: 1.18: Mar 17, 2002 Richard Foley +# + 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 +# + pre'n'post commands no longer trashed with no args +# + watch val joined out of eval() # #################################################################### # Needed for the statement after exec(): BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN. + +# test if assertions are supported and actived: +BEGIN { + $ini_assertion= + eval "sub asserting_test : assertion {1}; 1"; + # $ini_assertion = undef => assertions unsupported, + # " = 1 => assertions suported + # print "\$ini_assertion=$ini_assertion\n"; +} + local($^W) = 0; # Switch run-time warnings off during init. warn ( # Do not ;-) $dumpvar::hashDepth, @@ -355,7 +371,10 @@ $inhibit_exit = $option{PrintRet} = 1; recallCommand ShellBang pager tkRunning ornaments signalLevel warnLevel dieLevel inhibit_exit ImmediateStop bareStringify CreateTTY - RemotePort windowSize); + RemotePort windowSize DollarCaretP OnlyAssertions + WarnAssertions); + +@RememberOnROptions = qw(DollarCaretP OnlyAssertions); %optionVars = ( hashDepth => \$dumpvar::hashDepth, @@ -377,6 +396,7 @@ $inhibit_exit = $option{PrintRet} = 1; ImmediateStop => \$ImmediateStop, RemotePort => \$remoteport, windowSize => \$window, + WarnAssertions => \$warnassertions, ); %optionAction = ( @@ -397,6 +417,8 @@ $inhibit_exit = $option{PrintRet} = 1; tkRunning => \&tkRunning, ornaments => \&ornaments, RemotePort => \&RemotePort, + DollarCaretP => \&DollarCaretP, + OnlyAssertions=> \&OnlyAssertions, ); %optionRequire = ( @@ -438,7 +460,7 @@ if (defined $ENV{PERLDB_PIDS}) { $term_pid = -1; } else { $ENV{PERLDB_PIDS} = "$$"; - $pids = ''; + $pids = "{pid=$$}"; $term_pid = $$; } $pidprompt = ''; @@ -662,9 +684,9 @@ sub DB { } $runnonstop = 0 if $single or $signal; # Disable it if interactive. &save; - ($package, $filename, $line) = caller; - $filename_ini = $filename; - $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' . + local($package, $filename, $line) = caller; + local $filename_ini = $filename; + local $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' . "package $package;"; # this won't let them modify, alas local(*dbline) = $main::{'_<' . $filename}; @@ -675,7 +697,7 @@ sub DB { *dbline = $main::{'_<' . $filename}; } - $max = $#dbline; + local $max = $#dbline; if ($dbline{$line} && (($stop,$action) = split(/\0/,$dbline{$line}))) { if ($stop eq '1') { $signal |= 1; @@ -689,7 +711,7 @@ sub DB { 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; @@ -892,91 +914,34 @@ EOP $start = 1 if $start <= 0; $incr = $window - 1; $cmd = 'l ' . ($start) . '+'; }; - # rjsf -> - $cmd =~ /^([aAbBDhlLMoOvwW])\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; }; - $cmd =~ /^n$/ && do { + # rjsf <- pre|post commands stripped out + $cmd =~ /^y(?:\s+(\d*)\s*(.*))?$/ && do { + eval { require PadWalker; PadWalker->VERSION(0.08) } + or &warn($@ =~ /locate/ + ? "PadWalker module not found - please install\n" + : $@) + and next CMD; + do 'dumpvar.pl' unless defined &main::dumpvar; + defined &main::dumpvar + or print $OUT "dumpvar.pl not available.\n" + and next CMD; + my @vars = split(' ', $2 || ''); + my $h = eval { PadWalker::peek_my(($1 || 0) + 1) }; + $@ and $@ =~ s/ at .*//, &warn($@), next CMD; + my $savout = select($OUT); + dumpvar::dumplex($_, $h->{$_}, + defined $option{dumpDepth} + ? $option{dumpDepth} : -1, + @vars) + for sort keys %$h; + select($savout); + next CMD; }; + $cmd =~ /^n$/ && do { end_report(), next CMD if $finished and $level <= 1; $single = 2; $laststep = $cmd; @@ -1029,6 +994,10 @@ EOP print $OUT "Warning: some settings and command-line options may be lost!\n"; my (@script, @flags, $cl); push @flags, '-w' if $ini_warn; + 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) { @@ -1050,7 +1019,7 @@ EOP ? $term->GetHistory : @hist); my @had_breakpoints = keys %had_breakpoints; set_list("PERLDB_VISITED", @had_breakpoints); - set_list("PERLDB_OPT", %option); + set_list("PERLDB_OPT", options2remember()); set_list("PERLDB_ON_LOAD", %break_on_load); my @hard; for (0 .. $#had_breakpoints) { @@ -1112,8 +1081,8 @@ EOP $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:; @@ -1253,7 +1222,7 @@ EOP } } next CMD; }; - $cmd =~ /^\@\s*(.*\S)/ && do { + $cmd =~ /^source\s+(.*\S)/ && do { if (open my $fh, $1) { push @cmdfhs, $fh; } else { @@ -1364,7 +1333,19 @@ sub sub { print_trace($LINEINFO, -1, 1, 1, "$sub$al") ) : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")) if $frame; if (wantarray) { - @ret = &$sub; + if ($assertion) { + $assertion=0; + eval { + @ret = &$sub; + }; + if ($@) { + print $OUT $@; + $signal=1 unless $warnassertions; + } + } + else { + @ret = &$sub; + } $single |= $stack[$stack_depth--]; ($frame & 4 ? ( print_lineinfo(' ' x $stack_depth, "out "), @@ -1380,11 +1361,24 @@ sub sub { } @ret; } else { - if (defined wantarray) { - $ret = &$sub; - } else { - &$sub; undef $ret; - }; + if ($assertion) { + $assertion=0; + eval { + $ret = &$sub; + }; + if ($@) { + print $OUT $@; + $signal=1 unless $warnassertions; + } + $ret=undef unless defined wantarray; + } + else { + if (defined wantarray) { + $ret = &$sub; + } else { + &$sub; undef $ret; + } + } $single |= $stack[$stack_depth--]; ($frame & 4 ? ( print_lineinfo(' ' x $stack_depth, "out "), @@ -1410,7 +1404,7 @@ sub sub { ### 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' => { @@ -1428,6 +1422,14 @@ my %set = ( # 'w' => 'v', 'W' => 'pre580_W', }, + 'pre590' => { + '<' => 'pre590_prepost', + '<<' => 'pre590_prepost', + '>' => 'pre590_prepost', + '>>' => 'pre590_prepost', + '{' => 'pre590_prepost', + '{{' => 'pre590_prepost', + }, ); sub cmd_wrapper { @@ -1439,14 +1441,15 @@ 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 "rjsf: cmd_wrapper($cmd): $CommandSet($set{$CommandSet}{$cmd}) => call($call)\n"; + # 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.+)/) { @@ -1466,6 +1469,7 @@ sub cmd_a { } sub cmd_A { + my $cmd = shift; # A my $line = shift || ''; my $dbline = shift; $line =~ s/^\./$dbline/; if ($line eq '*') { @@ -1503,6 +1507,7 @@ sub delete_action { } sub cmd_b { + my $cmd = shift; # b my $line = shift; # [.|line] [cond] my $dbline = shift; $line =~ s/^\./$dbline/; if ($line =~ /^\s*$/) { @@ -1647,6 +1652,7 @@ sub cmd_b_sub { } sub cmd_B { + my $cmd = shift; # B my $line = ($_[0] =~ /^\./) ? $dbline : shift || ''; my $dbline = shift; $line =~ s/^\./$dbline/; if ($line eq '*') { @@ -1696,6 +1702,7 @@ sub cmd_stop { # As on ^C, but not signal-safy. } sub cmd_h { + my $cmd = shift; # h my $line = shift || ''; if ($line =~ /^h\s*/) { print_help($help); @@ -1718,6 +1725,8 @@ sub cmd_h { } sub cmd_l { + my $current_line = $line; + my $cmd = shift; # l my $line = shift; $line =~ s/^-\s*$/-/; if ($line =~ /^(\$.*)/s) { @@ -1727,7 +1736,7 @@ sub cmd_l { $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/\'/::/; @@ -1752,20 +1761,20 @@ sub cmd_l { $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; @@ -1781,7 +1790,7 @@ sub cmd_l { my ($stop,$action); ($stop,$action) = split(/\0/, $dbline{$i}) if $dbline{$i}; - $arrow = ($i==$line + $arrow = ($i==$current_line and $filename eq $filename_ini) ? '==>' : ($dbline[$i]+0 ? ':' : ' ') ; @@ -1798,6 +1807,7 @@ sub cmd_l { } 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; @@ -1875,6 +1885,7 @@ sub cmd_M { } sub cmd_o { + my $cmd = shift; # o my $opt = shift || ''; # opt[=val] if ($opt =~ /^(\S.*)/) { &parse_options($1); @@ -1885,7 +1896,14 @@ sub cmd_o { } } +sub cmd_O { + print $OUT "The old O command is now the o command.\n"; # hint + print $OUT "Use 'h' to get current command help synopsis or\n"; # + print $OUT "use 'o CommandSet=pre580' to revert to old usage\n"; # +} + sub cmd_v { + my $cmd = shift; # v my $line = shift; if ($line =~ /^(\d*)$/) { @@ -1893,16 +1911,17 @@ sub cmd_v { $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; @@ -1912,6 +1931,7 @@ sub cmd_w { } sub cmd_W { + my $cmd = shift; # W my $expr = shift || ''; if ($expr eq '*') { $trace &= ~2; @@ -1931,6 +1951,25 @@ sub cmd_W { } } + + +sub cmd_P { + if ($cmd =~ /^.\b\s*([+-]?)\s*(~?)\s*(\w+(\s*\|\s*\w+)*)\s*$/) { + my ($how, $neg, $flags)=($1, $2, $3); + my $acu=parse_DollarCaretP_flags($flags); + if (defined $acu) { + $acu= ~$acu if $neg; + if ($how eq '+') { $^P|=$acu } + elsif ($how eq '-') { $^P&=~$acu } + else { $^P=$acu } + } + # else { print $OUT "undefined acu\n" } + } + my $expanded=expand_DollarCaretP_flags($^P); + print $OUT "Internal Perl debugger flags:\n\$^P=$expanded\n"; + $expanded +} + ### END of the API section sub save { @@ -2232,6 +2271,9 @@ sub os2_get_fork_TTY { $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b// if $ENV{PERL5OPT}; $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT}; print $OUT "Making kid PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT}; + local $ENV{PERL5LIB} = $ENV{PERL5LIB} ? $ENV{PERL5LIB} : $ENV{PERLLIB}; + $ENV{PERL5LIB} = '' unless defined $ENV{PERL5LIB}; + $ENV{PERL5LIB} = join ';', @ini_INC, split /;/, $ENV{PERL5LIB}; (my $name = $0) =~ s,^.*[/\\],,s; my @args; if ( pipe $in1, $out1 and pipe $in2, $out2 @@ -2240,6 +2282,8 @@ sub os2_get_fork_TTY { and @args = ($rl, fileno $in1, fileno $out2, "Daughter Perl debugger $pids $name") and (($kpid = CORE::system 4, $^X, '-we', <<'ES', @args) >= 0 # P_SESSION +END {sleep 5 unless $loaded} +BEGIN {open STDIN, ' I<*> Delete all watch-expressions. B [I [I]] List some (default all) variables in package (default current). Use B<~>I and BI for positive and negative regexps. B [I] Same as \"B I [I]\". +B [I [I]] List lexicals in higher scope . Vars same as B. B I Evals expression in list context, dumps the result. B I Evals expression in list context, prints methods callable on the first element of the result. B I Prints methods callable via the given class. B Show versions of loaded modules. +B [I [I]] List lexical variables I levels up from current sub B<<> ? List Perl commands to run before each prompt. B<<> I Define Perl command to run before each prompt. B<<<> I 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 Define Perl command to run after each prompt. B<>>B<>> I 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 Define debugger command to run before each prompt. B<{> ? List debugger commands to run before each prompt. B<{{> I 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 Redo a previous command (default previous command). B<$prc> I<-number> Redo number'th-to-last command. B<$prc> I Redo last command that started with I. @@ -2725,7 +2815,7 @@ B<$psh$psh> I Run cmd in a subprocess (reads from DB::IN, writes to DB::O . ( $rc eq $sh ? "" : " B<$psh> [I] Run I in subshell (forces \"\$SHELL -c 'cmd'\")." ) . " See 'B I' too. -B<@>I Execute I containing debugger commands (may nest). +B I Execute I containing debugger commands (may nest). B I<-number> Display last number commands (default all). B

I Same as \"I\" in current package. B<|>I Run debugger command, piping DB::OUT to current pager. @@ -2800,7 +2890,7 @@ I B List break/watch/act B [I<-num>] Display last num commands B [I] I Do cmd before line B<=> [I I] Define/list an alias B I Delete a/all actions B [I] Get help on command B I Add a watch expression - B Complete help page B I Delete a/all watch expressions + B Complete help page B I Delete a/all watch exprs B<|>[B<|>]I Send output to pager B<$psh>\[B<$psh>\] I Run cmd in a subprocess B or B<^D> Quit B Attempt a restart I B Execute perl code, also see: B,B,B I @@ -2809,6 +2899,7 @@ I B Execute perl code, also see: B,B,B B [[B]I] List subroutine names [not] matching pattern B [I [I]] List Variables in Package. Vars can be ~pattern or !pattern. B [I] Same as \"B I [I]\". + B [I [I]] List lexicals in higher scope . Vars same as B. For more help, type B I, or run B<$doccmd perldebug> for all docs. END_SUM # ')}}; # Fix balance of vi % matching @@ -2893,7 +2984,7 @@ B<$psh$psh> I Run cmd in a subprocess (reads from DB::IN, writes to DB::O . ( $rc eq $sh ? "" : " B<$psh> [I] Run I in subshell (forces \"\$SHELL -c 'cmd'\")." ) . " See 'B I' too. -B<@>I Execute I containing debugger commands (may nest). +B I Execute I containing debugger commands (may nest). B I<-number> Display last number commands (default all). B

I Same as \"I\" in current package. B<|>I Run debugger command, piping DB::OUT to current pager. @@ -2976,6 +3067,7 @@ I B Execute perl code, also see: B,B,B B [[B]I] List subroutine names [not] matching pattern B [I [I]] List Variables in Package. Vars can be ~pattern or !pattern. B [I] Same as \"B I [I]\". + B [I [I]] List lexicals in higher scope . Vars same as B. For more help, type B I, or run B<$doccmd perldebug> for all docs. END_SUM # ')}}; # Fix balance of vi % matching @@ -3416,6 +3508,70 @@ sub clean_ENV { } } + +# PERLDBf_... flag names from perl.h +our (%DollarCaretP_flags, %DollarCaretP_flags_r); +BEGIN { + %DollarCaretP_flags = + ( PERLDBf_SUB => 0x01, # Debug sub enter/exit + PERLDBf_LINE => 0x02, # Keep line # + PERLDBf_NOOPT => 0x04, # Switch off optimizations + PERLDBf_INTER => 0x08, # Preserve more data + PERLDBf_SUBLINE => 0x10, # Keep subr source lines + PERLDBf_SINGLE => 0x20, # Start with single-step on + PERLDBf_NONAME => 0x40, # For _SUB: no name of the subr + PERLDBf_GOTO => 0x80, # Report goto: call DB::goto + PERLDBf_NAMEEVAL => 0x100, # Informative names for evals + PERLDBf_NAMEANON => 0x200, # Informative names for anon subs + PERLDBf_ASSERTION => 0x400, # Debug assertion subs enter/exit + PERLDB_ALL => 0x33f, # No _NONAME, _GOTO, _ASSERTION + ); + + %DollarCaretP_flags_r=reverse %DollarCaretP_flags; +} + +sub parse_DollarCaretP_flags { + my $flags=shift; + $flags=~s/^\s+//; + $flags=~s/\s+$//; + my $acu=0; + foreach my $f (split /\s*\|\s*/, $flags) { + my $value; + if ($f=~/^0x([[:xdigit:]]+)$/) { + $value=hex $1; + } + elsif ($f=~/^(\d+)$/) { + $value=int $1; + } + elsif ($f=~/^DEFAULT$/i) { + $value=$DollarCaretP_flags{PERLDB_ALL}; + } + else { + $f=~/^(?:PERLDBf_)?(.*)$/i; + $value=$DollarCaretP_flags{'PERLDBf_'.uc($1)}; + unless (defined $value) { + print $OUT ("Unrecognized \$^P flag '$f'!\n", + "Acceptable flags are: ". + join(', ', sort keys %DollarCaretP_flags), + ", and hexadecimal and decimal numbers.\n"); + return undef; + } + } + $acu|=$value; + } + $acu; +} + +sub expand_DollarCaretP_flags { + my $DollarCaretP=shift; + my @bits= ( map { my $n=(1<<$_); + ($DollarCaretP & $n) + ? ($DollarCaretP_flags_r{$n} + || sprintf('0x%x', $n)) + : () } 0..31 ); + return @bits ? join('|', @bits) : 0; +} + END { $finished = 1 if $inhibit_exit; # So that some keys may be disabled. $fall_off_end = 1 unless $inhibit_exit; @@ -3434,6 +3590,7 @@ sub cmd_pre580_null { } sub cmd_pre580_a { + my $xcmd = shift; # my $cmd = shift; if ($cmd =~ /^(\d*)\s*(.*)/) { $i = $1 || $line; $j = $2; @@ -3453,6 +3610,7 @@ sub cmd_pre580_a { } sub cmd_pre580_b { + my $xcmd = shift; # my $cmd = shift; my $dbline = shift; if ($cmd =~ /^load\b\s*(.*)/) { @@ -3478,6 +3636,7 @@ sub cmd_pre580_b { } sub cmd_pre580_D { + my $xcmd = shift; # my $cmd = shift; if ($cmd =~ /^\s*$/) { print $OUT "Deleting all breakpoints...\n"; @@ -3507,6 +3666,7 @@ sub cmd_pre580_D { } sub cmd_pre580_h { + my $xcmd = shift; # my $cmd = shift; if ($cmd =~ /^\s*$/) { print_help($pre580_help); @@ -3527,6 +3687,7 @@ sub cmd_pre580_h { } sub cmd_pre580_W { + my $xcmd = shift; # my $cmd = shift; if ($cmd =~ /^$/) { $trace &= ~2; @@ -3541,6 +3702,67 @@ sub cmd_pre580_W { } } +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 = '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 { @@ -3550,4 +3772,3 @@ sub at_exit { package DB; # Do not trace this 1; below! 1; -