204 lines
5.3 KiB
Diff
204 lines
5.3 KiB
Diff
--- perl-5.8.8/sv.c.U27512 2006-06-01 18:43:19.000000000 -0400
|
|
+++ perl-5.8.8/sv.c 2006-06-01 19:13:32.000000000 -0400
|
|
@@ -7993,6 +7993,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
|
|
|
|
@@ -8025,10 +8071,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))
|
|
--- perl-5.8.8/proto.h.U27512 2006-06-01 18:43:19.000000000 -0400
|
|
+++ perl-5.8.8/proto.h 2006-06-01 19:13:32.000000000 -0400
|
|
@@ -1875,6 +1875,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)
|
|
--- perl-5.8.8/embed.h.U27512 2006-06-01 18:43:19.000000000 -0400
|
|
+++ perl-5.8.8/embed.h 2006-06-01 19:13:32.000000000 -0400
|
|
@@ -1348,6 +1348,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)
|
|
@@ -3390,6 +3391,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)
|
|
--- perl-5.8.8/embed.fnc.U27512 2006-06-01 18:43:19.000000000 -0400
|
|
+++ perl-5.8.8/embed.fnc 2006-06-01 19:13:32.000000000 -0400
|
|
@@ -1276,6 +1276,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)
|
|
--- perl-5.8.8/lib/overload.t.U27512 2006-06-01 19:13:06.000000000 -0400
|
|
+++ perl-5.8.8/lib/overload.t 2006-06-01 19:13:32.000000000 -0400
|
|
@@ -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);
|
|
+}
|