pod2html: try to be EOL agnostic.

[p5sagit/p5-mst-13.2.git] / lib / perl5db.pl

diff --git a/lib/perl5db.pl b/lib/perl5db.pl
index e48a9aa..ba3e2f7 100644 (file)
--- 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.19;
 $header  = "perl5db.pl version $VERSION";
 
 # It is crucial that there is no lexicals in scope of `eval ""' down below
@@ -23,6 +23,7 @@ sub eval {
     local $saved[0];           # Preserve the old value of $@
     eval { &DB::save };
     if ($at) {
+       local $\ = '';
        print $OUT $at;
     } elsif ($onetimeDump) {
       if ($onetimeDump eq 'dump')  {
@@ -315,6 +316,10 @@ 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 <richard.foley@rfi.net>
+#   + fixed missing cmd_O bug
+# Changes: 1.19: Mar 29, 2002 Spider Boardman
+#   + Added missing local()s -- DB::DB is called recursively.
 # 
 ####################################################################
 
@@ -437,7 +442,7 @@ if (defined $ENV{PERLDB_PIDS}) {
   $term_pid = -1;
 } else {
   $ENV{PERLDB_PIDS} = "$$";
-  $pids = '';
+  $pids = "{pid=$$}";
   $term_pid = $$;
 }
 $pidprompt = '';
@@ -617,6 +622,8 @@ if ($notty) {
 
   $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
   unless ($runnonstop) {
+    local $\ = '';
+    local $, = '';
     if ($term_pid eq '-1') {
       print $OUT "\nDaughter DB session started...\n";
     } else {
@@ -659,12 +666,20 @@ 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};
-    $max = $#dbline;
+
+    # we need to check for pseudofiles on Mac OS (these are files
+    # not attached to a filename, but instead stored in Dev:Pseudo)
+    if ($^O eq 'MacOS' && $#dbline < 0) {
+       $filename_ini = $filename = 'Dev:Pseudo';
+       *dbline = $main::{'_<' . $filename};
+    }
+
+    local $max = $#dbline;
     if ($dbline{$line} && (($stop,$action) = split(/\0/,$dbline{$line}))) {
                if ($stop eq '1') {
                        $signal |= 1;
@@ -750,7 +765,7 @@ EOP
            &eval;
          }
          print $OUT $stack_depth . " levels deep in subroutine calls!\n"
-         if $single & 4;
+              if $single & 4;
                $start = $line;
                $incr = -1;             # for backward motion.
                @typeahead = (@$pretype, @typeahead);
@@ -778,18 +793,26 @@ EOP
                                        local $SIG{__WARN__};
                                        eval "\$cmd =~ $alias{$i}";
                                        if ($@) {
+                                                local $\ = '';
                                                print $OUT "Couldn't evaluate `$i' alias: $@";
                                                next CMD;
                                        } 
                    }
-        $cmd =~ /^q$/ && ($fall_off_end = 1) && clean_ENV() && exit $?;
+                    $cmd =~ /^q$/ && do {
+                        $fall_off_end = 1;
+                        clean_ENV();
+                        exit $?;
+                    };
                    $cmd =~ /^t$/ && do {
                        $trace ^= 1;
+                       local $\ = '';
                        print $OUT "Trace = " .
                            (($trace & 1) ? "on" : "off" ) . "\n";
                        next CMD; };
                    $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
                        $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
+                       local $\ = '';
+                       local $, = '';
                        foreach $subname (sort(keys %sub)) {
                            if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
                                print $OUT $subname,"\n";
@@ -808,7 +831,10 @@ EOP
                            local $frame = 0;
                            local $doret = -2;
                            # must detect sigpipe failures
-                           eval { &main::dumpvar($packname,@vars) };
+                           eval { &main::dumpvar($packname,
+                                                 defined $option{dumpDepth}
+                                                  ? $option{dumpDepth} : -1,
+                                                 @vars) };
                            if ($@) {
                                die unless $@ =~ /dumpvar print failed/;
                            } 
@@ -1349,6 +1375,7 @@ sub sub {
             print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
         : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
        if ($doret eq $stack_depth or $frame & 16) {
+           local $\ = '';
             my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
            print $fh ' ' x $stack_depth if $frame & 16;
            print $fh "list context return from $sub:\n"; 
@@ -1368,6 +1395,7 @@ sub sub {
              print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
         : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
        if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
+           local $\ = '';
             my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
            print $fh (' ' x $stack_depth) if $frame & 16;
            print $fh (defined wantarray 
@@ -1417,7 +1445,7 @@ sub cmd_wrapper {
        my $call = 'cmd_'.(
                $set{$CommandSet}{$cmd} || $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);
 }
@@ -1526,6 +1554,8 @@ sub cmd_b_load {
   }
   break_on_load($_) for @files;
   @files = report_break_on_load;
+  local $\ = '';
+  local $" = ' ';
   print $OUT "Will stop on load of `@files'.\n";
 }
 
@@ -1566,7 +1596,10 @@ sub break_on_line {
 }
 
 sub cmd_b_line {
-  eval { break_on_line(@_); 1 } or print $OUT $@ and return;
+  eval { break_on_line(@_); 1 } or do {
+    local $\ = '';
+    print $OUT $@ and return;
+  };
 }
 
 sub break_on_filename_line {
@@ -1611,7 +1644,10 @@ sub cmd_b_sub {
       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 print $OUT $@ and return;
+  eval { break_subroutine($subname,$cond); 1 } or do {
+    local $\ = '';
+    print $OUT $@ and return;
+  }
 }
 
 sub cmd_B {
@@ -1620,7 +1656,10 @@ sub cmd_B {
        if ($line eq '*') {
                eval { &delete_breakpoint(); 1 } or print $OUT $@ and return;
        } elsif ($line =~ /^(\S.*)/) {
-               eval { &delete_breakpoint($line || $dbline); 1 } or print $OUT $@ and return;
+               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
        }
@@ -1850,6 +1889,12 @@ 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 $line = shift;
 
@@ -1905,6 +1950,8 @@ sub save {
 
 sub print_lineinfo {
   resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
+  local $\ = '';
+  local $, = '';
   print $LINEINFO @_;
 }
 
@@ -1925,6 +1972,7 @@ sub postponed_sub {
       ++$i until $dbline[$i] != 0 or $i >= $max;
       $dbline{$i} = delete $postponed{$subname};
     } else {
+      local $\ = '';
       print $OUT "Subroutine $subname not found.\n";
     }
     return;
@@ -1944,6 +1992,7 @@ sub postponed {
   local *dbline = shift;
   my $filename = $dbline;
   $filename =~ s/^_<//;
+  local $\ = '';
   $signal = 1, print $OUT "'$filename' loaded...\n"
     if $break_on_load{$filename};
   print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
@@ -1968,11 +2017,15 @@ sub dumpit {
        do 'dumpvar.pl';
     }
     if (defined &main::dumpValue) {
+        local $\ = '';
+        local $, = '';
+        local $" = ' ';
         my $v = shift;
         my $maxdepth = shift || $option{dumpDepth};
         $maxdepth = -1 unless defined $maxdepth;   # -1 means infinite depth
        &main::dumpValue($v, $maxdepth);
     } else {
+        local $\ = '';
        print $OUT "dumpvar.pl not available.\n";
     }
     $single = $osingle;
@@ -1983,6 +2036,7 @@ sub dumpit {
 # Tied method do not create a context, so may get wrong message:
 
 sub print_trace {
+  local $\ = '';
   my $fh = shift;
   resetterm(1) if $fh eq $LINEINFO and $LINEINFO eq $OUT and $term_pid != $$;
   my @sub = dump_trace($_[0] + 1, $_[1]);
@@ -2181,12 +2235,16 @@ sub xterm_get_fork_TTY {
 # This example function resets $IN, $OUT itself
 sub os2_get_fork_TTY {
   local $^F = 40;                      # XXXX Fixme!
+  local $\ = '';
   my ($in1, $out1, $in2, $out2);
   # Having -d in PERL5OPT would lead to a disaster...
   local $ENV{PERL5OPT} = $ENV{PERL5OPT}    if $ENV{PERL5OPT};
   $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
@@ -2195,6 +2253,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,  '</dev/con' or warn "reopen stdin: $!"}
 use OS2::Process;
 
 my ($rl, $in) = (shift, shift);                # Read from $in and pass through
@@ -2273,6 +2333,7 @@ sub readline {
   if (@typeahead) {
     my $left = @typeahead;
     my $got = shift @typeahead;
+    local $\ = '';
     print $OUT "auto(-$left)", shift, $got, "\n";
     $term->AddHistory($got) 
       if length($got) > 1 and defined $term->Features->{addHistory};
@@ -2326,6 +2387,7 @@ sub option_val {
 
 sub parse_options {
     local($_)= @_;
+    local $\ = '';
     # too dangerous to let intuitive usage overwrite important things
     # defaultion should never be the default
     my %opt_needs_val = map { ( $_ => 1 ) } qw{
@@ -2434,6 +2496,7 @@ sub catch {
 sub warn {
     my($msg)= join("",@_);
     $msg .= ": $!\n" unless $msg =~ /\n$/;
+    local $\ = '';
     print $OUT $msg;
 }
 
@@ -2500,6 +2563,7 @@ sub tkRunning {
     if (${$term->Features}{tkRunning}) {
         return $term->tkRunning(@_);
     } else {
+       local $\ = '';
        print $OUT "tkRunning not supported by current ReadLine package.\n";
        0;
     }
@@ -2760,6 +2824,7 @@ I<Data Examination:>     B<expr>     Execute perl code, also see: B<s>,B<n>,B<t>
   B<S> [[B<!>]I<pat>]     List subroutine names [not] matching pattern
   B<V> [I<Pk> [I<Vars>]]  List Variables in Package.  Vars can be ~pattern or !pattern.
   B<X> [I<Vars>]       Same as \"B<V> I<current_package> [I<Vars>]\".
+  B<y> [I<n> [I<Vars>]]   List lexicals in higher scope <n>.  Vars same as B<V>.
 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
 END_SUM
                                # ')}}; # Fix balance of vi % matching
@@ -2927,6 +2992,7 @@ I<Data Examination:>     B<expr>     Execute perl code, also see: B<s>,B<n>,B<t>
   B<S> [[B<!>]I<pat>]     List subroutine names [not] matching pattern
   B<V> [I<Pk> [I<Vars>]]  List Variables in Package.  Vars can be ~pattern or !pattern.
   B<X> [I<Vars>]       Same as \"B<V> I<current_package> [I<Vars>]\".
+  B<y> [I<n> [I<Vars>]]   List lexicals in higher scope <n>.  Vars same as B<V>.
 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
 END_SUM
                                # ')}}; # Fix balance of vi % matching
@@ -2978,6 +3044,7 @@ sub print_help {
        . $Term::ReadLine::TermCap::rl_term_set[1]
     }gex;
 
+    local $\ = '';
     print $OUT $_;
 }
 
@@ -3006,6 +3073,7 @@ sub diesignal {
        &warn(Carp::longmess("Signal @_"));
     }
     else {
+       local $\ = '';
        print $DB::OUT "Got signal @_\n";
     }
     kill 'ABRT', $$;
@@ -3077,6 +3145,7 @@ sub warnLevel {
 }
 
 sub dieLevel {
+  local $\ = '';
   if (@_) {
     $prevdie = $SIG{__DIE__} unless $dieLevel;
     $dieLevel = shift;
@@ -3164,6 +3233,8 @@ sub methods_via {
   for $name (grep {defined &{${"${class}::"}{$_}}} 
             sort keys %{"${class}::"}) {
     next if $seen{ $name }++;
+    local $\ = '';
+    local $, = '';
     print $DB::OUT "$prepend$name\n";
   }
   return unless shift;         # Recurse?
@@ -3350,6 +3421,7 @@ sub db_complete {
 }
 
 sub end_report {
+  local $\ = '';
   print $OUT "Use `q' to quit or `R' to restart.  `h q' for details.\n"
 }