This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add re::optimization()
authorHugo van der Sanden <hv@crypt.org>
Wed, 16 Sep 2020 13:08:42 +0000 (14:08 +0100)
committerHugo van der Sanden <hv@crypt.org>
Fri, 25 Sep 2020 13:29:31 +0000 (14:29 +0100)
Given a compiled regexp object, this returns a hashref of the optimization
information discovered for it.

ext/re/re.pm
ext/re/re.xs
ext/re/t/re_funcs.t
perl.h
pod/perlreapi.pod

index ea47897..d1db462 100644 (file)
@@ -4,11 +4,13 @@ package re;
 use strict;
 use warnings;
 
-our $VERSION     = "0.40";
+our $VERSION     = "0.41";
 our @ISA         = qw(Exporter);
-our @EXPORT_OK   = ('regmust',
-                    qw(is_regexp regexp_pattern
-                       regname regnames regnames_count));
+our @EXPORT_OK   = qw{
+       is_regexp regexp_pattern
+       regname regnames regnames_count
+       regmust optimization
+};
 our %EXPORT_OK = map { $_ => 1 } @EXPORT_OK;
 
 my %bitmask = (
@@ -805,6 +807,116 @@ floating string. This will be what the optimiser of the Perl that you
 are using thinks is the longest. If you believe that the result is wrong
 please report it via the L<perlbug> utility.
 
+=item optimization($ref)
+
+If the argument is a compiled regular expression as returned by C<qr//>,
+then this function returns a hashref of the optimization information
+discovered at compile time, so we can write tests around it. If any
+other argument is given, returns C<undef>.
+
+The hash contents are expected to change from time to time as we develop
+new ways to optimize - no assumption of stability should be made, not
+even between minor versions of perl.
+
+For the current version, the hash will have the following contents:
+
+=over 4
+
+=item minlen
+
+An integer, the least number of characters in any string that can match.
+
+=item minlenret
+
+An integer, the least number of characters that can be in C<$&> after a
+match. (Consider eg C< /ns(?=\d)/ >.)
+
+=item gofs
+
+An integer, the number of characters before C<pos()> to start match at.
+
+=item noscan
+
+A boolean, C<TRUE> to indicate that any anchored/floating substrings
+found should not be used. (CHECKME: apparently this is set for an
+anchored pattern with no floating substring, but never used.)
+
+=item isall
+
+A boolean, C<TRUE> to indicate that the optimizer information is all
+that the regular expression contains, and thus one does not need to
+enter the regexp runtime engine at all.
+
+=item anchor SBOL
+
+A boolean, C<TRUE> if the pattern is anchored to start of string.
+
+=item anchor MBOL
+
+A boolean, C<TRUE> if the pattern is anchored to any start of line
+within the string.
+
+=item anchor GPOS
+
+A boolean, C<TRUE> if the pattern is anchored to the end of the previous
+match.
+
+=item skip
+
+A boolean, C<TRUE> if the start class can match only the first of a run.
+
+=item implicit
+
+A boolean, C<TRUE> if a C</.*/> has been turned implicitly into a C</^.*/>.
+
+=item anchored/floating
+
+A byte string representing an anchored or floating substring respectively
+that any match must contain, or undef if no such substring was found, or
+if the substring would require utf8 to represent.
+
+=item anchored utf8/floating utf8
+
+A utf8 string representing an anchored or floating substring respectively
+that any match must contain, or undef if no such substring was found, or
+if the substring contains only 7-bit ASCII characters.
+
+=item anchored min offset/floating min offset
+
+An integer, the first offset in characters from a match location at which
+we should look for the corresponding substring.
+
+=item anchored max offset/floating max offset
+
+An integer, the last offset in characters from a match location at which
+we should look for the corresponding substring.
+
+Ignored for anchored, so may be 0 or same as min.
+
+=item anchored end shift/floating end shift
+
+FIXME: not sure what this is, something to do with lookbehind. regcomp.c
+says:
+    When the final pattern is compiled and the data is moved from the
+    scan_data_t structure into the regexp structure the information
+    about lookbehind is factored in, with the information that would
+    have been lost precalculated in the end_shift field for the
+    associated string.
+
+=item checking
+
+A constant string, one of "anchored", "floating" or "none" to indicate
+which substring (if any) should be checked for first.
+
+=item stclass
+
+A string representation of a character class ("start class") that must
+be the first character of any match.
+
+TODO: explain the representations.
+
+=back
+
 =back
 
 =head1 SEE ALSO
index f8d77dd..ebb359d 100644 (file)
@@ -11,7 +11,7 @@
 
 #undef dXSBOOTARGSXSAPIVERCHK
 /* skip API version checking due to different interp struct size but,
-   this hack is until #123007 is resolved */
+   this hack is until GitHub issue #14169 is resolved */
 #define dXSBOOTARGSXSAPIVERCHK dXSBOOTARGSNOVERCHK
 
 START_EXTERN_C
@@ -54,6 +54,10 @@ extern SV*      my_reg_qr_package(pTHX_ REGEXP * const rx);
 #if defined(USE_ITHREADS)
 extern void*   my_regdupe (pTHX_ REGEXP * const r, CLONE_PARAMS *param);
 #endif
+extern void     my_regprop(pTHX_
+    const regexp *prog, SV* sv, const regnode* o,
+    const regmatch_info *reginfo, const RExC_state_t *pRExC_state
+);
 
 EXTERN_C const struct regexp_engine my_reg_engine;
 EXTERN_C const struct regexp_engine wild_reg_engine;
@@ -100,6 +104,8 @@ const struct regexp_engine wild_reg_engine = {
         my_re_op_compile,
 };
 
+#define newSVbool_(x) newSViv((x) ? 1 : 0)
+
 MODULE = re    PACKAGE = re
 
 void
@@ -143,3 +149,94 @@ PPCODE:
     XSRETURN_UNDEF;
 }
 
