[perl #130410] Import B-Debug 1.25 from CPAN
authorDagfinn Ilmari Mannsåker <ilmari@ilmari.org>
Thu, 27 Jul 2017 10:06:35 +0000 (11:06 +0100)
committerDagfinn Ilmari Mannsåker <ilmari@ilmari.org>
Thu, 27 Jul 2017 10:11:19 +0000 (11:11 +0100)
This marks it as deprecated in core so it can be removed in 5.30.

Porting/Maintainers.pl
cpan/B-Debug/Debug.pm

index 961f23c..e577fd6 100755 (executable)
@@ -173,7 +173,7 @@ use File::Glob qw(:case);
     },
 
     'B::Debug' => {
-        'DISTRIBUTION' => 'RURBAN/B-Debug-1.24.tar.gz',
+        'DISTRIBUTION' => 'RURBAN/B-Debug-1.25.tar.gz',
         'FILES'        => q[cpan/B-Debug],
         'EXCLUDED'     => ['t/pod.t'],
     },
index e295635..b49041f 100644 (file)
@@ -1,10 +1,11 @@
 package B::Debug;
 
-our $VERSION = '1.24';
+our $VERSION = '1.25';
+BEGIN { if ($] >= 5.027001) { require deprecate; import deprecate; } }
 
 use strict;
 require 5.006;
-use B qw(peekop class walkoptree walkoptree_exec
+use B qw(peekop walkoptree walkoptree_exec
          main_start main_root cstring sv_undef SVf_NOK SVf_IOK);
 use Config;
 my (@optype, @specialsv_name);
@@ -37,7 +38,7 @@ sub _printop {
   my $addr = ${$op} ? $op->ppaddr : '';
   $addr =~ s/^PL_ppaddr// if $addr;
   if (${$op}) {
-    return sprintf "0x%08x %6s %s", ${$op}, class($op), $addr;
+    return sprintf "0x%08x %6s %s", ${$op}, B::class($op), $addr;
   } else {
     return sprintf "0x%x %6s %s", ${$op}, '', $addr;
   }
@@ -45,7 +46,7 @@ sub _printop {
 
 sub B::OP::debug {
     my ($op) = @_;
-    printf <<'EOT', class($op), $$op, _printop($op), _printop($op->next), _printop($op->sibling), $op->targ, $op->type, $op->name;
+    printf <<'EOT', B::class($op), $$op, _printop($op), _printop($op->next), _printop($op->sibling), $op->targ, $op->type, $op->name;
 %s (0x%lx)
        op_ppaddr       %s
        op_next         %s
@@ -64,13 +65,18 @@ EOT
     }
     if ($have_B_Flags) {
         printf <<'EOT', $op->flags, $op->flagspv, $op->private, $op->privatepv;
-       op_flags        %d      %s
-       op_private      %d      %s
+       op_flags        %u      %s
+       op_private      %u      %s
 EOT
     } else {
         printf <<'EOT', $op->flags, $op->private;
-       op_flags        %d
-       op_private      %d
+       op_flags        %u
+       op_private      %u
+EOT
+    }
+    if ($op->can('rettype')) {
+        printf <<'EOT', $op->rettype;
+       op_rettype      %u
 EOT
     }
 }
@@ -143,7 +149,7 @@ sub B::COP::debug {
        cop_warnings    0x%x
 EOT
   if ($] > 5.008 and $] < 5.011) {
-    my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string;
+    my $cop_io = B::class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string;
     printf("   cop_io          %s\n", cstring($cop_io));
   }
 }
@@ -167,6 +173,16 @@ sub B::METHOP::debug {
     }
 }
 
