if ($is_regex) {
my $pat;
- # This really sucks, re:regexp_pattern is in ext/re/re.xs and not in
- # universal.c, and even worse we cant just require that re to be loaded
- # we *have* to use() it.
- # We should probably move it to universal.c for 5.10.1 and fix this.
- # Currently we only use re::regexp_pattern when the re is blessed into another
- # package. This has the disadvantage of meaning that a DD dump won't round trip
- # as the pattern will be repeatedly wrapped with the same modifiers.
- # This is an aesthetic issue so we will leave it for now, but we could use
- # regexp_pattern() in list context to get the modifiers separately.
- # But since this means loading the full debugging engine in process we wont
- # bother unless its necessary for accuracy.
- if (($realpack ne 'Regexp') && defined(*re::regexp_pattern{CODE})) {
- $pat = re::regexp_pattern($val);
+ my $flags = "";
+ if (defined(*re::regexp_pattern{CODE})) {
+ ($pat, $flags) = re::regexp_pattern($val);
}
else {
$pat = "$val";
}
$pat =~ s <(\\.)|/> { $1 || '\\/' }ge;
- $out .= "qr/$pat/";
+ $out .= "qr/$pat/$flags";
}
elsif ($realtype eq 'SCALAR' || $realtype eq 'REF'
|| $realtype eq 'VSTRING') {
if (is_regex)
{
STRLEN rlen;
- const char *rval = SvPV(val, rlen);
- const char * const rend = rval+rlen;
- const char *slash = rval;
+ SV *sv_pattern = NULL;
+ SV *sv_flags = NULL;
+ CV *re_pattern_cv;
+ const char *rval;
+ const char *rend;
+ const char *slash;
+
+ if ((re_pattern_cv = get_cv("re::regexp_pattern", 0))) {
+ dSP;
+ I32 count;
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+ XPUSHs(val);
+ PUTBACK;
+ count = call_sv((SV*)re_pattern_cv, G_ARRAY);
+ SPAGAIN;
+ if (count >= 2) {
+ sv_flags = POPs;
+ sv_pattern = POPs;
+ SvREFCNT_inc(sv_flags);
+ SvREFCNT_inc(sv_pattern);
+ }
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+ if (sv_pattern) {
+ sv_2mortal(sv_pattern);
+ sv_2mortal(sv_flags);
+ }
+ }
+ else {
+ sv_pattern = val;
+ }
+ rval = SvPV(sv_pattern, rlen);
+ rend = rval+rlen;
+ slash = rval;
sv_catpvn(retval, "qr/", 3);
for (;slash < rend; slash++) {
if (*slash == '\\') { ++slash; continue; }
}
sv_catpvn(retval, rval, rlen);
sv_catpvn(retval, "/", 1);
+ if (sv_flags)
+ sv_catsv(retval, sv_flags);
}
else if (
#if PERL_VERSION < 9
my $t = bless( qr//, 'foo');
my $dt = Dumper($t);
-my $o = ($] >= 5.013006 ? <<'PERL' : <<'PERL_LEGACY');
-$VAR1 = bless( qr/(?^:)/, 'foo' );
+my $o = ($] > 5.010 ? <<'PERL' : <<'PERL_LEGACY');
+$VAR1 = bless( qr//, 'foo' );
PERL
$VAR1 = bless( qr/(?-xism:)/, 'foo' );
PERL_LEGACY
$Data::Dumper::Useperl = 1;
if (defined &Data::Dumper::Dumpxs) {
print "### XS extension loaded, will run XS tests\n";
- $TMAX = 426; $XS = 1;
+ $TMAX = 432; $XS = 1;
}
else {
print "### XS extensions not loaded, will NOT run XS tests\n";
- $TMAX = 213; $XS = 0;
+ $TMAX = 216; $XS = 0;
}
print "1..$TMAX\n";
"numbers and number-like scalars"
if $XS;
}
+############# 426
+{
+ # [perl #82948]
+ # re::regexp_pattern was moved to universal.c in v5.10.0-252-g192c1e2
+ # and apparently backported to maint-5.10
+ $WANT = $] > 5.010 ? <<'NEW' : <<'OLD';
+#$VAR1 = qr/abc/;
+#$VAR2 = qr/abc/i;
+NEW
+#$VAR1 = qr/(?-xism:abc)/;
+#$VAR2 = qr/(?i-xsm:abc)/;
+OLD
+ TEST q(Data::Dumper->Dump([ qr/abc/, qr/abc/i ])), "qr//";
+ TEST q(Data::Dumper->Dumpxs([ qr/abc/, qr/abc/i ])), "qr// xs"
+ if $XS;
+}
+############# 432