Refresh CGI to 2.34

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

diff --git a/lib/perl5db.pl b/lib/perl5db.pl
index 26a3309..d0a7125 100644 (file)
--- a/lib/perl5db.pl
+++ b/lib/perl5db.pl
@@ -2,7 +2,7 @@ package DB;
 
 # Debugger for Perl 5.00x; perl5db.pl patch level:
 
-$VERSION = 0.9907;
+$VERSION = 0.9911;
 $header = "perl5db.pl patch level $VERSION";
 
 # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
@@ -177,7 +177,7 @@ $inhibit_exit = $option{PrintRet} = 1;
                  compactDump veryCompact quote HighBit undefPrint
                  globPrint PrintRet UsageOnly frame AutoTrace
                  TTY noTTY ReadLine NonStop LineInfo maxTraceLen
-                 recallCommand ShellBang pager tkRunning
+                 recallCommand ShellBang pager tkRunning ornaments
                  signalLevel warnLevel dieLevel inhibit_exit);
 
 %optionVars    = (
@@ -211,6 +211,7 @@ $inhibit_exit = $option{PrintRet} = 1;
                  warnLevel     => \&warnLevel,
                  dieLevel      => \&dieLevel,
                  tkRunning     => \&tkRunning,
+                 ornaments     => \&ornaments,
                 );
 
 %optionRequire = (
@@ -261,7 +262,8 @@ if (exists $ENV{PERLDB_RESTART}) {
   %postponed = get_list("PERLDB_POSTPONE");
   my @had_breakpoints= get_list("PERLDB_VISITED");
   for (0 .. $#had_breakpoints) {
-    %{$postponed_file{$had_breakpoints[$_]}} = get_list("PERLDB_FILE_$_");
+    my %pf = get_list("PERLDB_FILE_$_");
+    $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
   }
   my %opt = get_list("PERLDB_OPT");
   my ($opt,$val);
@@ -284,7 +286,7 @@ if ($notty) {
 
   if (-e "/dev/tty") {
     $console = "/dev/tty";
-  } elsif (-e "con") {
+  } elsif (-e "con" or $^O eq 'MSWin32') {
     $console = "con";
   } else {
     $console = "sys\$command";
@@ -410,7 +412,9 @@ sub DB {
     $evalarg = $action, &eval if $action;
     if ($single || $was_signal) {
        local $level = $level + 1;
-       map {$evalarg = $_, &eval} @$pre;
+       foreach $evalarg (@$pre) {
+         &eval;
+       }
        print $OUT $#stack . " levels deep in subroutine calls!\n"
          if $single & 4;
        $start = $line;
@@ -649,12 +653,11 @@ sub DB {
                        print $OUT "Postponed breakpoints in files:\n";
                        my ($file, $line);
                        for $file (keys %postponed_file) {
-                         my %db = %{$postponed_file{$file}};
-                         next unless keys %db;
+                         my $db = $postponed_file{$file};
                          print $OUT " $file:\n";
-                         for $line (sort {$a <=> $b} keys %db) {
+                         for $line (sort {$a <=> $b} keys %$db) {
                                print $OUT "  $line:\n";
-                               my ($stop,$action) = split(/\0/, $db{$line});
+                               my ($stop,$action) = split(/\0/, $$db{$line});
                                print $OUT "    break if (", $stop, ")\n"
                                  if $stop;
                                print $OUT "    action:  ", $action, "\n"
@@ -855,12 +858,12 @@ sub DB {
                        for (0 .. $#had_breakpoints) {
                          my $file = $had_breakpoints[$_];
                          *dbline = $main::{'_<' . $file};
-                         next unless %dbline or %{$postponed_file{$file}};
+                         next unless %dbline or $postponed_file{$file};
                          (push @hard, $file), next 
                            if $file =~ /^\(eval \d+\)$/;
                          my @add;
                          @add = %{$postponed_file{$file}}
-                           if %{$postponed_file{$file}};
+                           if $postponed_file{$file};
                          set_list("PERLDB_FILE_$_", %dbline, @add);
                        }
                        for (@hard) { # Yes, really-really...
@@ -1074,7 +1077,9 @@ sub DB {
            }
        }                       # CMD:
        $exiting = 1 unless defined $cmd;
-        map {$evalarg = $_; &eval} @$post;
+       foreach $evalarg (@$post) {
+         &eval;
+       }
     }                          # if ($single || $signal)
     ($@, $!, $,, $/, $\, $^W) = @saved;
     ();
@@ -1185,14 +1190,14 @@ sub postponed {
   $signal = 1, print $OUT "'$filename' loaded...\n"
     if $break_on_load{$filename};
   print $LINEINFO ' ' x $#stack, "Package $filename.\n" if $frame;
-  return unless %{$postponed_file{$filename}};
+  return unless $postponed_file{$filename};
   $had_breakpoints{$filename}++;
   #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
   my $key;
   for $key (keys %{$postponed_file{$filename}}) {
     $dbline{$key} = $ {$postponed_file{$filename}}{$key};
   }
-  undef %{$postponed_file{$filename}};
+  delete $postponed_file{$filename};
 }
 
 sub dumpit {
@@ -1370,6 +1375,7 @@ sub setterm {
     if ($term->Features->{setHistory} and "@hist" ne "?") {
       $term->SetHistory(@hist);
     }
+    ornaments($ornaments) if defined $ornaments;
 }
 
 sub readline {
@@ -1559,6 +1565,16 @@ sub shellBang {
     $psh;
 }
 
+sub ornaments {
+  if (defined $term) {
+    local ($warnLevel,$dieLevel) = (0, 1);
+    return '' unless $term->Features->{ornaments};
+    eval { $term->ornaments(@_) } || '';
+  } else {
+    $ornaments = shift;
+  }
+}
+
 sub recallCommand {
     if (@_) {
        $rc = quotemeta shift;
@@ -1675,6 +1691,7 @@ O [opt[=val]] [opt\"val\"] [opt?]...
          frame    affects printing messages on entry and exit from subroutines.
          AutoTrace affects printing messages on every possible breaking point.
         maxTraceLen gives maximal length of evals/args listed in stack trace.
+        ornaments affects screen appearance of the command line.
                During startup options are initialized from \$ENV{PERLDB_OPTS}.
                You can put additional initialization options TTY, noTTY,
                ReadLine, and NonStop there.