1################################################################################ 2## 3## Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz. 4## Version 2.x, Copyright (C) 2001, Paul Marquess. 5## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. 6## 7## This program is free software; you can redistribute it and/or 8## modify it under the same terms as Perl itself. 9## 10################################################################################ 11 12=provides 13 14__UNDEFINED__ 15SV_NOSTEAL 16sv_setsv_flags 17newSVsv_nomg 18newSVsv_flags 19 20=implementation 21 22__UNDEFINED__ SV_NOSTEAL 16 23 24#if ( { VERSION >= 5.7.3 } && { VERSION < 5.8.7 } ) || ( { VERSION >= 5.9.0 } && { VERSION < 5.9.2 } ) 25#undef sv_setsv_flags 26#if defined(PERL_USE_GCC_BRACE_GROUPS) 27#define sv_setsv_flags(dstr, sstr, flags) \ 28 STMT_START { \ 29 if (((flags) & SV_NOSTEAL) && (sstr) && (SvFLAGS((SV *)(sstr)) & SVs_TEMP)) { \ 30 SvTEMP_off((SV *)(sstr)); \ 31 Perl_sv_setsv_flags(aTHX_ (dstr), (sstr), (flags) & ~SV_NOSTEAL); \ 32 SvTEMP_on((SV *)(sstr)); \ 33 } else { \ 34 Perl_sv_setsv_flags(aTHX_ (dstr), (sstr), (flags) & ~SV_NOSTEAL); \ 35 } \ 36 } STMT_END 37#else 38#define sv_setsv_flags(dstr, sstr, flags) \ 39 ( \ 40 (((flags) & SV_NOSTEAL) && (sstr) && (SvFLAGS((SV *)(sstr)) & SVs_TEMP)) ? ( \ 41 SvTEMP_off((SV *)(sstr)), \ 42 Perl_sv_setsv_flags(aTHX_ (dstr), (sstr), (flags) & ~SV_NOSTEAL), \ 43 SvTEMP_on((SV *)(sstr)), \ 44 1 \ 45 ) : ( \ 46 Perl_sv_setsv_flags(aTHX_ (dstr), (sstr), (flags) & ~SV_NOSTEAL), \ 47 1 \ 48 ) \ 49 ) 50#endif 51#endif 52 53#if defined(PERL_USE_GCC_BRACE_GROUPS) 54__UNDEFINED__ sv_setsv_flags(dstr, sstr, flags) \ 55 STMT_START { \ 56 if (((flags) & SV_NOSTEAL) && (sstr) && (SvFLAGS((SV *)(sstr)) & SVs_TEMP)) { \ 57 SvTEMP_off((SV *)(sstr)); \ 58 if (!((flags) & SV_GMAGIC) && (sstr) && SvGMAGICAL((SV *)(sstr))) { \ 59 SvGMAGICAL_off((SV *)(sstr)); \ 60 sv_setsv((dstr), (sstr)); \ 61 SvGMAGICAL_on((SV *)(sstr)); \ 62 } else { \ 63 sv_setsv((dstr), (sstr)); \ 64 } \ 65 SvTEMP_on((SV *)(sstr)); \ 66 } else { \ 67 if (!((flags) & SV_GMAGIC) && (sstr) && SvGMAGICAL((SV *)(sstr))) { \ 68 SvGMAGICAL_off((SV *)(sstr)); \ 69 sv_setsv((dstr), (sstr)); \ 70 SvGMAGICAL_on((SV *)(sstr)); \ 71 } else { \ 72 sv_setsv((dstr), (sstr)); \ 73 } \ 74 } \ 75 } STMT_END 76#else 77__UNDEFINED__ sv_setsv_flags(dstr, sstr, flags) \ 78 ( \ 79 (((flags) & SV_NOSTEAL) && (sstr) && (SvFLAGS((SV *)(sstr)) & SVs_TEMP)) ? ( \ 80 SvTEMP_off((SV *)(sstr)), \ 81 (!((flags) & SV_GMAGIC) && (sstr) && SvGMAGICAL((SV *)(sstr))) ? ( \ 82 SvGMAGICAL_off((SV *)(sstr)), \ 83 sv_setsv((dstr), (sstr)), \ 84 SvGMAGICAL_on((SV *)(sstr)), \ 85 1 \ 86 ) : ( \ 87 sv_setsv((dstr), (sstr)), \ 88 1 \ 89 ), \ 90 SvTEMP_on((SV *)(sstr)), \ 91 1 \ 92 ) : ( \ 93 (!((flags) & SV_GMAGIC) && (sstr) && SvGMAGICAL((SV *)(sstr))) ? ( \ 94 SvGMAGICAL_off((SV *)(sstr)), \ 95 sv_setsv((dstr), (sstr)), \ 96 SvGMAGICAL_on((SV *)(sstr)), \ 97 1 \ 98 ) : ( \ 99 sv_setsv((dstr), (sstr)), \ 100 1 \ 101 ) \ 102 ) \ 103 ) 104#endif 105 106#ifndef newSVsv_flags 107# if defined(PERL_USE_GCC_BRACE_GROUPS) 108# define newSVsv_flags(sv, flags) \ 109 ({ \ 110 SV *n= newSV(0); \ 111 sv_setsv_flags(n, (sv), (flags)); \ 112 n; \ 113 }) 114# else 115 PERL_STATIC_INLINE SV* D_PPP_newSVsv_flags(SV *const old, I32 flags) 116 { 117 dTHX; 118 SV *n= newSV(0); 119 sv_setsv_flags(n, old, flags); 120 return n; 121 } 122# define newSVsv_flags(sv, flags) D_PPP_newSVsv_flags(sv, flags) 123# endif 124#endif 125 126__UNDEFINED__ newSVsv_nomg(sv) newSVsv_flags((sv), SV_NOSTEAL) 127 128#if { VERSION >= 5.17.5 } 129__UNDEFINED__ sv_mortalcopy_flags(sv, flags) Perl_sv_mortalcopy_flags(aTHX_ (sv), (flags)) 130#else 131__UNDEFINED__ sv_mortalcopy_flags(sv, flags) sv_2mortal(newSVsv_flags((sv), (flags))) 132#endif 133 134__UNDEFINED__ SvMAGIC_set(sv, val) \ 135 STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ 136 (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END 137 138#if { VERSION < 5.9.3 } 139 140__UNDEFINED__ SvPVX_const(sv) ((const char*) (0 + SvPVX(sv))) 141__UNDEFINED__ SvPVX_mutable(sv) (0 + SvPVX(sv)) 142 143__UNDEFINED__ SvRV_set(sv, val) \ 144 STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ 145 (((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END 146 147#else 148 149__UNDEFINED__ SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv)) 150__UNDEFINED__ SvPVX_mutable(sv) ((sv)->sv_u.svu_pv) 151 152__UNDEFINED__ SvRV_set(sv, val) \ 153 STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ 154 ((sv)->sv_u.svu_rv = (val)); } STMT_END 155 156#endif 157 158__UNDEFINED__ SvSTASH_set(sv, val) \ 159 STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ 160 (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END 161 162#if { VERSION < 5.004 } 163 164__UNDEFINED__ SvUV_set(sv, val) \ 165 STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ 166 (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END 167 168#else 169 170__UNDEFINED__ SvUV_set(sv, val) \ 171 STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ 172 (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END 173 174#endif 175 176=xsubs 177 178IV 179TestSvUV_set(sv, val) 180 SV *sv 181 UV val 182 CODE: 183 SvUV_set(sv, val); 184 RETVAL = SvUVX(sv) == val ? 42 : -1; 185 OUTPUT: 186 RETVAL 187 188IV 189TestSvPVX_const(sv) 190 SV *sv 191 CODE: 192 RETVAL = strEQ(SvPVX_const(sv), "mhx") ? 43 : -1; 193 OUTPUT: 194 RETVAL 195 196IV 197TestSvPVX_mutable(sv) 198 SV *sv 199 CODE: 200 RETVAL = strEQ(SvPVX_mutable(sv), "mhx") ? 44 : -1; 201 OUTPUT: 202 RETVAL 203 204void 205TestSvSTASH_set(sv, name) 206 SV *sv 207 char *name 208 CODE: 209 sv = SvRV(sv); 210 SvREFCNT_dec(SvSTASH(sv)); 211 SvSTASH_set(sv, (HV*) SvREFCNT_inc(gv_stashpv(name, 0))); 212 213IV 214Test_sv_setsv_SV_NOSTEAL() 215 PREINIT: 216 SV *sv1, *sv2; 217 CODE: 218 sv1 = sv_2mortal(newSVpv("test1", 0)); 219 sv2 = sv_2mortal(newSVpv("test2", 0)); 220 sv_setsv_flags(sv2, sv1, SV_NOSTEAL); 221 RETVAL = (strEQ(SvPV_nolen(sv1), "test1") && strEQ(SvPV_nolen(sv2), "test1")); 222 OUTPUT: 223 RETVAL 224 225SV * 226newSVsv_nomg(sv) 227 SV *sv 228 CODE: 229 RETVAL = newSVsv_nomg(sv); 230 OUTPUT: 231 RETVAL 232 233void 234sv_setsv_compile_test(sv) 235 SV *sv 236 CODE: 237 sv_setsv(sv, NULL); 238 sv_setsv_flags(sv, NULL, 0); 239 sv_setsv_flags(sv, NULL, SV_NOSTEAL); 240 241=tests plan => 15 242 243my $foo = 5; 244is(&Devel::PPPort::TestSvUV_set($foo, 12345), 42); 245is(&Devel::PPPort::TestSvPVX_const("mhx"), 43); 246is(&Devel::PPPort::TestSvPVX_mutable("mhx"), 44); 247 248my $bar = []; 249 250bless $bar, 'foo'; 251is($bar->x(), 'foobar'); 252 253Devel::PPPort::TestSvSTASH_set($bar, 'bar'); 254is($bar->x(), 'hacker'); 255 256 if (ivers($]) != ivers(5.7.2)) { 257 ok(Devel::PPPort::Test_sv_setsv_SV_NOSTEAL()); 258 } 259 else { 260 skip("7.2 broken for NOSTEAL", 1); 261 } 262 263 tie my $scalar, 'TieScalarCounter', 'string'; 264 265 is tied($scalar)->{fetch}, 0; 266 is tied($scalar)->{store}, 0; 267 my $copy = Devel::PPPort::newSVsv_nomg($scalar); 268 is tied($scalar)->{fetch}, 0; 269 is tied($scalar)->{store}, 0; 270 271 my $fetch = $scalar; 272 is tied($scalar)->{fetch}, 1; 273 is tied($scalar)->{store}, 0; 274 my $copy2 = Devel::PPPort::newSVsv_nomg($scalar); 275 is tied($scalar)->{fetch}, 1; 276 is tied($scalar)->{store}, 0; 277 is $copy2, 'string'; 278 279package TieScalarCounter; 280 281sub TIESCALAR { 282 my ($class, $value) = @_; 283 return bless { fetch => 0, store => 0, value => $value }, $class; 284} 285 286sub FETCH { 287 my ($self) = @_; 288 $self->{fetch}++; 289 return $self->{value}; 290} 291 292sub STORE { 293 my ($self, $value) = @_; 294 $self->{store}++; 295 $self->{value} = $value; 296} 297 298package foo; 299 300sub x { 'foobar' } 301 302package bar; 303 304sub x { 'hacker' } 305