From dd2eae666980a8d8bd145f2f6cc632a45513f9ce Mon Sep 17 00:00:00 2001 From: Nicholas Clark Date: Wed, 15 Mar 2006 15:08:49 +0000 Subject: [PATCH] Moving the overloading flag from the reference to the referant allows (re)?blessing of overloaded objects to work correctly. p4raw-id: //depot/perl@27506 --- dump.c | 3 +-- lib/overload.t | 47 ++++++++++++++++++++++++++++++++++++++++++++++- sv.c | 7 +++++-- sv.h | 31 +++++++++++++++++++++---------- 4 files changed, 73 insertions(+), 15 deletions(-) diff --git a/dump.c b/dump.c index 650c1ab..8d4f063 100644 --- a/dump.c +++ b/dump.c @@ -1196,8 +1196,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo if (flags & SVf_FAKE) sv_catpv(d, "FAKE,"); if (flags & SVf_READONLY) sv_catpv(d, "READONLY,"); - if (flags & SVf_AMAGIC && type != SVt_PVHV) - sv_catpv(d, "OVERLOAD,"); + if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,"); if (flags & SVp_IOK) sv_catpv(d, "pIOK,"); if (flags & SVp_NOK) sv_catpv(d, "pNOK,"); if (flags & SVp_POK) sv_catpv(d, "pPOK,"); diff --git a/lib/overload.t b/lib/overload.t index 7854860..cf553ce 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=>497; +use Test::More tests=>503; $a = new Oscalar "087"; @@ -1180,3 +1180,48 @@ foreach my $op (qw(<=> == != < <= > >=)) { BEGIN { overload::constant integer => sub { 23 } } is(eval "17", $twenty_three); } + +{ + 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"); +} diff --git a/sv.c b/sv.c index e5e997c..147d13b 100644 --- a/sv.c +++ b/sv.c @@ -3652,7 +3652,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) if (sflags & SVf_IVisUV) SvIsUV_on(dstr); } - SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8); + SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8 + |SVf_AMAGIC); { const MAGIC * const smg = SvVOK(sstr); if (smg) { @@ -3664,7 +3665,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } else if (sflags & (SVp_IOK|SVp_NOK)) { (void)SvOK_off(dstr); - SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK); + SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK + |SVf_AMAGIC); if (sflags & SVp_IOK) { /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */ SvIV_set(dstr, SvIVX(sstr)); @@ -3684,6 +3686,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) SvFAKE_off(sstr); gv_efullname3(dstr, (GV *)sstr, "*"); SvFLAGS(sstr) |= wasfake; + SvFLAGS(dstr) |= sflags & SVf_AMAGIC; } else (void)SvOK_off(dstr); diff --git a/sv.h b/sv.h index 4461a3c..f2f2fea 100644 --- a/sv.h +++ b/sv.h @@ -865,11 +865,11 @@ Set the actual length of the string which is in the SV. See C. #define SvOK(sv) (SvFLAGS(sv) & SVf_OK) #define SvOK_off(sv) (assert_not_ROK(sv) assert_not_glob(sv) \ - SvFLAGS(sv) &= ~(SVf_OK|SVf_AMAGIC| \ + SvFLAGS(sv) &= ~(SVf_OK| \ SVf_IVisUV|SVf_UTF8), \ SvOOK_off(sv)) #define SvOK_off_exc_UV(sv) (assert_not_ROK(sv) \ - SvFLAGS(sv) &= ~(SVf_OK|SVf_AMAGIC| \ + SvFLAGS(sv) &= ~(SVf_OK| \ SVf_UTF8), \ SvOOK_off(sv)) @@ -938,11 +938,11 @@ in gv.h: */ SvFLAGS(sv) |= (SVf_POK|SVp_POK)) #define SvPOK_off(sv) (SvFLAGS(sv) &= ~(SVf_POK|SVp_POK)) #define SvPOK_only(sv) (assert_not_ROK(sv) assert_not_glob(sv) \ - SvFLAGS(sv) &= ~(SVf_OK|SVf_AMAGIC| \ + SvFLAGS(sv) &= ~(SVf_OK| \ SVf_IVisUV|SVf_UTF8), \ SvFLAGS(sv) |= (SVf_POK|SVp_POK)) #define SvPOK_only_UTF8(sv) (assert_not_ROK(sv) assert_not_glob(sv) \ - SvFLAGS(sv) &= ~(SVf_OK|SVf_AMAGIC| \ + SvFLAGS(sv) &= ~(SVf_OK| \ SVf_IVisUV), \ SvFLAGS(sv) |= (SVf_POK|SVp_POK)) @@ -958,7 +958,7 @@ in gv.h: */ #define SvROK(sv) (SvFLAGS(sv) & SVf_ROK) #define SvROK_on(sv) (SvFLAGS(sv) |= SVf_ROK) -#define SvROK_off(sv) (SvFLAGS(sv) &= ~(SVf_ROK|SVf_AMAGIC)) +#define SvROK_off(sv) (SvFLAGS(sv) &= ~(SVf_ROK)) #define SvMAGICAL(sv) (SvFLAGS(sv) & (SVs_GMG|SVs_SMG|SVs_RMG)) #define SvMAGICAL_on(sv) (SvFLAGS(sv) |= (SVs_GMG|SVs_SMG|SVs_RMG)) @@ -976,11 +976,22 @@ in gv.h: */ #define SvRMAGICAL_on(sv) (SvFLAGS(sv) |= SVs_RMG) #define SvRMAGICAL_off(sv) (SvFLAGS(sv) &= ~SVs_RMG) -#define SvAMAGIC(sv) (SvFLAGS(sv) & SVf_AMAGIC) -#define SvAMAGIC_on(sv) (SvFLAGS(sv) |= SVf_AMAGIC) -#define SvAMAGIC_off(sv) (SvFLAGS(sv) &= ~SVf_AMAGIC) +#define SvAMAGIC(sv) (SvROK(sv) && (SvFLAGS(SvRV(sv)) & SVf_AMAGIC)) +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) +# define SvAMAGIC_on(sv) ({ SV *kloink = sv; \ + assert(SvROK(kloink)); \ + SvFLAGS(SvRV(kloink)) |= SVf_AMAGIC; \ + }) +# define SvAMAGIC_off(sv) ({ SV *kloink = sv; \ + if(SvROK(kloink)) \ + SvFLAGS(SvRV(kloink)) &= ~SVf_AMAGIC;\ + }) +#else +# define SvAMAGIC_on(sv) (SvFLAGS(SvRV(sv)) |= SVf_AMAGIC) +# define SvAMAGIC_off(sv) (SvROK(sv) && SvFLAGS(SvRV(sv)) &= ~SVf_AMAGIC) +#endif -#define SvGAMAGIC(sv) (SvFLAGS(sv) & (SVs_GMG|SVf_AMAGIC)) +#define SvGAMAGIC(sv) (SvGMAGICAL(sv) || SvAMAGIC(sv)) /* #define Gv_AMG(stash) \ @@ -1653,7 +1664,7 @@ Like C but doesn't process magic. #define CAN_COW_MASK (SVs_OBJECT|SVs_GMG|SVs_SMG|SVs_RMG|SVf_IOK|SVf_NOK| \ SVf_POK|SVf_ROK|SVp_IOK|SVp_NOK|SVp_POK|SVf_FAKE| \ - SVf_OOK|SVf_BREAK|SVf_READONLY|SVf_AMAGIC) + SVf_OOK|SVf_BREAK|SVf_READONLY) #define CAN_COW_FLAGS (SVp_POK|SVf_POK) #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) \ -- 1.8.3.1