Fixes for ext/compress

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

diff --git a/lib/perl5db.pl b/lib/perl5db.pl
index 41e7c52..765b0e5 100644 (file)
--- a/lib/perl5db.pl
+++ b/lib/perl5db.pl
@@ -511,7 +511,7 @@ package DB;
 BEGIN {eval 'use IO::Handle'}; # Needed for flush only? breaks under miniperl
 
 # Debugger for Perl 5.00x; perl5db.pl patch level:
-$VERSION = 1.30;
+$VERSION = 1.32;
 
 $header = "perl5db.pl version $VERSION";
 
@@ -941,6 +941,14 @@ sub eval {
 #   + Added macosx_get_fork_TTY support 
 # Changes: 1.30: Mar 06, 2007 Andreas Koenig <andk@cpan.org>
 #   + Added HistFile, HistSize
+# Changes: 1.31
+#   + Remove support for assertions and -A
+#   + stop NEXT::AUTOLOAD from emitting warnings under the debugger. RT #25053
+#   + "update for Mac OS X 10.5" [finding the tty device]
+#   + "What I needed to get the forked debugger to work" [on VMS]
+#   + [perl #57016] debugger: o warn=0 die=0 ignored
+#   + Note, but don't use, PERLDBf_SAVESRC
+#   + Fix #7013: lvalue subs not working inside debugger
 ########################################################################
 
 =head1 DEBUGGER INITIALIZATION
@@ -3776,6 +3784,69 @@ sub sub {
     } ## end else [ if (wantarray)
 } ## end sub sub
 
+sub lsub : lvalue {
+
+       # lock ourselves under threads
+       lock($DBGR);
+
+    # Whether or not the autoloader was running, a scalar to put the
+    # sub's return value in (if needed), and an array to put the sub's
+    # return value in (if needed).
+    my ( $al, $ret, @ret ) = "";
+       if ($sub =~ /^threads::new$/ && $ENV{PERL5DB_THREADED}) {
+               print "creating new thread\n";
+       }
+
+    # If the last ten characters are C'::AUTOLOAD', note we've traced
+    # into AUTOLOAD for $sub.
+    if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) {
+        $al = " for $$sub";
+    }
+
+    # We stack the stack pointer and then increment it to protect us
+    # from a situation that might unwind a whole bunch of call frames
+    # at once. Localizing the stack pointer means that it will automatically
+    # unwind the same amount when multiple stack frames are unwound.
+    local $stack_depth = $stack_depth + 1;    # Protect from non-local exits
+
+    # Expand @stack.
+    $#stack = $stack_depth;
+
+    # Save current single-step setting.
+    $stack[-1] = $single;
+
+    # Turn off all flags except single-stepping.
+    $single &= 1;
+
+    # If we've gotten really deeply recursed, turn on the flag that will
+    # make us stop with the 'deep recursion' message.
+    $single |= 4 if $stack_depth == $deep;
+
+    # If frame messages are on ...
+    (
+        $frame & 4    # Extended frame entry message
+        ? (
+            print_lineinfo( ' ' x ( $stack_depth - 1 ), "in  " ),
+
+            # Why -1? But it works! :-(
+            # Because print_trace will call add 1 to it and then call
+            # dump_trace; this results in our skipping -1+1 = 0 stack frames
+            # in dump_trace.
+            print_trace( $LINEINFO, -1, 1, 1, "$sub$al" )
+          )
+        : print_lineinfo( ' ' x ( $stack_depth - 1 ), "entering $sub$al\n" )
+
+          # standard frame entry message
+      )
+      if $frame;
+
+    # Pop the single-step value back off the stack.
+    $single |= $stack[ $stack_depth-- ];
+
+    # call the original lvalue sub.
+    &$sub;
+}
+
 =head1 EXTENDED COMMAND HANDLING AND THE COMMAND API
 
 In Perl 5.8.0, there was a major realignment of the commands and what they did,
@@ -7927,26 +7998,28 @@ sub methods_via {
     # This is a package that is contributing the methods we're about to print.
     my $prefix  = shift;
     my $prepend = $prefix ? "via $prefix: " : '';
+    my @to_print;
+
+    # Extract from all the symbols in this class.
+    while (my ($name, $glob) = each %{"${class}::"}) {
+       # references directly in the symbol table are Proxy Constant
+       # Subroutines, and are by their very nature defined
+       # Otherwise, check if the thing is a typeglob, and if it is, it decays
+       # to a subroutine reference, which can be tested by defined.
+       # $glob might also be the value -1  (from sub foo;)
+       # or (say) '$$' (from sub foo ($$);)
+       # \$glob will be SCALAR in both cases.
+       if ((ref $glob || ($glob && ref \$glob eq 'GLOB' && defined &$glob))
+           && !$seen{$name}++) {
+           push @to_print, "$prepend$name\n";
+       }
+    }
 
-    my $name;
-    for $name (
-
-        # Keep if this is a defined subroutine in this class.
-        grep { defined &{ ${"${class}::"}{$_} } }
-
-        # Extract from all the symbols in this class.
-        sort keys %{"${class}::"}
-      )
     {
-
-        # If we printed this already, skip it.
-        next if $seen{$name}++;
-
-        # Print the new method name.
-        local $\ = '';
-        local $, = '';
-        print $DB::OUT "$prepend$name\n";
-    } ## end for $name (grep { defined...
+       local $\ = '';
+       local $, = '';
+       print $DB::OUT $_ foreach sort @to_print;
+    }
 
     # If the $crawl_upward argument is false, just quit here.
     return unless shift;