[perl #121081] workaround different output on VMS

[perl5.git] / lib / perl5db.pl

diff --git a/lib/perl5db.pl b/lib/perl5db.pl
index 0705341..c1d6752 100644 (file)
--- a/lib/perl5db.pl
+++ b/lib/perl5db.pl
@@ -523,7 +523,7 @@ BEGIN {
 # Debugger for Perl 5.00x; perl5db.pl patch level:
 use vars qw($VERSION $header);
 
-$VERSION = '1.39_10';
+$VERSION = '1.43';
 
 $header = "perl5db.pl version $VERSION";
 
@@ -744,7 +744,7 @@ sub eval {
     # Since we're only saving $@, we only have to localize the array element
     # that it will be stored in.
     local $saved[0];    # Preserve the old value of $@
-    eval { DB::save() };
+    eval { &DB::save };
 
     # Now see whether we need to report an error back to the user.
     if ($at) {
@@ -1362,7 +1362,8 @@ the R command stuffed into the environment variables.
   PERLDB_RESTART   - flag only, contains no restart data itself.
   PERLDB_HIST      - command history, if it's available
   PERLDB_ON_LOAD   - breakpoints set by the rc file
-  PERLDB_POSTPONE  - subs that have been loaded/not executed, and have actions
+  PERLDB_POSTPONE  - subs that have been loaded/not executed,
+                     and have actions
   PERLDB_VISITED   - files that had breakpoints
   PERLDB_FILE_...  - breakpoints for a file
   PERLDB_OPT       - active options
@@ -1793,7 +1794,8 @@ sub _DB__determine_if_we_should_break
         # see if we should stop. If so, remove the one-time sigil.
         elsif ($stop) {
             $evalarg = "\$DB::signal |= 1 if do {$stop}";
-            DB::eval();
+            # The &-call is here to ascertain the mutability of @_.
+            &DB::eval;
             # If the breakpoint is temporary, then delete its enabled status.
             if ($dbline{$line} =~ s/;9($|\0)/$1/) {
                 _cancel_breakpoint_temp_enabled_status($filename, $line);
@@ -2500,7 +2502,7 @@ my %cmd_lookup =
         { t => 's', v => \&_DB__handle_restart_and_rerun_commands, },
         } qw(R rerun)),
     (map { $_ => {t => 'm', v => '_handle_cmd_wrapper_commands' }, }
-    qw(a A b B e E h i l L M o O P v w W)),
+        qw(a A b B e E h i l L M o O v w W)),
 );
 
 sub DB {
@@ -2562,7 +2564,8 @@ sub DB {
     # Last line in the program.
     $max = $#dbline;
 
-    _DB__determine_if_we_should_break(@_);
+    # The &-call is here to ascertain the mutability of @_.
+    &_DB__determine_if_we_should_break;
 
     # Preserve the current stop-or-not, and see if any of the W
     # (watch expressions) has changed.
@@ -2655,7 +2658,8 @@ If there are any preprompt actions, execute those as well.
     # If there's an action, do it now.
     if ($action) {
         $evalarg = $action;
-        DB::eval();
+        # The &-call is here to ascertain the mutability of @_.
+        &DB::eval;
     }
 
     # Are we nested another level (e.g., did we evaluate a function
@@ -2667,7 +2671,8 @@ If there are any preprompt actions, execute those as well.
 
         # Do any pre-prompt actions.
         foreach $evalarg (@$pre) {
-            DB::eval();
+            # The &-call is here to ascertain the mutability of @_.
+            &DB::eval;
         }
 
         # Complain about too much recursion if we passed the limit.
@@ -3082,7 +3087,8 @@ any variables we might want to address in the C<DB> package.
             $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd";
 
             # Run *our* eval that executes in the caller's context.
-            DB::eval();
+            # The &-call is here to ascertain the mutability of @_.
+            &DB::eval;
 
             # Turn off the one-time-dump stuff now.
             if ($onetimeDump) {
@@ -3128,7 +3134,8 @@ again.
 
         # Evaluate post-prompt commands.
         foreach $evalarg (@$post) {
-            DB::eval();
+            # The &-call is here to ascertain the mutability of @_.
+            &DB::eval;
         }
     }    # if ($single || $signal)
 
@@ -4087,9 +4094,6 @@ sub _print_frame_message {
 }
 
 sub DB::sub {
-    # Do not use a regex in this subroutine -> results in corrupted memory
-    # See: [perl #66110]
-
     # lock ourselves under threads
     lock($DBGR);
 
@@ -4262,7 +4266,9 @@ sub lsub : lvalue {
     $stack[-1] = $single;
 
     # Turn off all flags except single-stepping.
-    $single &= 1;
+    # Use local so the single-step value is popped back off the
+    # stack for us.
+    local $single = $single & 1;
 
     # If we've gotten really deeply recursed, turn on the flag that will
     # make us stop with the 'deep recursion' message.
@@ -4271,9 +4277,6 @@ sub lsub : lvalue {
     # If frame messages are on ...
     _print_frame_message($al);
 
-    # Pop the single-step value back off the stack.
-    $single |= $stack[ $stack_depth-- ];
-
     # call the original lvalue sub.
     &$sub;
 }
@@ -5431,7 +5434,8 @@ sub cmd_i {
     my $line = shift;
     foreach my $isa ( split( /\s+/, $line ) ) {
         $evalarg = $isa;
-        ($isa) = DB::eval();
+        # The &-call is here to ascertain the mutability of @_.
+        ($isa) = &DB::eval;
         no strict 'refs';
         print join(
             ', ',
@@ -6000,7 +6004,8 @@ sub _add_watch_expr {
     # in the user's context. This version can handle expressions which
     # return a list value.
     $evalarg = $expr;
-    my ($val) = join( ' ', DB::eval() );
+    # The &-call is here to ascertain the mutability of @_.
+    my ($val) = join( ' ', &DB::eval);
     $val = ( defined $val ) ? "'$val'" : 'undef';
 
     # Save the current value of the expression.
@@ -6138,7 +6143,11 @@ sub print_lineinfo {
     resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
     local $\ = '';
     local $, = '';
-    print $LINEINFO @_;
+    # $LINEINFO may be undef if $noTTY is set or some other issue.
+    if ($LINEINFO)
+    {
+        print {$LINEINFO} @_;
+    }
 } ## end sub print_lineinfo
 
 =head2 C<postponed_sub>
@@ -9030,7 +9039,7 @@ BEGIN {    # This does not compile, alas. (XXX eh?)
 
     # This defines the point at which you get the 'deep recursion'
     # warning. It MUST be defined or the debugger will not load.
-    $deep = 100;
+    $deep = 1000;
 
     # Number of lines around the current one that are shown in the
     # 'w' command.
@@ -9376,7 +9385,7 @@ If the package is C<::> (C<main>), create an empty list; if it's something else,
 =cut
 
         push @out, map "$prefix$_", grep /^\Q$text/,
-          ( grep /^_?[a-zA-Z]/, keys %$pack ),
+          ( grep /^_?[a-zA-Z]/, do { no strict 'refs'; keys %$pack } ),
           ( $pack eq '::' ? () : ( grep /::$/, keys %:: ) );
 
 =item *
@@ -10122,7 +10131,8 @@ sub cmd_pre580_W {
         # Get the current value of the expression.
         # Doesn't handle expressions returning list values!
         $evalarg = $1;
-        my ($val) = DB::eval();
+        # The &-call is here to ascertain the mutability of @_.
+        my ($val) = &DB::eval;
         $val = ( defined $val ) ? "'$val'" : 'undef';
 
         # Save it.