__UNDEFINED__ SV_NOSTEAL sv_setsv_flags newSVsv_nomg

__UNDEFINED__ SV_NOSTEAL 16

#if ( { VERSION >= 5.7.3 } && { VERSION < 5.8.7 } ) || ( { VERSION >= 5.9.0 } && { VERSION < 5.9.2 } ) #undef sv_setsv_flags #if defined(PERL_USE_GCC_BRACE_GROUPS) #define sv_setsv_flags(dstr, sstr, flags) \ STMT_START { \ if (((flags) & SV_NOSTEAL) && (sstr) && (SvFLAGS((SV *)(sstr)) & SVs_TEMP)) { \ SvTEMP_off((SV *)(sstr)); \ Perl_sv_setsv_flags(aTHX_ (dstr), (sstr), (flags) & ~SV_NOSTEAL); \ SvTEMP_on((SV *)(sstr)); \ } else { \ Perl_sv_setsv_flags(aTHX_ (dstr), (sstr), (flags) & ~SV_NOSTEAL); \ } \ } STMT_END #else ( \ (((flags) & SV_NOSTEAL) && (sstr) && (SvFLAGS((SV *)(sstr)) & SVs_TEMP)) ? ( \ SvTEMP_off((SV *)(sstr)), \ Perl_sv_setsv_flags(aTHX_ (dstr), (sstr), (flags) & ~SV_NOSTEAL), \ SvTEMP_on((SV *)(sstr)), \ 1 \ ) : ( \ Perl_sv_setsv_flags(aTHX_ (dstr), (sstr), (flags) & ~SV_NOSTEAL), \ 1 \ ) \ ) #endif #endif

#if defined(PERL_USE_GCC_BRACE_GROUPS) __UNDEFINED__ sv_setsv_flags(dstr, sstr, flags) \ STMT_START { \ if (((flags) & SV_NOSTEAL) && (sstr) && (SvFLAGS((SV *)(sstr)) & SVs_TEMP)) { \ SvTEMP_off((SV *)(sstr)); \ if (!((flags) & SV_GMAGIC) && (sstr) && SvGMAGICAL((SV *)(sstr))) { \ SvGMAGICAL_off((SV *)(sstr)); \ sv_setsv((dstr), (sstr)); \ SvGMAGICAL_on((SV *)(sstr)); \ } else { \ sv_setsv((dstr), (sstr)); \ } \ SvTEMP_on((SV *)(sstr)); \ } else { \ if (!((flags) & SV_GMAGIC) && (sstr) && SvGMAGICAL((SV *)(sstr))) { \ SvGMAGICAL_off((SV *)(sstr)); \ sv_setsv((dstr), (sstr)); \ SvGMAGICAL_on((SV *)(sstr)); \ } else { \ sv_setsv((dstr), (sstr)); \ } \ } \ } STMT_END #else __UNDEFINED__ sv_setsv_flags(dstr, sstr, flags) \ ( \ (((flags) & SV_NOSTEAL) && (sstr) && (SvFLAGS((SV *)(sstr)) & SVs_TEMP)) ? ( \ SvTEMP_off((SV *)(sstr)), \ (!((flags) & SV_GMAGIC) && (sstr) && SvGMAGICAL((SV *)(sstr))) ? ( \ SvGMAGICAL_off((SV *)(sstr)), \ sv_setsv((dstr), (sstr)), \ SvGMAGICAL_on((SV *)(sstr)), \ 1 \ ) : ( \ sv_setsv((dstr), (sstr)), \ 1 \ ), \ SvTEMP_on((SV *)(sstr)), \ 1 \ ) : ( \ (!((flags) & SV_GMAGIC) && (sstr) && SvGMAGICAL((SV *)(sstr))) ? ( \ SvGMAGICAL_off((SV *)(sstr)), \ sv_setsv((dstr), (sstr)), \ SvGMAGICAL_on((SV *)(sstr)), \ 1 \ ) : ( \ sv_setsv((dstr), (sstr)), \ 1 \ ) \ ) \ ) #endif

#if defined(PERL_USE_GCC_BRACE_GROUPS) __UNDEFINED__ newSVsv_flags(sv, flags) ({ SV *_sv = newSV(0); sv_setsv_flags(_sv, (sv), (flags)); _sv; }) #else __UNDEFINED__ newSVsv_flags(sv, flags) ((PL_Sv = newSV(0)), sv_setsv_flags(PL_Sv, (sv), (flags)), PL_Sv) #endif

__UNDEFINED__ newSVsv_nomg(sv) newSVsv_flags((sv), SV_NOSTEAL)

