Upgrade B-Debug from 1.14 to 1.16

3 files changed, 57 insertions, 79 deletions

diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl
index 926af50a26..460f845c6c 100755
--- a/Porting/Maintainers.pl
+++ b/Porting/Maintainers.pl
@@ -258,7 +258,7 @@ use File::Glob qw(:case);
     'B::Debug' =>
 	{
 	'MAINTAINER'	=> 'rurban',
-	'DISTRIBUTION'	=> 'RURBAN/B-Debug-1.14.tar.gz',
+	'DISTRIBUTION'	=> 'RURBAN/B-Debug-1.16.tar.gz',
 	'FILES'		=> q[cpan/B-Debug],
 	'EXCLUDED'	=> [ qw( t/pod.t ) ],
 	'UPSTREAM'	=> 'cpan',
diff --git a/cpan/B-Debug/Debug.pm b/cpan/B-Debug/Debug.pm
index 7f2b6af97a..17f026d9fa 100644
--- a/cpan/B-Debug/Debug.pm
+++ b/cpan/B-Debug/Debug.pm
@@ -1,6 +1,6 @@
 package B::Debug;
 
-our $VERSION = '1.14';
+our $VERSION = '1.16';
 
 use strict;
 require 5.006;
@@ -15,9 +15,20 @@ if ($] < 5.009) {
 } else {
   B->import (qw(@optype @specialsv_name));
 }
-my $have_B_Flags;
+
+if ($] < 5.006002) {
+  eval q|sub B::GV::SAFENAME {
+    my $name = (shift())->NAME;
+    # The regex below corresponds to the isCONTROLVAR macro from toke.c
+    $name =~ s/^([\cA-\cZ\c\\c[\c]\c?\c_\c^])/"^".chr(64 ^ ord($1))/e;
+    return $name;
+  }|;
+}
+
+my ($have_B_Flags, $have_B_Flags_extra);
 if (!$ENV{PERL_CORE}){ # avoid CORE test crashes
   eval { require B::Flags and $have_B_Flags++ };
+  $have_B_Flags_extra++ if $have_B_Flags and $B::Flags::VERSION gt '0.03';
 }
 my %done_gv;
 
@@ -127,7 +138,7 @@ sub B::COP::debug {
 	cop_line	%d
 	cop_warnings	0x%x
 EOT
-  if ($] >= 5.007 and $] < 5.011) {
+  if ($] > 5.008 and $] < 5.011) {
     my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string;
     printf("	cop_io		%s\n", cstring($cop_io));
   }
@@ -167,11 +178,16 @@ sub B::SV::debug {
 	print class($sv), " = NULL\n";
 	return;
     }
-    printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS;
+    printf <<'EOT', class($sv), $$sv, $sv->REFCNT;
 %s (0x%x)
 	REFCNT		%d
 	FLAGS		0x%x
 EOT
+    printf "\tFLAGS\t\t0x%x", $sv->FLAGS;
+    if ($have_B_Flags) {
+      printf "\t%s", $have_B_Flags_extra ? $sv->flagspv(0) : $sv->flagspv;
+    }
+    print "\n";
 }
 
 sub B::RV::debug {
@@ -253,6 +269,13 @@ sub B::CV::debug {
 	OUTSIDE		0x%x
 EOT
     printf("\tOUTSIDE_SEQ\t%d\n", , $sv->OUTSIDE_SEQ) if $] > 5.007;
+    if ($have_B_Flags) {
+      my $SVt_PVCV = $] < 5.010 ? 12 : 13;
+      printf("\tCvFLAGS\t0x%x\t%s\n", $sv->CvFLAGS,
+	     $have_B_Flags_extra ? $sv->flagspv($SVt_PVCV) : $sv->flagspv);
+    } else {
+      printf("\tCvFLAGS\t0x%x\n", $sv->CvFLAGS);
+    }
     $start->debug if $start;
     $root->debug if $root;
     $gv->debug if $gv;
@@ -278,9 +301,14 @@ EOT
 	MAX		%d
 EOT
     }
