X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fperl5db.pl;h=d0a712534ae1a57635ec783943b7c37a98ac56ea;hb=12c5d27a30700a469ee068632587ba3fb5c99a7d;hp=26a3309ca1b340ba94caeba55caf8decf4b15a21;hpb=3e6ffef9cf30ba48a3263e20d99f968b825f0ba5;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/perl5db.pl b/lib/perl5db.pl
index 26a3309..d0a7125 100644
--- 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.