#if { VERSION >= 5.17.5 } __UNDEFINED__ sv_mortalcopy_flags(sv, flags) Perl_sv_mortalcopy_flags(aTHX_ (sv), (flags)) #else __UNDEFINED__ sv_mortalcopy_flags(sv, flags) sv_2mortal(newSVsv_flags((sv), (flags))) #endif

__UNDEFINED__ SvMAGIC_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END

#if { VERSION < 5.9.3 }

__UNDEFINED__ SvPVX_const(sv) ((const char*) (0 + SvPVX(sv))) __UNDEFINED__ SvPVX_mutable(sv) (0 + SvPVX(sv))

__UNDEFINED__ SvRV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ (((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END

#else

__UNDEFINED__ SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv)) __UNDEFINED__ SvPVX_mutable(sv) ((sv)->sv_u.svu_pv)

__UNDEFINED__ SvRV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ ((sv)->sv_u.svu_rv = (val)); } STMT_END

#endif

__UNDEFINED__ SvSTASH_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END

#if { VERSION < 5.004 }

__UNDEFINED__ SvUV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END

#else

__UNDEFINED__ SvUV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END

#endif

IV TestSvUV_set(sv, val) SV *sv UV val CODE: SvUV_set(sv, val); RETVAL = SvUVX(sv) == val ? 42 : -1; OUTPUT: RETVAL

IV TestSvPVX_const(sv) SV *sv CODE: RETVAL = strEQ(SvPVX_const(sv), "mhx") ? 43 : -1; OUTPUT: RETVAL

IV TestSvPVX_mutable(sv) SV *sv CODE: RETVAL = strEQ(SvPVX_mutable(sv), "mhx") ? 44 : -1; OUTPUT: RETVAL

void TestSvSTASH_set(sv, name) SV *sv char *name CODE: sv = SvRV(sv); SvREFCNT_dec(SvSTASH(sv)); SvSTASH_set(sv, (HV*) SvREFCNT_inc(gv_stashpv(name, 0)));

IV Test_sv_setsv_SV_NOSTEAL() PREINIT: SV *sv1, *sv2; CODE: sv1 = sv_2mortal(newSVpv("test1", 0)); sv2 = sv_2mortal(newSVpv("test2", 0)); sv_setsv_flags(sv2, sv1, SV_NOSTEAL); RETVAL = (strEQ(SvPV_nolen(sv1), "test1") && strEQ(SvPV_nolen(sv2), "test1")); OUTPUT: RETVAL

SV * newSVsv_nomg(sv) SV *sv CODE: RETVAL = newSVsv_nomg(sv); OUTPUT: RETVAL

void sv_setsv_compile_test(sv) SV *sv CODE: sv_setsv(sv, NULL); sv_setsv_flags(sv, NULL, 0); sv_setsv_flags(sv, NULL, SV_NOSTEAL);

my $foo = 5; is(&Devel::PPPort::TestSvUV_set($foo, 12345), 42); is(&Devel::PPPort::TestSvPVX_const("mhx"), 43); is(&Devel::PPPort::TestSvPVX_mutable("mhx"), 44);

my $bar = [];

bless $bar, 'foo'; is($bar->x(), 'foobar');

Devel::PPPort::TestSvSTASH_set($bar, 'bar'); is($bar->x(), 'hacker');

if (ivers($]) != ivers(5.7.2)) {
    ok(Devel::PPPort::Test_sv_setsv_SV_NOSTEAL());
}
else {
    skip("7.2 broken for NOSTEAL", 1);
}

tie my $scalar, 'TieScalarCounter', 'string';

is tied($scalar)->{fetch}, 0;
is tied($scalar)->{store}, 0;
my $copy = Devel::PPPort::newSVsv_nomg($scalar);
is tied($scalar)->{fetch}, 0;
is tied($scalar)->{store}, 0;

my $fetch = $scalar;
is tied($scalar)->{fetch}, 1;
is tied($scalar)->{store}, 0;
my $copy2 = Devel::PPPort::newSVsv_nomg($scalar);
is tied($scalar)->{fetch}, 1;
is tied($scalar)->{store}, 0;
is $copy2, 'string';

package TieScalarCounter;

sub TIESCALAR { my ($class, $value) = @_; return bless { fetch => 0, store => 0, value => $value }, $class; }

sub FETCH { my ($self) = @_; $self->{fetch}++; return $self->{value}; }

sub STORE { my ($self, $value) = @_; $self->{store}++; $self->{value} = $value; }

package foo;

sub x { 'foobar' }

package bar;

sub x { 'hacker' }

cpanm ATOOMIC/Devel-PPPort-3.60_01.tar.gz

perl -MCPAN -e shell
install ATOOMIC/Devel-PPPort-3.60_01.tar.gz