-    printf <<'EOT', $av->AvFLAGS if $] < 5.009;
-	AvFLAGS		%d
-EOT
+    if ($] < 5.009) {
+      if ($have_B_Flags) {
+	printf("\tAvFLAGS\t0x%x\t%s\n", $av->AvFLAGS,
+	       $have_B_Flags_extra ? $av->flagspv(10) : $av->flagspv);
+      } else {
+	printf("\tAvFLAGS\t0x%x\n", $av->AvFLAGS);
+      }
+    }
 }
 
 sub B::GV::debug {
@@ -306,8 +334,14 @@ sub B::GV::debug {
 	CVGEN		%d
 	LINE		%d
 	FILE		%s
-	GvFLAGS		0x%x
 EOT
+    if ($have_B_Flags) {
+      my $SVt_PVGV = $] < 5.010 ? 13 : 9;
+      printf("\tGvFLAGS\t0x%x\t%s\n", $gv->GvFLAGS,
+	     $have_B_Flags_extra ? $gv->flagspv($SVt_PVGV) : $gv->flagspv);
+    } else {
+      printf("\tGvFLAGS\t0x%x\n", $gv->GvFLAGS);
+    }
     $sv->debug if $sv;
     $av->debug if $av;
     $cv->debug if $cv;
@@ -339,7 +373,8 @@ B::Debug - Walk Perl syntax tree, printing debug info about ops
 
 =head1 SYNOPSIS
 
-	perl -MO=Debug[,OPTIONS] foo.pl
+        perl -MO=Debug foo.pl
+        perl -MO=Debug,-exec foo.pl
 
 =head1 DESCRIPTION
 
@@ -350,60 +385,6 @@ See F<ext/B/README> and the newer L<B::Concise>, L<B::Terse>.
 With option -exec, walks tree in execute order,
 otherwise in basic order.
 
-=head1 Changes
-
-  1.13 2010-09-09 rurban
-	print name of op_type
-	print ppaddr consistent with other op addr
-	fix cop_io
-        omit cv->OUTSIDE_SEQ for 5.6
-	fix NULL specials
-	fix NV assertion for CV
-	stabilize tests for space in runperl path
-	fix t/debug.t test 7
-
-  1.12 2010-02-10 rurban
-	remove archlib installation cruft, and use the proper PM rule.
-	By Todd Rinaldo (toddr)
-
-  1.11 2008-07-14 rurban
-	avoid B::Flags in CORE tests not to crash on old XS in @INC
-
-  1.10 2008-06-28 rurban
-	require 5.006; Test::More not possible in 5.00505
-	our => my
-	
-  1.09 2008-06-18 rurban
-	minor META.yml syntax fix
-	5.8.0 ending nextstate test failure: be more tolerant
-	PREREQ_PM Test::More
-
-  1.08 2008-06-17 rurban
-	support 5.00558 - 5.6.2
-
-  1.07 2008-06-16 rurban
-	debug.t: fix strawberry perl quoting issue
-
-  1.06 2008-06-11 rurban
-	added B::Flags output
-	dual-life CPAN as B-Debug-1.06 and CORE
-	protect scalar(@array) if tied arrays leave out FETCHSIZE
-
-  1.05_03 2008-04-16 rurban
-	ithread fixes in B::AV
-	B-C-1.04_??
-
-  B-C-1.04_09 2008-02-24 rurban
-	support 5.8 (import Asmdata)
-
-  1.05_02 2008-02-21 rurban
-	added _printop
-	B-C-1.04_08 and CORE
-
-  1.05_01 2008-02-05 rurban
-	5.10 fix for op->seq
-	B-C-1.04_04
-
 =head1 AUTHOR
 
 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
@@ -412,7 +393,7 @@ Reini Urban C<rurban@cpan.org>
 =head1 LICENSE
 
 Copyright (c) 1996, 1997 Malcolm Beattie
-Copyright (c) 2008 Reini Urban
+Copyright (c) 2008, 2010 Reini Urban
 
 	This program is free software; you can redistribute it and/or modify
 	it under the terms of either:
diff --git a/cpan/B-Debug/t/debug.t b/cpan/B-Debug/t/debug.t
index fc73e06971..e523d3d565 100644
--- a/cpan/B-Debug/t/debug.t
+++ b/cpan/B-Debug/t/debug.t
@@ -27,14 +27,13 @@ use Config;
 use Test::More tests => 11;
 use B;
 use B::Debug;
+use File::Spec;
 
 my $a;
-my $Is_VMS = $^O eq 'VMS';
-my $Is_MacOS = $^O eq 'MacOS';
 my $X = $^X =~ m/\s/ ? qq{"$^X"} : $^X;
 
-my $path = join " ", map { qq["-I$_"] } @INC;
-my $redir = $Is_MacOS ? "" : "2>&1";
+my $path = join " ", map { qq["-I$_"] } (File::Spec->catfile("blib","lib"), @INC);
+my $redir = $^O =~ /VMS|MSWin32|MacOS/ ? "" : "2>&1";
 
 $a = `$X $path "-MO=Debug" -e 1 $redir`;
 like($a, qr/\bLISTOP\b.*\bOP\b.*\bCOP\b.*\bOP\b/s);
@@ -81,20 +80,18 @@ $a = `$X $path "-MO=Debug" -e "B::main_start->debug" $redir`;
 like($a, qr/\[OP_ENTER\]/m);
 
 # pass missing FETCHSIZE, fixed with 1.06
-my $tmp = "tmp.pl";
-open TMP, "> $tmp";
-print TMP 'BEGIN{tie @a, __PACKAGE__;sub TIEARRAY {bless{}} sub FETCH{1}};
-print $a[1]';
-close TMP;
-$a = `$X $path "-MO=Debug" $tmp $redir`;
-unlink $tmp;
+my $e = q(BEGIN{tie @a, __PACKAGE__;sub TIEARRAY {bless{}} sub FETCH{1}};print $a[1]);
+$a = `$X $path "-MO=Debug" -e"$e" $redir`;
 unlike($a, qr/locate object method "FETCHSIZE"/m);
 
 # NV assertion with CV, fixed with 1.13
-my $e = 'my $p=1;$g=2;sub p($){my $i=1;$i+1};print p(0)+$g;';
-$a = `$X $path "-MO=Debug" -e'$e' $redir`;
+my $tmp = "tmp.pl";
+open TMP, ">", $tmp;
+print TMP 'my $p=1;$g=2;sub p($){my $i=1;$i+1};print p(0)+$g;';
+close TMP;
+$a = `$X $path "-MO=Debug" $tmp $redir`;
 ok(! $?);
 unlike($a, qr/assertion "SvTYPE(sv) != SVt_PVCV" failed.*function: S_sv_2iuv_common/m);
 unlike($a, qr/Use of uninitialized value in print/m);
 
-END { unlink $tmp; }
+END { unlink $tmp if $tmp; }