Add a few helpers to B for INVLIST

This commit provide some basic method
to access to internal fields from one
INVLIST: SVt_INVLIST

- prev_index
- is_offset
- array_len
- get_invlist_array

This allows B::C to be walk and save invlists.

1 files changed, 65 insertions, 0 deletions

diff --git a/ext/B/t/invlist.t b/ext/B/t/invlist.t
new file mode 100644
index 0000000000..a719d04cd2
--- /dev/null
+++ b/ext/B/t/invlist.t
@@ -0,0 +1,65 @@
+#!./perl
+
+BEGIN {
+    unshift @INC, 't';
+    require Config;
+    if ( ( $Config::Config{'extensions'} !~ /\bB\b/ ) ) {
+        print "1..0 # Skip -- Perl configured without B module\n";
+        exit 0;
+    }
+}
+
+use strict;
+use warnings;
+use Test::More;
+
+if ( $Config::Config{useithreads} ) {
+    plan( skip_all => "Perl compiled with ithreads... no invlist in the example");
+}
+
+use_ok('B');
+
+# Somewhat minimal tests.
+
+my $found_invlist;
+
+# we are going to walk this sub
+sub check {
+    "ABCD" !~ tr/\0-\377//c;    # this is using the Latin1_invlist
+}
+
+sub B::OP::visit {
+    my $op = shift;
+
+    note ref($op) . " ; NAME: ", $op->name, " ; TYPE: ", $op->type;
+
+    return unless ref $op eq 'B::SVOP' && $op->name eq 'trans';
+
+    my $sv = $op->sv;
+
+    note "SV: ", ref $sv, " = " . $sv->LEN . " " . $sv->CUR;
+    foreach my $elt ( $sv->ARRAY ) {
+        next unless ref $elt eq 'B::INVLIST';
+        $found_invlist = 1;
+        my $invlist = $elt;
+
+        is $invlist->prev_index, 0, "prev_index=0";
+        is $invlist->is_offset,  0, "is_offset = 0 (false)";
+
+        my @array = $invlist->get_invlist_array;
+        is scalar @array, 2, "invlist array size is 2" or diag explain \@array;
+        is $array[0], 0,   "PL_Latin1 first value in the invlist array is 0"  or diag explain \@array;
+        is $array[1], 256, "PL_Latin1 second value in the invlist array is 0" or diag explain \@array;
+
+        is $invlist->array_len(), 2, "PL_Latin1 array length is 2";
+    }
+
+    return;
+}
+
+my $op = B::svref_2object( \*main::check );
+B::walkoptree( $op->CV->ROOT, 'visit' );
+
+ok $found_invlist, "visited one INVLIST";
+
+done_testing();