Change 27512 by [EMAIL PROTECTED] on 2006/03/15 20:21:52
When bless() changes the overloading state of the passed in reference,
and there are other references to this object, then brute force search
for the other references, and perform the same change on them. Fixes
bug 34925.
Integrate the regression tests from:
[ 27506]
Moving the overloading flag from the reference to the referant allows
(re)?blessing of overloaded objects to work correctly.
[ 27508]
Test for reblessing objects with weak references.
[ 27510]
D'oh! 27508 wasn't quite testing what I wanted it to test. This does.
Affected files ...
... //depot/maint-5.8/perl/embed.fnc#133 edit
... //depot/maint-5.8/perl/embed.h#101 edit
... //depot/maint-5.8/perl/lib/overload.t#12 edit
... //depot/maint-5.8/perl/proto.h#122 edit
... //depot/maint-5.8/perl/sv.c#242 edit
Differences ...
==== //depot/maint-5.8/perl/embed.fnc#133 (text) ====
Index: perl/embed.fnc
--- perl/embed.fnc#132~27391~ 2006-03-06 10:13:50.000000000 -0800
+++ perl/embed.fnc 2006-03-15 12:21:52.000000000 -0800
@@ -1273,6 +1273,7 @@
s |bool |utf8_mg_pos_init |NN SV *sv|NN MAGIC **mgp \
|NN STRLEN **cachep|I32 i|I32 offsetp \
|NN const U8 *s|NN const U8 *start
+s |void |reset_amagic |NN SV *rv|const bool on
#endif
#if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
==== //depot/maint-5.8/perl/embed.h#101 (text+w) ====
Index: perl/embed.h
--- perl/embed.h#100~27391~ 2006-03-06 10:13:50.000000000 -0800
+++ perl/embed.h 2006-03-15 12:21:52.000000000 -0800
@@ -1321,6 +1321,7 @@
#ifdef PERL_CORE
#define utf8_mg_pos S_utf8_mg_pos
#define utf8_mg_pos_init S_utf8_mg_pos_init
+#define reset_amagic S_reset_amagic
#endif
#endif
#if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
@@ -3338,6 +3339,7 @@
#ifdef PERL_CORE
#define utf8_mg_pos(a,b,c,d,e,f,g,h,i) S_utf8_mg_pos(aTHX_ a,b,c,d,e,f,g,h,i)
#define utf8_mg_pos_init(a,b,c,d,e,f,g) S_utf8_mg_pos_init(aTHX_
a,b,c,d,e,f,g)
+#define reset_amagic(a,b) S_reset_amagic(aTHX_ a,b)
#endif
#endif
#if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
==== //depot/maint-5.8/perl/lib/overload.t#12 (text) ====
Index: perl/lib/overload.t
--- perl/lib/overload.t#11~27509~ 2006-03-15 10:14:26.000000000 -0800
+++ perl/lib/overload.t 2006-03-15 12:21:52.000000000 -0800
@@ -47,7 +47,7 @@
package main;
$| = 1;
-use Test::More tests=>496;
+use Test::More tests => 508;
$a = new Oscalar "087";
@@ -1173,3 +1173,76 @@
like('x:a:a:=', qr/x$a$a=$/);
}
+
+{
+ package Sklorsh;
+ use overload
+ bool => sub { shift->is_cool };
+
+ sub is_cool {
+ $_[0]->{name} eq 'cool';
+ }
+
+ sub delete {
+ undef %{$_[0]};
+ bless $_[0], 'Brap';
+ return 1;
+ }
+
+ sub delete_with_self {
+ my $self = shift;
+ undef %$self;
+ bless $self, 'Brap';
+ return 1;
+ }
+
+ package Brap;
+
+ 1;
+
+ package main;
+
+ my $obj;
+ $obj = bless {name => 'cool'}, 'Sklorsh';
+ $obj->delete;
+ ok(eval {if ($obj) {1}; 1}, $@ || 'reblessed into nonexist namespace');
+
+ $obj = bless {name => 'cool'}, 'Sklorsh';
+ $obj->delete_with_self;
+ ok (eval {if ($obj) {1}; 1}, $@);
+
+ my $a = $b = {name => 'hot'};
+ bless $b, 'Sklorsh';
+ is(ref $a, 'Sklorsh');
+ is(ref $b, 'Sklorsh');
+ ok(!$b, "Expect overloaded boolean");
+ ok(!$a, "Expect overloaded boolean");
+}
+{
+ use Scalar::Util 'weaken';
+
+ package Shklitza;
+ use overload '""' => sub {"CLiK KLAK"};
+
+ package Ksshfwoom;
+
+ package main;
+
+ my ($obj, $ref);
+ $obj = bless do {my $a; \$a}, 'Shklitza';
+ $ref = $obj;
+
+ is ($obj, "CLiK KLAK");
+ is ($ref, "CLiK KLAK");
+
+ weaken $ref;
+ is ($ref, "CLiK KLAK");
+
+ bless $obj, 'Ksshfwoom';
+
+ like ($obj, qr/^Ksshfwoom=/);
+ like ($ref, qr/^Ksshfwoom=/);
+
+ undef $obj;
+ is ($ref, undef);
+}
==== //depot/maint-5.8/perl/proto.h#122 (text+w) ====
Index: perl/proto.h
--- perl/proto.h#121~27391~ 2006-03-06 10:13:50.000000000 -0800
+++ perl/proto.h 2006-03-15 12:21:52.000000000 -0800
@@ -1872,6 +1872,7 @@
#
STATIC bool S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32
i, I32 *offsetp, I32 uoff, const U8 **sp, const U8 *start, const U8 *send);
STATIC bool S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep,
I32 i, I32 offsetp, const U8 *s, const U8 *start);
+STATIC void S_reset_amagic(pTHX_ SV *rv, const bool on);
#endif
#if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
==== //depot/maint-5.8/perl/sv.c#242 (text) ====
Index: perl/sv.c
--- perl/sv.c#241~27395~ 2006-03-06 13:28:10.000000000 -0800
+++ perl/sv.c 2006-03-15 12:21:52.000000000 -0800
@@ -6945,6 +6945,52 @@
return rv;
}
+/* This is a hack to cope with reblessing from class with overloading magic to
+ one without (or the other way). Search for every reference pointing to the
+ object. Can't use S_visit() because we would need to pass a parameter to
+ our function. */
+static void
+S_reset_amagic(pTHX_ SV *rv, const bool on) {
+ /* It is assumed that you've already turned magic on/off on rv */
+ SV* sva;
+ SV *const target = SvRV(rv);
+ /* Less 1 for the reference we've already dealt with. */
+ U32 how_many = SvREFCNT(target) - 1;
+ MAGIC *mg;
+
+ if (SvMAGICAL(target) && (mg = mg_find(target, PERL_MAGIC_backref))) {
+ /* Back referneces also need to be found, but aren't part of the
+ target's reference count. */
+ how_many += 1 + av_len((AV*)mg->mg_obj);
+ }
+
+ if (!how_many) {
+ /* There was only 1 reference to this object. */
+ return;
+ }
+
+ for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
+ register const SV * const svend = &sva[SvREFCNT(sva)];
+ register SV* sv;
+ for (sv = sva + 1; sv < svend; ++sv) {
+ if (SvTYPE(sv) != SVTYPEMASK
+ && (sv->sv_flags & SVf_ROK) == SVf_ROK
+ && SvREFCNT(sv)
+ && SvRV(sv) == target
+ && sv != rv) {
+ if (on)
+ SvAMAGIC_on(sv);
+ else
+ SvAMAGIC_off(sv);
+ if (--how_many == 0) {
+ /* We have found them all. */
+ return;
+ }
+ }
+ }
+ }
+}
+
/*
=for apidoc sv_bless
@@ -6977,10 +7023,17 @@
(void)SvUPGRADE(tmpRef, SVt_PVMG);
SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc(stash));
- if (Gv_AMG(stash))
- SvAMAGIC_on(sv);
- else
- SvAMAGIC_off(sv);
+ if (Gv_AMG(stash)) {
+ if (!SvAMAGIC(sv)) {
+ SvAMAGIC_on(sv);
+ S_reset_amagic(aTHX_ sv, TRUE);
+ }
+ } else {
+ if (SvAMAGIC(sv)) {
+ SvAMAGIC_off(sv);
+ S_reset_amagic(aTHX_ sv, FALSE);
+ }
+ }
if(SvSMAGICAL(tmpRef))
if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
End of Patch.
