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.

diff --git a/MANIFEST b/MANIFEST
index 6a81fb5..003b220 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -4117,6 +4117,7 @@ ext/B/t/f_map                     code from perldoc -f map
 ext/B/t/f_map.t                        converted to optreeCheck()s
 ext/B/t/f_sort                 optree test raw material
 ext/B/t/f_sort.t               optree test raw material
+ext/B/t/invlist.t              test B::INVLIST
 ext/B/t/o.t            See if O works
 ext/B/t/optree_check.t         test OptreeCheck apparatus
 ext/B/t/optree_concise.t       more B::Concise tests

diff --git a/ext/B/B.pm b/ext/B/B.pm
index 551f230..ef23af6 100644 (file)
--- a/ext/B/B.pm
+++ b/ext/B/B.pm
@@ -20,7 +20,7 @@ sub import {
 # walkoptree comes from B.xs
 
 BEGIN {
-    $B::VERSION = '1.81';
+    $B::VERSION = '1.82';
     @B::EXPORT_OK = ();
 
     # Our BOOT code needs $VERSION set, and will append to @EXPORT_OK.
@@ -559,9 +559,9 @@ The inheritance hierarchy mimics the underlying C "inheritance":
                 +------------+------------+
                 |            |            |
               B::PV        B::IV        B::NV
-                  \         /           /
-                   \       /           /
-                    B::PVIV           /
+               /  \         /           /
+              /    \       /           /
+        B::INVLIST  B::PVIV           /
                          \           /
                           \         /
                            \       /
@@ -735,6 +735,32 @@ in the MAGIC.
 
 =back
 
+=head2 B::INVLIST Methods
+
+=over 4
+
+=item prev_index
+
+Returns the cache result of previous invlist_search() (internal usage)
+
+=item is_offset
+
+Returns a boolean value (0 or 1) to know if the invlist is using an offset.
+When false the list begins with the code point U+0000.
+When true the list begins with the following elements.
+
+=item array_len
+
+Returns an integer with the size of the array used to define the invlist.
+
+=item get_invlist_array
+
+This method returns a list of integers representing the array used by the
+invlist.
+Note: this cannot be used while in middle of iterating on an invlist and croaks.
+
+=back
+
 =head2 B::PVLV Methods
 
 =over 4

diff --git a/ext/B/B.xs b/ext/B/B.xs
index ae2393e..e6e3fb8 100644 (file)
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -13,6 +13,9 @@
 #include "perl.h"
 #include "XSUB.h"
 
+/* #include "invlist_inline.h" */
+#define FROM_INTERNAL_SIZE(x) ((x)/ sizeof(UV))
+
 #ifdef PerlIO
 typedef PerlIO * InputStream;
 #else
@@ -472,6 +475,7 @@ typedef PADLIST     *B__PADLIST;
 typedef PADNAMELIST *B__PADNAMELIST;
 typedef PADNAME        *B__PADNAME;
 
+typedef INVLIST  *B__INVLIST;
 
 #ifdef MULTIPLICITY
 #  define ASSIGN_COMMON_ALIAS(prefix, var) \
@@ -1631,6 +1635,71 @@ REGEX(sv)
                PUSHi(PTR2IV(sv));
        }
 
+MODULE = B  PACKAGE = B::INVLIST    PREFIX = Invlist
+
+int
+prev_index(invlist)
+       B::INVLIST      invlist
+    CODE:
+        RETVAL = ((XINVLIST*) SvANY(invlist))->prev_index;
+    OUTPUT:
+       RETVAL
+
+int
+is_offset(invlist)
+       B::INVLIST      invlist
+    CODE:
+        RETVAL = ((XINVLIST*) SvANY(invlist))->is_offset == TRUE ? 1 : 0;
+    OUTPUT:
+       RETVAL
+
+unsigned int
+array_len(invlist)
+       B::INVLIST      invlist
+    CODE:
+    {
+        if (SvCUR(invlist) > 0)
+            RETVAL = FROM_INTERNAL_SIZE(SvCUR(invlist)); /* - ((XINVLIST*) SvANY(invlist))->is_offset; */ /* <- for iteration */
+        else
+            RETVAL = 0;
+    }
+    OUTPUT:
+       RETVAL
+
+void
+get_invlist_array(invlist)
+    B::INVLIST      invlist
+PPCODE:
+  {
+    /* should use invlist_is_iterating but not public for now */
+    bool is_iterating = ( (XINVLIST*) SvANY(invlist) )->iterator < (STRLEN) UV_MAX;
+
+    if (is_iterating) {
+        croak( "Can't access inversion list: in middle of iterating" );
+    }
+
+    {
+        UV pos;
+        UV len;
+
+        len = 0;
+        /* should use _invlist_len (or not) */
+        if (SvCUR(invlist) > 0)
+            len = FROM_INTERNAL_SIZE(SvCUR(invlist)); /* - ((XINVLIST*) SvANY(invlist))->is_offset; */ /* <- for iteration */
+
+        if ( len > 0 ) {
+            UV *array = (UV*) SvPVX( invlist ); /* invlist_array */
+
+            EXTEND(SP, (int) len);
+
+            for ( pos = 0; pos < len; ++pos ) {
+                PUSHs( sv_2mortal( newSVuv(array[pos]) ) );
+            }
+        }
+    }
+
+  }
+
 MODULE = B     PACKAGE = B::PV
 
 void
@@ -2206,7 +2275,7 @@ PadnameTYPE(pn)
        B::PADLIST::outid       = PL_outid_ix
     PREINIT:
        char *ptr;
-       SV *ret;
+       SV *ret = NULL;
     PPCODE:
        ptr = (ix & 0xFFFF) + (char *)pn;
        switch ((U8)(ix >> 16)) {

diff --git a/ext/B/t/invlist.t b/ext/B/t/invlist.t
new file mode 100644 (file)
index 0000000..a719d04
--- /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();

diff --git a/ext/B/typemap b/ext/B/typemap
index 045d6a0..d891f9d 100644 (file)
--- a/ext/B/typemap
+++ b/ext/B/typemap
@@ -27,6 +27,7 @@ B::HV         T_SV_OBJ
 B::AV          T_SV_OBJ
 B::IO          T_SV_OBJ
 B::FM          T_SV_OBJ
+B::INVLIST     T_SV_OBJ
 
 B::MAGIC       T_MG_OBJ
 SSize_t                T_IV

diff --git a/perl.h b/perl.h
index d0066f5..da05d96 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -2800,6 +2800,7 @@ typedef struct gv GV;
 typedef struct io IO;
 typedef struct context PERL_CONTEXT;
 typedef struct block BLOCK;
+typedef struct invlist INVLIST;
 
 typedef struct magic MAGIC;
 typedef struct xpv XPV;

diff --git a/sv.h b/sv.h
index 3d906aa..2ad0a5c 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -265,6 +265,11 @@ struct p5rx {
     _SV_HEAD_UNION;
 };
 
+struct invlist {
+    _SV_HEAD(XINVLIST*);       /* pointer to xpvinvlist body */
+    _SV_HEAD_UNION;
+};
+
 #undef _SV_HEAD
 #undef _SV_HEAD_UNION          /* ensure no pollution */