+SV *
+optimization(sv)
+    SV * sv
+PROTOTYPE: $
+PREINIT:
+    REGEXP *re;
+    regexp *r;
+    struct reg_substr_datum * data;
+    HV *hv;
+CODE:
+{
+    re = SvRX(sv);
+    if (!re) {
+        XSRETURN_UNDEF;
+    }
+
+    /* only for re engines we know about */
+    if (   RX_ENGINE(re) != &my_reg_engine
+        && RX_ENGINE(re) != &wild_reg_engine
+        && RX_ENGINE(re) != &PL_core_reg_engine)
+    {
+        XSRETURN_UNDEF;
+    }
+
+    if (!PL_colorset) {
+        reginitcolors();
+    }
+
+    r = ReANY(re);
+    hv = newHV();
+
+    hv_stores(hv, "minlen", newSViv(r->minlen));
+    hv_stores(hv, "minlenret", newSViv(r->minlenret));
+    hv_stores(hv, "gofs", newSViv(r->gofs));
+
+    data = &r->substrs->data[0];
+    hv_stores(hv, "anchored", data->substr
+            ? newSVsv(data->substr) : &PL_sv_undef);
+    hv_stores(hv, "anchored utf8", data->utf8_substr
+            ? newSVsv(data->utf8_substr) : &PL_sv_undef);
+    hv_stores(hv, "anchored min offset", newSViv(data->min_offset));
+    hv_stores(hv, "anchored max offset", newSViv(data->max_offset));
+    hv_stores(hv, "anchored end shift", newSViv(data->end_shift));
+
+    data = &r->substrs->data[1];
+    hv_stores(hv, "floating", data->substr
+            ? newSVsv(data->substr) : &PL_sv_undef);
+    hv_stores(hv, "floating utf8", data->utf8_substr
+            ? newSVsv(data->utf8_substr) : &PL_sv_undef);
+    hv_stores(hv, "floating min offset", newSViv(data->min_offset));
+    hv_stores(hv, "floating max offset", newSViv(data->max_offset));
+    hv_stores(hv, "floating end shift", newSViv(data->end_shift));
+
+    hv_stores(hv, "checking", newSVpv(
+        (!r->check_substr && !r->check_utf8)
+            ? "none"
+        : (    r->check_substr == r->substrs->data[1].substr
+            && r->check_utf8   == r->substrs->data[1].utf8_substr
+        )
+            ? "floating"
+        : "anchored"
+    , 0));
+
+    hv_stores(hv, "noscan", newSVbool_(r->intflags & PREGf_NOSCAN));
+    hv_stores(hv, "isall", newSVbool_(r->extflags & RXf_CHECK_ALL));
+    hv_stores(hv, "anchor SBOL", newSVbool_(r->intflags & PREGf_ANCH_SBOL));
+    hv_stores(hv, "anchor MBOL", newSVbool_(r->intflags & PREGf_ANCH_MBOL));
+    hv_stores(hv, "anchor GPOS", newSVbool_(r->intflags & PREGf_ANCH_GPOS));
+    hv_stores(hv, "skip", newSVbool_(r->intflags & PREGf_SKIP));
+    hv_stores(hv, "implicit", newSVbool_(r->intflags & PREGf_IMPLICIT));
+
+    {
+        RXi_GET_DECL(r, ri);
+        if (ri->regstclass) {
+            SV* sv = newSV(0);
+            /* not Perl_regprop, we must have the DEBUGGING version */
+            my_regprop(r, sv, ri->regstclass, NULL, NULL);
+            hv_stores(hv, "stclass", sv);
+        } else {
+            hv_stores(hv, "stclass", &PL_sv_undef);
+        }
+    }
+
+    RETVAL = newRV_noinc((SV *)hv);
+}
+OUTPUT:
+    RETVAL
+
+#
+# ex: set ts=8 sts=4 sw=4 et:
+#
index 69275d8..cbed67b 100644 (file)
@@ -1,19 +1,19 @@
 #!./perl
 
 BEGIN {
-       require Config;
-       if (($Config::Config{'extensions'} !~ /\bre\b/) ){
-               print "1..0 # Skip -- Perl configured without re module\n";
-               exit 0;
-       }
+    require Config;
+    if (($Config::Config{'extensions'} !~ /\bre\b/) ){
+        print "1..0 # Skip -- Perl configured without re module\n";
+        exit 0;
+    }
 }
 
 use strict;
 use warnings;
 
 use Test::More; # test count at bottom of file
