Sys::Syslog: hyphens in hostnames

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

diff --git a/lib/perl5db.pl b/lib/perl5db.pl
index 9718fed..c09238d 100644 (file)
--- a/lib/perl5db.pl
+++ b/lib/perl5db.pl
@@ -2,8 +2,8 @@ package DB;
 
 # Debugger for Perl 5.00x; perl5db.pl patch level:
 
-$VERSION = 0.9909;
-$header = "perl5db.pl patch level $VERSION";
+$VERSION = 1.00;
+$header = "perl5db.pl version $VERSION";
 
 # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
 # Latest version available: ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
@@ -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 = (
@@ -272,6 +273,10 @@ if (exists $ENV{PERLDB_RESTART}) {
   }
   @INC = get_list("PERLDB_INC");
   @ini_INC = @INC;
+  $pretype = [get_list("PERLDB_PRETYPE")];
+  $pre = [get_list("PERLDB_PRE")];
+  $post = [get_list("PERLDB_POST")];
+  @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
 }
 
 if ($notty) {
@@ -285,7 +290,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";
@@ -340,6 +345,8 @@ if (defined &afterinit) {   # May be defined in $rcfile
   &afterinit();
 }
 
+$I_m_init = 1;
+
 ############################################################ Subroutines
 
 sub DB {
@@ -899,6 +906,10 @@ sub DB {
                          }
                        }
                        set_list("PERLDB_POSTPONE", %postponed);
+                       set_list("PERLDB_PRETYPE", @$pretype);
+                       set_list("PERLDB_PRE", @$pre);
+                       set_list("PERLDB_POST", @$post);
+                       set_list("PERLDB_TYPEAHEAD", @typeahead);
                        $ENV{PERLDB_RESTART} = 1;
                        #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
                        exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
@@ -1374,6 +1385,7 @@ sub setterm {
     if ($term->Features->{setHistory} and "@hist" ne "?") {
       $term->SetHistory(@hist);
     }
+    ornaments($ornaments) if defined $ornaments;
 }
 
 sub readline {
@@ -1500,28 +1512,25 @@ sub warn {
 
 sub TTY {
     if ($term) {
-       &warn("Too late to set TTY!\n") if @_;
-    } else {
-       $tty = shift if @_;
-    }
+       &warn("Too late to set TTY, enabled on next `R'!\n") if @_;
+    } 
+    $tty = shift if @_;
     $tty or $console;
 }
 
 sub noTTY {
     if ($term) {
-       &warn("Too late to set noTTY!\n") if @_;
-    } else {
-       $notty = shift if @_;
+       &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
     }
+    $notty = shift if @_;
     $notty;
 }
 
 sub ReadLine {
     if ($term) {
-       &warn("Too late to set ReadLine!\n") if @_;
-    } else {
-       $rl = shift if @_;
+       &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
     }
+    $rl = shift if @_;
     $rl;
 }
 
@@ -1536,10 +1545,9 @@ sub tkRunning {
 
 sub NonStop {
     if ($term) {
-       &warn("Too late to set up NonStop mode!\n") if @_;
-    } else {
-       $runnonstop = shift if @_;
+       &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
     }
+    $runnonstop = shift if @_;
     $runnonstop;
 }
 
@@ -1563,6 +1571,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;
@@ -1679,9 +1697,10 @@ 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.
+               ReadLine, and NonStop there (or use `R' after you set them).
 < command      Define Perl command to run before each prompt.
 << command     Add to the list of Perl commands to run before each prompt.
 > command      Define Perl command to run after each prompt.
@@ -1828,7 +1847,8 @@ sub dieLevel {
       $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
       #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
       print $OUT "Stack dump during die enabled", 
-        ( $dieLevel == 1 ? " outside of evals" : ""), ".\n";
+        ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
+         if $I_m_init;
       print $OUT "Dump printed too.\n" if $dieLevel > 2;
     } else {
       $SIG{__DIE__} = $prevdie;
@@ -2006,7 +2026,9 @@ sub db_complete {
   return $term->filename_list($text); # filenames
 }
 
-sub end_report { print $OUT "Use `q' to quit and `R' to restart. `h q' for details.\n" }
+sub end_report {
+  print $OUT "Use `q' to quit or `R' to restart.  `h q' for details.\n"
+}
 
 END {
   $finished = $inhibit_exit;   # So that some keys may be disabled.
@@ -2018,7 +2040,7 @@ END {
 package DB::fake;
 
 sub at_exit {
-  "Debuggee terminated. Use `q' to quit and `R' to restart.";
+  "Debugged program terminated.  Use `q' to quit or `R' to restart.";
 }
 
 package DB;                    # Do not trace this 1; below!