dist/Devel-PPPort/parts/inc/Sv_set

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