-use re qw(regmust);
 {
+    use re qw{regmust};
     my $qr=qr/here .* there/x;
     my ($anchored,$floating)=regmust($qr);
     is($anchored,'here',"Regmust anchored - qr//");
@@ -27,6 +27,75 @@ use re qw(regmust);
     is($anchored,undef,"Regmust anchored - ref");
     is($floating,undef,"Regmust anchored - ref");
 }
+
+{
+    use re qw{optimization};
+    # try to show each element is populated, without working the regexp
+    # engine any harder than necessary - the real work will be testing
+    # that optimization happens correctly using this under t/re.
+
+    is(optimization(undef), undef, "non-qr returns undef");
+    is(optimization("foo"), undef, "non-qr returns undef");
+    is(optimization(bless {}, "Regexp"), undef, "non-qr returns undef");
+
+    my $o = optimization(qr{foo});
+    is(ref($o), 'HASH', "qr returns a hashref");
+    is($o->{minlen}, 3, "/foo/ has minlen");
+
+    $o = optimization(qr{foo(?=bar)});
+    is($o->{minlenret}, 3, "/foo(?=bar)/ has minlenret");
+
+    $o = optimization(qr{.\G.});
+    ok($o->{'anchor GPOS'}, "/.\\G./ has anchor GPOS");
+    is($o->{gofs}, 1, "/.\\G./ has gofs");
+
+    $o = optimization(qr{a|bc});
+    is($o->{anchored}, undef, "/a|bc/ has no anchored substring");
+    is($o->{floating}, undef, "/a|bc/ has no floating substring");
+    is($o->{checking}, "none", "/a|bc/ is checking no substring");
+
+    $o = optimization(qr{foo});
+    ok($o->{isall}, "/foo/ has isall");
+    is($o->{anchored}, "foo", "/foo/ has anchored substring");
+    is($o->{'anchored utf8'}, undef, "/foo/ has no anchored utf8");
+    is($o->{floating}, undef, "/foo/ has no floating substring");
+    is($o->{checking}, "anchored", "/foo/ is checking anchored");
+
+    $o = optimization(qr{.foo});
+    is($o->{'anchored min offset'}, 1, "/.foo/ has anchored min offset");
+    like($o->{'anchored max offset'}, qr{^[01]\z},
+            "/.foo/ has valid anchored max offset");
+
+    $o = optimization(qr{.foo\x{100}});
+    is($o->{anchored}, undef, "/.foo\\x{100}/ has no anchored");
+    is($o->{'anchored utf8'}, "foo\x{100}", "/.foo\\x{100}/ has anchored utf8");
+    is($o->{'anchored min offset'}, 1, "/.foo\\x{100}/ has anchored min");
+    like($o->{'anchored max offset'}, qr{^[01]\z},
+            "/.foo\\x{100}/ has valid anchored max offset");
+
+    $o = optimization(qr{.x?foo});
+    is($o->{anchored}, undef, "/.x?foo/ has no anchored substring");
+    is($o->{floating}, "foo", "/.x?foo/ has floating substring");
+    is($o->{'floating utf8'}, undef, "/.x?foo/ has no floating utf8");
+    is($o->{'floating min offset'}, 1, "/.x?foo/ has floating min offset");
+    is($o->{'floating max offset'}, 2, "/.x?foo/ has floating max offset");
+    is($o->{checking}, "floating", "/foo/ is checking floating");
+
+    $o = optimization(qr{[ab]+});
+    ok($o->{skip}, "/[ab]+/ has skip");
+    like($o->{stclass}, qr{^ANYOF}, "/[ab]+/ has stclass");
+
+    ok(optimization(qr{^foo})->{'anchor SBOL'}, "/^foo/ has anchor SBOL");
+    ok(optimization(qr{^foo}m)->{'anchor MBOL'}, "/^foo/m has anchor MBOL");
+    ok(optimization(qr{.*})->{implicit}, "/.*/ has implicit anchor");
+    ok(optimization(qr{^.foo})->{noscan}, "/^.foo/ has noscan");
+
+    # TODO: test anchored/floating end shift
+}
 # New tests above this line, don't forget to update the test count below!
-use Test::More tests => 6;
+use Test::More tests => 40;
 # No tests here!
+
+#
+# ex: set ts=8 sts=4 sw=4 et:
+#
diff --git a/perl.h b/perl.h
index 5a48146..e00a024 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -3994,7 +3994,8 @@ typedef        struct crypt_data {     /* straight from /usr/include/crypt.h */
 
 typedef struct magic_state MGS;        /* struct magic_state defined in mg.c */
 
-#if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_REGEXEC_C)
+#if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_REGEXEC_C) \
+ || defined(PERL_EXT_RE_BUILD)
 
 /* These have to be predeclared, as they are used in proto.h which is #included
  * before their definitions in regcomp.h. */
index 493aff6..790e3fd 100644 (file)
@@ -665,7 +665,7 @@ pointed to by C<RE_ENGINE_PTR>.
 
 =head2 C<mother_re>
 
-TODO, see L<http://www.mail-archive.com/perl5-changes@perl.org/msg17328.html>
+TODO, see commit 28d8d7f41a.
 
 =head2 C<extflags>