X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fperl5db.pl;h=9655956348f9d0929d1375ae80b9ec868ad0240a;hb=5438961c527f841385f3ab1b8503235cb786f085;hp=c770b52321caf78b4b048a03cb599ee4382ec7a5;hpb=7f9c46c2e27d6ddeeb97c57f8d12c650dafc9778;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/perl5db.pl b/lib/perl5db.pl index c770b52..9655956 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -1,7 +1,9 @@ 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 @@ -79,7 +81,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 @@ -320,12 +321,25 @@ sub eval { # + 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, @@ -359,7 +373,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, @@ -381,6 +398,7 @@ $inhibit_exit = $option{PrintRet} = 1; ImmediateStop => \$ImmediateStop, RemotePort => \$remoteport, windowSize => \$window, + WarnAssertions => \$warnassertions, ); %optionAction = ( @@ -401,6 +419,8 @@ $inhibit_exit = $option{PrintRet} = 1; tkRunning => \&tkRunning, ornaments => \&ornaments, RemotePort => \&RemotePort, + DollarCaretP => \&DollarCaretP, + OnlyAssertions=> \&OnlyAssertions, ); %optionRequire = ( @@ -693,7 +713,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; @@ -896,91 +916,34 @@ EOP $start = 1 if $start <= 0; $incr = $window - 1; $cmd = 'l ' . ($start) . '+'; }; - # rjsf -> - $cmd =~ /^([aAbBhlLMoOvwW])\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; @@ -1033,6 +996,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) { @@ -1054,7 +1021,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) { @@ -1116,8 +1083,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:; @@ -1257,7 +1224,7 @@ EOP } } next CMD; }; - $cmd =~ /^\@\s*(.*\S)/ && do { + $cmd =~ /^source\s+(.*\S)/ && do { if (open my $fh, $1) { push @cmdfhs, $fh; } else { @@ -1304,6 +1271,8 @@ EOP $onetimeDump = undef; $onetimedumpDepth = undef; } elsif ($term_pid == $$) { + STDOUT->flush(); + STDERR->flush(); print $OUT "\n"; } } continue { # CMD: @@ -1368,7 +1337,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 "), @@ -1384,11 +1365,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 "), @@ -1414,7 +1408,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' => { @@ -1432,6 +1426,14 @@ my %set = ( # 'w' => 'v', 'W' => 'pre580_W', }, + 'pre590' => { + '<' => 'pre590_prepost', + '<<' => 'pre590_prepost', + '>' => 'pre590_prepost', + '>>' => 'pre590_prepost', + '{' => 'pre590_prepost', + '{{' => 'pre590_prepost', + }, ); sub cmd_wrapper { @@ -1443,14 +1445,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 "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.+)/) { @@ -1470,6 +1473,7 @@ sub cmd_a { } sub cmd_A { + my $cmd = shift; # A my $line = shift || ''; my $dbline = shift; $line =~ s/^\./$dbline/; if ($line eq '*') { @@ -1507,6 +1511,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*$/) { @@ -1651,6 +1656,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 '*') { @@ -1700,6 +1706,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); @@ -1722,6 +1729,8 @@ sub cmd_h { } sub cmd_l { + my $current_line = $line; + my $cmd = shift; # l my $line = shift; $line =~ s/^-\s*$/-/; if ($line =~ /^(\$.*)/s) { @@ -1731,7 +1740,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/\'/::/; @@ -1756,20 +1765,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; @@ -1785,7 +1794,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 ? ':' : ' ') ; @@ -1802,6 +1811,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; @@ -1879,6 +1889,7 @@ sub cmd_M { } sub cmd_o { + my $cmd = shift; # o my $opt = shift || ''; # opt[=val] if ($opt =~ /^(\S.*)/) { &parse_options($1); @@ -1896,6 +1907,7 @@ sub cmd_O { } sub cmd_v { + my $cmd = shift; # v my $line = shift; if ($line =~ /^(\d*)$/) { @@ -1903,16 +1915,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; @@ -1922,6 +1935,7 @@ sub cmd_w { } sub cmd_W { + my $cmd = shift; # W my $expr = shift || ''; if ($expr eq '*') { $trace &= ~2; @@ -1941,6 +1955,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 { @@ -2364,6 +2397,13 @@ sub dump_option { printf $OUT "%20s = '%s'\n", $opt, $val; } +sub options2remember { + foreach my $k (@RememberOnROptions) { + $option{$k}=option_val($k, 'N/A'); + } + return %option; +} + sub option_val { my ($opt, $default)= @_; my $val; @@ -2577,6 +2617,40 @@ sub NonStop { $runnonstop; } +sub DollarCaretP { + if ($term) { + &warn("Some flag changes could not take effect until next 'R'!\n") if @_; + } + $^P = parse_DollarCaretP_flags(shift) if @_; + expand_DollarCaretP_flags($^P) +} + +sub OnlyAssertions { + if ($term) { + &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"); + } + return 0; + } + 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}) || 0; +} + sub pager { if (@_) { $pager = shift; @@ -2717,21 +2791,26 @@ B 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. @@ -2740,7 +2819,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. @@ -2815,7 +2894,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 @@ -2909,7 +2988,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. @@ -3433,6 +3512,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; @@ -3451,6 +3594,7 @@ sub cmd_pre580_null { } sub cmd_pre580_a { + my $xcmd = shift; # my $cmd = shift; if ($cmd =~ /^(\d*)\s*(.*)/) { $i = $1 || $line; $j = $2; @@ -3470,6 +3614,7 @@ sub cmd_pre580_a { } sub cmd_pre580_b { + my $xcmd = shift; # my $cmd = shift; my $dbline = shift; if ($cmd =~ /^load\b\s*(.*)/) { @@ -3495,6 +3640,7 @@ sub cmd_pre580_b { } sub cmd_pre580_D { + my $xcmd = shift; # my $cmd = shift; if ($cmd =~ /^\s*$/) { print $OUT "Deleting all breakpoints...\n"; @@ -3524,6 +3670,7 @@ sub cmd_pre580_D { } sub cmd_pre580_h { + my $xcmd = shift; # my $cmd = shift; if ($cmd =~ /^\s*$/) { print_help($pre580_help); @@ -3544,6 +3691,7 @@ sub cmd_pre580_h { } sub cmd_pre580_W { + my $xcmd = shift; # my $cmd = shift; if ($cmd =~ /^$/) { $trace &= ~2; @@ -3558,6 +3706,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 { @@ -3567,4 +3776,3 @@ sub at_exit { package DB; # Do not trace this 1; below! 1; -