+sub B::UNOP_AUX::debug {
+    my ($op) = @_;
+    $op->B::OP::debug();
+    # string and perl5 aux_list needs the cv
+    # cperl has aux, Concise,-debug leaves it empty
+    if ($op->can('aux')) {
+        printf "\top_aux\t%s\n", cstring($op->aux);
+    }
+}
+
 sub B::PVOP::debug {
     my ($op) = @_;
     $op->B::OP::debug();
@@ -191,10 +207,10 @@ sub B::NULL::debug {
 sub B::SV::debug {
     my ($sv) = @_;
     if (!$$sv) {
-       print class($sv), " = NULL\n";
+       print B::class($sv), " = NULL\n";
        return;
     }
-    printf <<'EOT', class($sv), $$sv, $sv->REFCNT;
+    printf <<'EOT', B::class($sv), $$sv, $sv->REFCNT;
 %s (0x%x)
        REFCNT          %d
 EOT
@@ -266,38 +282,43 @@ sub B::BM::debug {
 }
 
 sub B::CV::debug {
-    my ($sv) = @_;
-    $sv->B::PVNV::debug();
-    my ($stash) = $sv->STASH;
-    my ($start) = $sv->START;
-    my ($root)  = $sv->ROOT;
-    my ($padlist) = $sv->PADLIST;
-    my ($file) = $sv->FILE;
-    my ($gv) = $sv->GV;
+    my ($cv) = @_;
+    $cv->B::PVNV::debug();
+    my $stash = $cv->STASH;
+    my $start = $cv->START;
+    my $root  = $cv->ROOT;
+    my $padlist = $cv->PADLIST;
+    my $file = $cv->FILE;
+    my $gv;
     printf <<'EOT', $$stash, $$start, $$root;
        STASH           0x%x
        START           0x%x
        ROOT            0x%x
 EOT
-    if ( $]>5.017 && ($sv->FLAGS & 0x40000)) { #lexsub
-      printf("\tNAME\t%%s\n", $sv->NAME);
+    if ($cv->can('NAME_HEK') && $cv->NAME_HEK) {
+        printf("\tNAME\t%%s\n", $cv->NAME_HEK);
+    }
+    elsif ( $]>5.017 && ($cv->FLAGS & 0x40000)) { #lexsub
+        printf("\tNAME\t%%s\n", $cv->NAME_HEK);
     } else {
-      printf("\tGV\t%0x%x\t%s\n", $$gv, $gv->SAFENAME);
+        $gv = $cv->GV;
+        printf("\tGV\t%0x%x\t%s\n", $$gv, $gv->SAFENAME);
     }
-    printf <<'EOT', $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE};
+    printf <<'EOT', $file, $cv->DEPTH, $padlist, ${$cv->OUTSIDE};
        FILE            %s
        DEPTH           %d
        PADLIST         0x%x
        OUTSIDE         0x%x
 EOT
-    printf("\tOUTSIDE_SEQ\t%d\n", $sv->OUTSIDE_SEQ) if $] > 5.007;
+    printf("\tOUTSIDE_SEQ\t%d\n", $cv->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);
+        my $SVt_PVCV = $] < 5.010 ? 12 : 13;
+        printf("\tCvFLAGS\t0x%x\t%s\n", $cv->CvFLAGS,
+               $have_B_Flags_extra ? $cv->flagspv($SVt_PVCV) : $cv->flagspv);
     } else {
-      printf("\tCvFLAGS\t0x%x\n", $sv->CvFLAGS);
+        printf("\tCvFLAGS\t0x%x\n", $cv->CvFLAGS);
     }
+    printf("\tSIGOP\t0x%x\n", $cv->SIGOP) if $cv->can('SIGOP');
     $start->debug if $start;
     $root->debug if $root;
     $gv->debug if $gv;
@@ -316,7 +337,7 @@ sub _array_debug {
     my (@array) = eval { $av->ARRAY; };
     print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";
     my $fill = eval { scalar(@array) };
-    if ($Config{'useithreads'} && class($av) ne 'PADLIST') {
+    if ($Config{'useithreads'} && B::class($av) ne 'PADLIST') {
       printf <<'EOT', $fill, $av->MAX, $av->OFF;
        FILL            %d
        MAX             %d
@@ -382,7 +403,7 @@ sub B::SPECIAL::debug {
 
 sub B::PADLIST::debug {
     my ($padlist) = @_;
-    printf <<'EOT', class($padlist), $$padlist, $padlist->REFCNT;
+    printf <<'EOT', B::class($padlist), $$padlist, $padlist->REFCNT;
 %s (0x%x)
        REFCNT          %d
 EOT
@@ -415,7 +436,7 @@ B::Debug - Walk Perl syntax tree, printing debug info about ops
 
 =head1 DESCRIPTION
 
-See F<ext/B/README> and the newer L<B::Concise>, L<B::Terse>.
+See F<ext/B/README> and the newer L<B::Concise>.
 
 =head1 OPTIONS
 
@@ -424,7 +445,7 @@ otherwise in basic order.
 
 =head1 AUTHOR
 
-Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
+Malcolm Beattie, C<retired>
 Reini Urban C<rurban@cpan.org>
 
 =head1 LICENSE