+ $ret;
+ }
+}
+
+### The API section
+
+### Functions with multiple modes of failure die on error, the rest
+### returns FALSE on error.
+### User-interface functions cmd_* output error message.
+
+### Note all cmd_[a-zA-Z]'s require $line, $dblineno as first arguments
+
+my %set = ( #
+ 'pre580' => {
+ 'a' => 'pre580_a',
+ 'A' => 'pre580_null',
+ 'b' => 'pre580_b',
+ 'B' => 'pre580_null',
+ 'd' => 'pre580_null',
+ 'D' => 'pre580_D',
+ 'h' => 'pre580_h',
+ 'M' => 'pre580_null',
+ 'O' => 'o',
+ 'o' => 'pre580_null',
+ 'v' => 'M',
+ 'w' => 'v',
+ 'W' => 'pre580_W',
+ },
+);
+
+sub cmd_wrapper {
+ my $cmd = shift;
+ my $line = shift;
+ my $dblineno = shift;
+
+ # with this level of indirection we can wrap
+ # to old (pre580) or other command sets easily
+ #
+ my $call = 'cmd_'.(
+ $set{$CommandSet}{$cmd} || $cmd
+ );
+ # print "cmd_wrapper($cmd): $CommandSet($set{$CommandSet}{$cmd}) => call($call)\n";
+
+ return &$call($line, $dblineno);
+}
+
+sub cmd_a {
+ my $line = shift || ''; # [.|line] expr
+ my $dbline = shift; $line =~ s/^(\.|(?:[^\d]))/$dbline/;
+ if ($line =~ /^\s*(\d*)\s*(\S.+)/) {
+ my ($lineno, $expr) = ($1, $2);
+ if (length $expr) {
+ if ($dbline[$lineno] == 0) {
+ print $OUT "Line $lineno($dbline[$lineno]) does not have an action?\n";
+ } else {
+ $had_breakpoints{$filename} |= 2;
+ $dbline{$lineno} =~ s/\0[^\0]*//;
+ $dbline{$lineno} .= "\0" . action($expr);
+ }
+ }
+ } else {
+ print $OUT "Adding an action requires an optional lineno and an expression\n"; # hint
+ }
+}
+
+sub cmd_A {
+ my $line = shift || '';
+ my $dbline = shift; $line =~ s/^\./$dbline/;
+ if ($line eq '*') {
+ eval { &delete_action(); 1 } or print $OUT $@ and return;
+ } elsif ($line =~ /^(\S.*)/) {
+ eval { &delete_action($1); 1 } or print $OUT $@ and return;
+ } else {
+ print $OUT "Deleting an action requires a line number, or '*' for all\n"; # hint
+ }
+}
+
+sub delete_action {
+ my $i = shift;
+ if (defined($i)) {
+ die "Line $i has no action .\n" if $dbline[$i] == 0;
+ $dbline{$i} =~ s/\0[^\0]*//; # \^a
+ delete $dbline{$i} if $dbline{$i} eq '';
+ } else {
+ print $OUT "Deleting all actions...\n";
+ for my $file (keys %had_breakpoints) {
+ local *dbline = $main::{'_<' . $file};
+ my $max = $#dbline;
+ my $was;
+ for ($i = 1; $i <= $max ; $i++) {
+ if (defined $dbline{$i}) {
+ $dbline{$i} =~ s/\0[^\0]*//;
+ delete $dbline{$i} if $dbline{$i} eq '';
+ }
+ unless ($had_breakpoints{$file} &= ~2) {
+ delete $had_breakpoints{$file};
+ }
+ }
+ }
+ }
+}
+
+sub cmd_b {
+ my $line = shift; # [.|line] [cond]
+ my $dbline = shift; $line =~ s/^\./$dbline/;
+ if ($line =~ /^\s*$/) {
+ &cmd_b_line($dbline, 1);
+ } elsif ($line =~ /^load\b\s*(.*)/) {
+ my $file = $1; $file =~ s/\s+$//;
+ &cmd_b_load($file);
+ } elsif ($line =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/) {
+ my $cond = length $3 ? $3 : '1';
+ my ($subname, $break) = ($2, $1 eq 'postpone');
+ $subname =~ s/\'/::/g;
+ $subname = "${'package'}::" . $subname unless $subname =~ /::/;
+ $subname = "main".$subname if substr($subname,0,2) eq "::";
+ $postponed{$subname} = $break ? "break +0 if $cond" : "compile";
+ } elsif ($line =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/) {
+ $subname = $1;
+ $cond = length $2 ? $2 : '1';
+ &cmd_b_sub($subname, $cond);
+ } elsif ($line =~ /^(\d*)\s*(.*)/) {
+ $line = $1 || $dbline;
+ $cond = length $2 ? $2 : '1';
+ &cmd_b_line($line, $cond);
+ } else {
+ print "confused by line($line)?\n";
+ }
+}
+
+sub break_on_load {
+ my $file = shift;
+ $break_on_load{$file} = 1;
+ $had_breakpoints{$file} |= 1;
+}
+
+sub report_break_on_load {
+ sort keys %break_on_load;
+}
+
+sub cmd_b_load {
+ my $file = shift;
+ my @files;
+ {
+ push @files, $file;
+ push @files, $::INC{$file} if $::INC{$file};
+ $file .= '.pm', redo unless $file =~ /\./;
+ }
+ break_on_load($_) for @files;
+ @files = report_break_on_load;
+ local $\ = '';
+ local $" = ' ';
+ print $OUT "Will stop on load of `@files'.\n";
+}
+
+$filename_error = '';
+
+sub breakable_line {
+ my ($from, $to) = @_;
+ my $i = $from;
+ if (@_ >= 2) {
+ my $delta = $from < $to ? +1 : -1;
+ my $limit = $delta > 0 ? $#dbline : 1;
+ $limit = $to if ($limit - $to) * $delta > 0;
+ $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
+ }
+ return $i unless $dbline[$i] == 0;
+ my ($pl, $upto) = ('', '');
+ ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
+ die "Line$pl $from$upto$filename_error not breakable\n";
+}
+
+sub breakable_line_in_filename {
+ my ($f) = shift;
+ local *dbline = $main::{'_<' . $f};
+ local $filename_error = " of `$f'";
+ breakable_line(@_);
+}
+
+sub break_on_line {
+ my ($i, $cond) = @_;
+ $cond = 1 unless @_ >= 2;
+ my $inii = $i;
+ my $after = '';
+ my $pl = '';
+ die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
+ $had_breakpoints{$filename} |= 1;
+ if ($dbline{$i}) { $dbline{$i} =~ s/^[^\0]*/$cond/; }
+ else { $dbline{$i} = $cond; }
+}
+
+sub cmd_b_line {
+ eval { break_on_line(@_); 1 } or do {
+ local $\ = '';
+ print $OUT $@ and return;
+ };
+}
+
+sub break_on_filename_line {
+ my ($f, $i, $cond) = @_;
+ $cond = 1 unless @_ >= 3;
+ local *dbline = $main::{'_<' . $f};
+ local $filename_error = " of `$f'";
+ local $filename = $f;
+ break_on_line($i, $cond);
+}
+
+sub break_on_filename_line_range {
+ my ($f, $from, $to, $cond) = @_;
+ my $i = breakable_line_in_filename($f, $from, $to);
+ $cond = 1 unless @_ >= 3;
+ break_on_filename_line($f,$i,$cond);
+}
+
+sub subroutine_filename_lines {
+ my ($subname,$cond) = @_;
+ # Filename below can contain ':'
+ find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
+}
+
+sub break_subroutine {
+ my $subname = shift;
+ my ($file,$s,$e) = subroutine_filename_lines($subname) or
+ die "Subroutine $subname not found.\n";
+ $cond = 1 unless @_ >= 2;
+ break_on_filename_line_range($file,$s,$e,@_);
+}
+
+sub cmd_b_sub {
+ my ($subname,$cond) = @_;
+ $cond = 1 unless @_ >= 2;
+ unless (ref $subname eq 'CODE') {
+ $subname =~ s/\'/::/g;
+ my $s = $subname;
+ $subname = "${'package'}::" . $subname
+ unless $subname =~ /::/;
+ $subname = "CORE::GLOBAL::$s"
+ if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"};
+ $subname = "main".$subname if substr($subname,0,2) eq "::";
+ }
+ eval { break_subroutine($subname,$cond); 1 } or do {
+ local $\ = '';
+ print $OUT $@ and return;
+ }
+}
+
+sub cmd_B {
+ my $line = ($_[0] =~ /^\./) ? $dbline : shift || '';
+ my $dbline = shift; $line =~ s/^\./$dbline/;
+ if ($line eq '*') {
+ eval { &delete_breakpoint(); 1 } or print $OUT $@ and return;
+ } elsif ($line =~ /^(\S.*)/) {
+ eval { &delete_breakpoint($line || $dbline); 1 } or do {
+ local $\ = '';
+ print $OUT $@ and return;
+ };
+ } else {
+ print $OUT "Deleting a breakpoint requires a line number, or '*' for all\n"; # hint
+ }
+}
+
+sub delete_breakpoint {
+ my $i = shift;
+ if (defined($i)) {
+ die "Line $i not breakable.\n" if $dbline[$i] == 0;
+ $dbline{$i} =~ s/^[^\0]*//;
+ delete $dbline{$i} if $dbline{$i} eq '';
+ } else {
+ print $OUT "Deleting all breakpoints...\n";
+ for my $file (keys %had_breakpoints) {
+ local *dbline = $main::{'_<' . $file};
+ my $max = $#dbline;
+ my $was;
+ for ($i = 1; $i <= $max ; $i++) {
+ if (defined $dbline{$i}) {
+ $dbline{$i} =~ s/^[^\0]+//;
+ if ($dbline{$i} =~ s/^\0?$//) {
+ delete $dbline{$i};
+ }
+ }
+ }
+ if (not $had_breakpoints{$file} &= ~1) {
+ delete $had_breakpoints{$file};
+ }
+ }
+ undef %postponed;
+ undef %postponed_file;
+ undef %break_on_load;
+ }
+}
+
+sub cmd_stop { # As on ^C, but not signal-safy.
+ $signal = 1;
+}
+
+sub cmd_h {
+ my $line = shift || '';
+ if ($line =~ /^h\s*/) {
+ print_help($help);
+ } elsif ($line =~ /^(\S.*)$/) {
+ # support long commands; otherwise bogus errors
+ # happen when you ask for h on <CR> for example
+ my $asked = $1; # for proper errmsg
+ my $qasked = quotemeta($asked); # for searching
+ # XXX: finds CR but not <CR>
+ if ($help =~ /^<?(?:[IB]<)$qasked/m) {
+ while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
+ print_help($1);
+ }
+ } else {
+ print_help("B<$asked> is not a debugger command.\n");
+ }
+ } else {
+ print_help($summary);
+ }
+}
+
+sub cmd_l {
+ my $line = shift;
+ $line =~ s/^-\s*$/-/;
+ if ($line =~ /^(\$.*)/s) {
+ $evalarg = $2;
+ my ($s) = &eval;
+ print($OUT "Error: $@\n"), next CMD if $@;
+ $s = CvGV_name($s);
+ print($OUT "Interpreted as: $1 $s\n");
+ $line = "$1 $s";
+ &cmd_l($s);
+ } elsif ($line =~ /^([\':A-Za-z_][\':\w]*(\[.*\])?)/s) {
+ my $s = $subname = $1;
+ $subname =~ s/\'/::/;
+ $subname = $package."::".$subname
+ unless $subname =~ /::/;
+ $subname = "CORE::GLOBAL::$s"
+ if not defined &$subname and $s !~ /::/
+ and defined &{"CORE::GLOBAL::$s"};
+ $subname = "main".$subname if substr($subname,0,2) eq "::";
+ @pieces = split(/:/,find_sub($subname) || $sub{$subname});
+ $subrange = pop @pieces;
+ $file = join(':', @pieces);
+ if ($file ne $filename) {
+ print $OUT "Switching to file '$file'.\n"
+ unless $slave_editor;
+ *dbline = $main::{'_<' . $file};
+ $max = $#dbline;
+ $filename = $file;
+ }
+ if ($subrange) {
+ if (eval($subrange) < -$window) {
+ $subrange =~ s/-.*/+/;
+ }
+ $line = $subrange;
+ &cmd_l($subrange);
+ } else {
+ print $OUT "Subroutine $subname not found.\n";
+ }
+ } elsif ($line =~ /^\s*$/) {
+ $incr = $window - 1;
+ $line = $start . '-' . ($start + $incr);
+ &cmd_l($line);
+ } elsif ($line =~ /^(\d*)\+(\d*)$/) {
+ $start = $1 if $1;
+ $incr = $2;
+ $incr = $window - 1 unless $incr;
+ $line = $start . '-' . ($start + $incr);
+ &cmd_l($line);
+ } elsif ($line =~ /^((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/) {
+ $end = (!defined $2) ? $max : ($4 ? $4 : $2);
+ $end = $max if $end > $max;
+ $i = $2;
+ $i = $line if $i eq '.';
+ $i = 1 if $i < 1;
+ $incr = $end - $i;
+ if ($slave_editor) {
+ print $OUT "\032\032$filename:$i:0\n";
+ $i = $end;
+ } else {
+ for (; $i <= $end; $i++) {
+ my ($stop,$action);
+ ($stop,$action) = split(/\0/, $dbline{$i}) if
+ $dbline{$i};
+ $arrow = ($i==$line
+ and $filename eq $filename_ini)
+ ? '==>'
+ : ($dbline[$i]+0 ? ':' : ' ') ;
+ $arrow .= 'b' if $stop;
+ $arrow .= 'a' if $action;
+ print $OUT "$i$arrow\t", $dbline[$i];
+ $i++, last if $signal;
+ }
+ print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
+ }
+ $start = $i; # remember in case they want more
+ $start = $max if $start > $max;
+ }
+}
+
+sub cmd_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;
+ my $watch_wanted = ($arg =~ /w/) ? 1 : 0;
+
+ if ($break_wanted or $action_wanted) {
+ for my $file (keys %had_breakpoints) {
+ local *dbline = $main::{'_<' . $file};
+ my $max = $#dbline;
+ my $was;
+ for ($i = 1; $i <= $max; $i++) {
+ if (defined $dbline{$i}) {
+ print $OUT "$file:\n" unless $was++;
+ print $OUT " $i:\t", $dbline[$i];
+ ($stop,$action) = split(/\0/, $dbline{$i});
+ print $OUT " break if (", $stop, ")\n"
+ if $stop and $break_wanted;
+ print $OUT " action: ", $action, "\n"
+ if $action and $action_wanted;
+ last if $signal;
+ }
+ }
+ }
+ }
+ if (%postponed and $break_wanted) {
+ print $OUT "Postponed breakpoints in subroutines:\n";
+ my $subname;
+ for $subname (keys %postponed) {
+ print $OUT " $subname\t$postponed{$subname}\n";
+ last if $signal;
+ }
+ }
+ my @have = map { # Combined keys
+ keys %{$postponed_file{$_}}
+ } keys %postponed_file;
+ if (@have and ($break_wanted or $action_wanted)) {
+ print $OUT "Postponed breakpoints in files:\n";
+ my ($file, $line);
+ for $file (keys %postponed_file) {
+ my $db = $postponed_file{$file};
+ print $OUT " $file:\n";
+ for $line (sort {$a <=> $b} keys %$db) {
+ print $OUT " $line:\n";
+ my ($stop,$action) = split(/\0/, $$db{$line});
+ print $OUT " break if (", $stop, ")\n"
+ if $stop and $break_wanted;
+ print $OUT " action: ", $action, "\n"
+ if $action and $action_wanted;
+ last if $signal;
+ }
+ last if $signal;
+ }
+ }
+ if (%break_on_load and $break_wanted) {
+ print $OUT "Breakpoints on load:\n";
+ my $file;
+ for $file (keys %break_on_load) {
+ print $OUT " $file\n";
+ last if $signal;
+ }
+ }
+ if ($watch_wanted) {
+ if ($trace & 2) {
+ print $OUT "Watch-expressions:\n" if @to_watch;
+ for my $expr (@to_watch) {
+ print $OUT " $expr\n";
+ last if $signal;
+ }
+ }
+ }
+}
+
+sub cmd_M {
+ &list_modules();
+}
+
+sub cmd_o {
+ my $opt = shift || ''; # opt[=val]
+ if ($opt =~ /^(\S.*)/) {
+ &parse_options($1);
+ } else {
+ for (@options) {
+ &dump_option($_);
+ }
+ }
+}
+
+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 $line = shift;
+
+ if ($line =~ /^(\d*)$/) {
+ $incr = $window - 1;
+ $start = $1 if $1;
+ $start -= $preview;
+ $line = $start . '-' . ($start + $incr);
+ &cmd_l($line);
+ }
+}
+
+sub cmd_w {
+ my $expr = shift || '';
+ if ($expr =~ /^(\S.*)/) {
+ push @to_watch, $expr;
+ $evalarg = $expr;
+ my ($val) = &eval;
+ $val = (defined $val) ? "'$val'" : 'undef' ;
+ push @old_watch, $val;
+ $trace |= 2;
+ } else {
+ print $OUT "Adding a watch-expression requires an expression\n"; # hint
+ }
+}
+
+sub cmd_W {
+ my $expr = shift || '';
+ if ($expr eq '*') {
+ $trace &= ~2;
+ print $OUT "Deleting all watch expressions ...\n";
+ @to_watch = @old_watch = ();
+ } elsif ($expr =~ /^(\S.*)/) {
+ my $i_cnt = 0;
+ foreach (@to_watch) {
+ my $val = $to_watch[$i_cnt];
+ if ($val eq $expr) { # =~ m/^\Q$i$/) {
+ splice(@to_watch, $i_cnt, 1);
+ }
+ $i_cnt++;
+ }
+ } else {
+ print $OUT "Deleting a watch-expression requires an expression, or '*' for all\n"; # hint
+ }