In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/e4eea5780a2bbeecb73ada4fbd62b3616735d968?hp=7d0994e057b3340e9b0be219a07a5992e313f0f0>
- Log -----------------------------------------------------------------
commit e4eea5780a2bbeecb73ada4fbd62b3616735d968
Author: Rafael Garcia-Suarez <r...@consttype.org>
Date: Sun Nov 1 16:42:47 2009 +0100
Improvements to qr-overload tests
- Fix test for error message
- Add negative test cases
- Remove unneeded evals
M lib/overload.t
commit 206be27c0fa2615e5c56409de4fad77e959e8b43
Author: Rafael Garcia-Suarez <r...@consttype.org>
Date: Sun Nov 1 16:29:58 2009 +0100
Bump overload.pm's VERSION (plus some spelling nits)
M lib/overload.pm
commit 7cb0cfe6b05b22a9c89198b7133aee5507599e8c
Author: Ben Morrow <b...@morrow.me.uk>
Date: Tue Oct 27 16:12:36 2009 +0000
Documentation for the 'qr' overload.
M lib/overload.pm
M pod/perldiag.pod
M t/porting/diag.t
commit d4b87e753f3c5c8123aeebb4ae822cef9f2eed3c
Author: Ben Morrow <b...@morrow.me.uk>
Date: Tue Oct 27 15:55:36 2009 +0000
Implement the 'qr' overload type.
If this is defined, it will be called instead of stringification
whenever an object is used as a regexp or interpolated into a regexp.
This will fall back to stringification even without C<fallback => 1>,
for compatibility.
An overloaded 'qr' must return either a REGEXP or a ref to a REGEXP
(such as created by qr//). Any further overloading on the return value
will be ignored.
M gv.c
M lib/overload.t
M pp_ctl.c
commit d9151963660fed8e24ee268776a238e1d9ae6802
Author: Ben Morrow <b...@morrow.me.uk>
Date: Sat Oct 24 14:58:33 2009 +0100
Add a new overload type, "qr".
M lib/overload/numbers.pm
M overload.c
M overload.h
M overload.pl
-----------------------------------------------------------------------
Summary of changes:
gv.c | 1 +
lib/overload.pm | 29 +++++++++------
lib/overload.t | 87 ++++++++++++++++++++++++++++++++++++++++++++++-
lib/overload/numbers.pm | 2 +
overload.c | 2 +
overload.h | 1 +
overload.pl | 1 +
pod/perldiag.pod | 11 ++++++
pp_ctl.c | 35 +++++++++++++++++--
t/porting/diag.t | 1 -
10 files changed, 152 insertions(+), 18 deletions(-)
diff --git a/gv.c b/gv.c
index 22af274..3e225bc 100644
--- a/gv.c
+++ b/gv.c
@@ -1963,6 +1963,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method,
int flags)
case int_amg:
case iter_amg: /* XXXX Eventually should do to_gv. */
case ftest_amg: /* XXXX Eventually should do to_gv. */
+ case regexp_amg:
/* FAIL safe */
return NULL; /* Delegate operation to standard mechanisms. */
break;
diff --git a/lib/overload.pm b/lib/overload.pm
index 8960171..7d09d69 100644
--- a/lib/overload.pm
+++ b/lib/overload.pm
@@ -1,6 +1,6 @@
package overload;
-our $VERSION = '1.09';
+our $VERSION = '1.10';
sub nil {}
@@ -135,7 +135,7 @@ sub mycan { # Real can would leave
stubs.
unary => "neg ! ~",
mutators => '++ --',
func => "atan2 cos sin exp abs log sqrt int",
- conversion => 'bool "" 0+',
+ conversion => 'bool "" 0+ qr',
iterators => '<>',
filetest => "-X",
dereferencing => '${} @{} %{} &{} *{}',
@@ -400,15 +400,20 @@ floating-point-like types one should follow the same
semantic. If
C<int> is unavailable, it can be autogenerated using the overloading of
C<0+>.
-=item * I<Boolean, string and numeric conversion>
+=item * I<Boolean, string, numeric and regexp conversions>
- 'bool', '""', '0+',
+ 'bool', '""', '0+', 'qr'
-If one or two of these operations are not overloaded, the remaining ones can
-be used instead. C<bool> is used in the flow control operators
-(like C<while>) and for the ternary C<?:> operation. These functions can
-return any arbitrary Perl value. If the corresponding operation for this value
-is overloaded too, that operation will be called again with this value.
+If one or two of these operations are not overloaded, the remaining ones
+can be used instead. C<bool> is used in the flow control operators
+(like C<while>) and for the ternary C<?:> operation; C<qr> is used for
+the RHS of C<=~> and when an object is interpolated into a regexp.
+
+C<bool>, C<"">, and C<0+> can return any arbitrary Perl value. If the
+corresponding operation for this value is overloaded too, that operation
+will be called again with this value. C<qr> must return a compiled
+regexp, or a ref to a compiled regexp (such as C<qr//> returns), and any
+further overloading on the return value will be ignored.
As a special case if the overload returns the object itself then it will
be used directly. An overloaded conversion returning the object is
@@ -518,7 +523,7 @@ A computer-readable form of the above table is available in
the hash
unary => 'neg ! ~',
mutators => '++ --',
func => 'atan2 cos sin exp abs log sqrt',
- conversion => 'bool "" 0+',
+ conversion => 'bool "" 0+ qr',
iterators => '<>',
filetest => '-X',
dereferencing => '${} @{} %{} &{} *{}',
@@ -693,8 +698,8 @@ is not defined.
=item I<Conversion operations>
-String, numeric, and boolean conversion are calculated in terms of one
-another if not all of them are defined.
+String, numeric, boolean and regexp conversions are calculated in terms
+of one another if not all of them are defined.
=item I<Increment and decrement>
diff --git a/lib/overload.t b/lib/overload.t
index 1f9bc1b..d54068e 100644
--- a/lib/overload.t
+++ b/lib/overload.t
@@ -47,7 +47,7 @@ sub numify { 0 + "${$_[0]}" } # Not needed, additional
overhead
package main;
$| = 1;
-use Test::More tests => 577;
+use Test::More tests => 605;
$a = new Oscalar "087";
@@ -1182,6 +1182,91 @@ foreach my $op (qw(<=> == != < <= > >=)) {
}
{
+ {
+ package QRonly;
+ use overload qr => sub { qr/x/ }, fallback => 1;
+ }
+ {
+ my $x = bless [], "QRonly";
+
+ # like tries to be too clever, and decides that $x-stringified
+ # doesn't look like a regex
+ ok("x" =~ $x, "qr-only matches");
+ ok("y" !~ $x, "qr-only doesn't match what it shouldn't");
+ ok("xx" =~ /x$x/, "qr-only matches with concat");
+ like("$x", qr/^QRonly=ARRAY/, "qr-only doesn't have string overload");
+
+ my $qr = bless qr/y/, "QRonly";
+ ok("x" =~ $qr, "qr with qr-overload uses overload");
+ ok("y" !~ $qr, "qr with qr-overload uses overload");
+ is("$qr", "".qr/y/, "qr with qr-overload stringify");
+
+ my $rx = $$qr;
+ ok("y" =~ $rx, "bare rx with qr-overload doesn't overload match");
+ ok("x" !~ $rx, "bare rx with qr-overload doesn't overload match");
+ is("$rx", "".qr/y/, "bare rx with qr-overload stringify");
+ }
+ {
+ package QRandSTR;
+ use overload qr => sub { qr/x/ }, q/""/ => sub { "y" };
+ }
+ {
+ my $x = bless [], "QRandSTR";
+ ok("x" =~ $x, "qr+str uses qr for match");
+ ok("y" !~ $x, "qr+str uses qr for match");
+ ok("xx" =~ /x$x/, "qr+str uses qr for match with concat");
+ is("$x", "y", "qr+str uses str for stringify");
+
+ my $qr = bless qr/z/, "QRandSTR";
+ is("$qr", "y", "qr with qr+str uses str for stringify");
+ ok("xx" =~ /x$x/, "qr with qr+str uses qr for match");
+
+ my $rx = $$qr;
+ ok("z" =~ $rx, "bare rx with qr+str doesn't overload match");
+ is("$rx", "".qr/z/, "bare rx with qr+str doesn't overload stringify");
+ }
+ {
+ package QRany;
+ use overload qr => sub { $_[0]->(@_) };
+
+ package QRself;
+ use overload qr => sub { $_[0] };
+ }
+ {
+ my $rx = bless sub { ${ qr/x/ } }, "QRany";
+ ok("x" =~ $rx, "qr overload accepts a bare rx");
+ ok("y" !~ $rx, "qr overload accepts a bare rx");
+
+ my $str = bless sub { "x" }, "QRany";
+ ok(!eval { "x" =~ $str }, "qr overload doesn't accept a string");
+ like($@, qr/^Overloaded qr did not return a REGEXP/, "correct error");
+
+ my $oqr = bless qr/z/, "QRandSTR";
+ my $oqro = bless sub { $oqr }, "QRany";
+ ok("z" =~ $oqro, "qr overload doesn't recurse");
+
+ my $qrs = bless qr/z/, "QRself";
+ ok("z" =~ $qrs, "qr overload can return self");
+ }
+ {
+ package STRonly;
+ use overload q/""/ => sub { "x" };
+
+ package STRonlyFB;
+ use overload q/""/ => sub { "x" }, fallback => 1;
+ }
+ {
+ my $fb = bless [], "STRonlyFB";
+ ok("x" =~ $fb, "qr falls back to \"\"");
+ ok("y" !~ $fb, "qr falls back to \"\"");
+
+ my $nofb = bless [], "STRonly";
+ ok("x" =~ $nofb, "qr falls back even without fallback");
+ ok("y" !~ $nofb, "qr falls back even without fallback");
+ }
+}
+
+{
my $twenty_three = 23;
# Check that constant overloading propagates into evals
BEGIN { overload::constant integer => sub { 23 } }
diff --git a/lib/overload/numbers.pm b/lib/overload/numbers.pm
index 7c39b1c..d9daab5 100644
--- a/lib/overload/numbers.pm
+++ b/lib/overload/numbers.pm
@@ -81,6 +81,7 @@ our @names = qw#
(.=
(~~
(-X
+ (qr
DESTROY
#;
@@ -152,6 +153,7 @@ our @enums = qw#
concat_ass
smart
ftest
+ regexp
DESTROY
#;
diff --git a/overload.c b/overload.c
index 909a0ee..4a9c94b 100644
--- a/overload.c
+++ b/overload.c
@@ -83,6 +83,7 @@ static const U8 PL_AMG_namelens[NofAMmeth] = {
3,
3,
3,
+ 3,
7
};
@@ -159,5 +160,6 @@ static const char * const PL_AMG_names[NofAMmeth] = {
"(.=",
"(~~",
"(-X",
+ "(qr",
"DESTROY"
};
diff --git a/overload.h b/overload.h
index 1a1e69c..bbef5cb 100644
--- a/overload.h
+++ b/overload.h
@@ -80,6 +80,7 @@ enum {
concat_ass_amg,
smart_amg,
ftest_amg,
+ regexp_amg,
DESTROY_amg,
max_amg_code
/* Do not leave a trailing comma here. C9X allows it, C89 doesn't. */
diff --git a/overload.pl b/overload.pl
index aae9e6f..d4ba9a7 100644
--- a/overload.pl
+++ b/overload.pl
@@ -229,5 +229,6 @@ concat (.
concat_ass (.=
smart (~~
ftest (-X
+regexp (qr
# Note: Perl_Gv_AMupdate() assumes that DESTROY is the last entry
DESTROY DESTROY
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 2bad617..22b30f8 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -3004,6 +3004,17 @@ the string being unpacked. See L<perlfunc/pack>.
the string being unpacked. The string being unpacked was also invalid
UTF-8. See L<perlfunc/pack>.
+=item Overloaded dereference did not return a reference
+
+(F) An object with an overloaded dereference operator was dereferenced,
+but the overloaded operation did not return a reference. See
+L<overload>.
+
+=item Overloaded qr did not return a REGEXP
+
+(F) An object with a C<qr> overload was used as part of a match, but the
+overloaded operation didn't return a compiled regexp. See L<overload>.
+
=item %s package attribute may clash with future reserved word: %s
(W reserved) A lowercase attribute name was used that had a
diff --git a/pp_ctl.c b/pp_ctl.c
index f314989..ce60ea0 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -93,34 +93,61 @@ PP(pp_regcomp)
RETURN;
}
#endif
+
+#define tryAMAGICregexp(rx) \
+ STMT_START { \
+ if (SvROK(rx) && SvAMAGIC(rx)) { \
+ SV *sv = AMG_CALLun(rx, regexp); \
+ if (sv) { \
+ if (SvROK(sv)) \
+ sv = SvRV(sv); \
+ if (SvTYPE(sv) != SVt_REGEXP) \
+ Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \
+ rx = sv; \
+ } \
+ } \
+ } STMT_END
+
+
if (PL_op->op_flags & OPf_STACKED) {
/* multiple args; concatentate them */
dMARK; dORIGMARK;
tmpstr = PAD_SV(ARGTARG);
sv_setpvs(tmpstr, "");
while (++MARK <= SP) {
+ SV *msv = *MARK;
if (PL_amagic_generation) {
SV *sv;
- if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
- (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
+
+ tryAMAGICregexp(msv);
+
+ if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
+ (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
{
sv_setsv(tmpstr, sv);
continue;
}
}
- sv_catsv(tmpstr, *MARK);
+ sv_catsv(tmpstr, msv);
}
SvSETMAGIC(tmpstr);
SP = ORIGMARK;
}
- else
+ else {
tmpstr = POPs;
+ tryAMAGICregexp(tmpstr);
+ }
+
+#undef tryAMAGICregexp
if (SvROK(tmpstr)) {
SV * const sv = SvRV(tmpstr);
if (SvTYPE(sv) == SVt_REGEXP)
re = (REGEXP*) sv;
}
+ else if (SvTYPE(tmpstr) == SVt_REGEXP)
+ re = (REGEXP*) tmpstr;
+
if (re) {
re = reg_temp_copy(NULL, re);
ReREFCNT_dec(PM_GETRE(pm));
diff --git a/t/porting/diag.t b/t/porting/diag.t
index 9aa25d5..cdb6dba 100644
--- a/t/porting/diag.t
+++ b/t/porting/diag.t
@@ -298,7 +298,6 @@ Offset outside string
Opening dirhandle %s also as a file
Opening filehandle %s also as a directory
Operator or semicolon missing before %c%s
-Overloaded dereference did not return a reference
PERL_SIGNALS illegal: "%s"
Perl %s required (did you mean %s?)--this is only %s, stopped
Perl %s required--this is only %s, stopped
--
Perl5 Master Repository
