cpan/Devel-PPPort/parts/inc/Sv_set

   1 ################################################################################
   2 ##
   3 ##  $Revision: 7 $
   4 ##  $Author: mhx $
   5 ##  $Date: 2009/01/18 14:10:53 +0100 $
   6 ##
   7 ################################################################################
   8 ##
   9 ##  Version 3.x, Copyright (C) 2004-2009, Marcus Holland-Moritz.
  10 ##  Version 2.x, Copyright (C) 2001, Paul Marquess.
  11 ##  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
  12 ##
  13 ##  This program is free software; you can redistribute it and/or
  14 ##  modify it under the same terms as Perl itself.
  15 ##
  16 ################################################################################
  17
  18 =provides
  19
  20 __UNDEFINED__
  21
  22 =implementation
  23
  24 __UNDEFINED__ SvMAGIC_set(sv, val) \
  25                 STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \
  26                 (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END
  27
  28 #if { VERSION < 5.9.3 }
  29
  30 __UNDEFINED__ SvPVX_const(sv)     ((const char*) (0 + SvPVX(sv)))
  31 __UNDEFINED__ SvPVX_mutable(sv)   (0 + SvPVX(sv))
  32
  33 __UNDEFINED__ SvRV_set(sv, val) \
  34                 STMT_START { assert(SvTYPE(sv) >=  SVt_RV); \
  35                 (((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END
  36
  37 #else
  38
  39 __UNDEFINED__ SvPVX_const(sv)     ((const char*)((sv)->sv_u.svu_pv))
  40 __UNDEFINED__ SvPVX_mutable(sv)   ((sv)->sv_u.svu_pv)
  41
  42 __UNDEFINED__ SvRV_set(sv, val) \
  43                 STMT_START { assert(SvTYPE(sv) >=  SVt_RV); \
  44                 ((sv)->sv_u.svu_rv = (val)); } STMT_END
  45
  46 #endif
  47
  48 __UNDEFINED__ SvSTASH_set(sv, val) \
  49                 STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \
  50                 (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END
  51
  52 #if { VERSION < 5.004 }
  53
  54 __UNDEFINED__ SvUV_set(sv, val) \
  55                 STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \
  56                 (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END
  57
  58 #else
  59
  60 __UNDEFINED__ SvUV_set(sv, val) \
  61                 STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \
  62                 (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END
  63
  64 #endif
  65
  66 =xsubs
  67
  68 IV
  69 TestSvUV_set(sv, val)
  70         SV *sv
  71         UV val
  72         CODE:
  73                 SvUV_set(sv, val);
  74                 RETVAL = SvUVX(sv) == val ? 42 : -1;
  75         OUTPUT:
  76                 RETVAL
  77
  78 IV
  79 TestSvPVX_const(sv)
  80         SV *sv
  81         CODE:
  82                 RETVAL = strEQ(SvPVX_const(sv), "mhx") ? 43 : -1;
  83         OUTPUT:
  84                 RETVAL
  85
  86 IV
  87 TestSvPVX_mutable(sv)
  88         SV *sv
  89         CODE:
  90                 RETVAL = strEQ(SvPVX_mutable(sv), "mhx") ? 44 : -1;
  91         OUTPUT:
  92                 RETVAL
  93
  94 void
  95 TestSvSTASH_set(sv, name)
  96         SV *sv
  97         char *name
  98         CODE:
  99                 sv = SvRV(sv);
 100                 SvREFCNT_dec(SvSTASH(sv));
 101                 SvSTASH_set(sv, (HV*) SvREFCNT_inc(gv_stashpv(name, 0)));
 102
 103 =tests plan => 5
 104
 105 my $foo = 5;
 106 ok(&Devel::PPPort::TestSvUV_set($foo, 12345), 42);
 107 ok(&Devel::PPPort::TestSvPVX_const("mhx"), 43);
 108 ok(&Devel::PPPort::TestSvPVX_mutable("mhx"), 44);
 109
 110 my $bar = [];
 111
 112 bless $bar, 'foo';
 113 ok($bar->x(), 'foobar');
 114
 115 Devel::PPPort::TestSvSTASH_set($bar, 'bar');
 116 ok($bar->x(), 'hacker');
 117
 118 package foo;
 119
 120 sub x { 'foobar' }
 121
 122 package bar;
 123
 124 sub x { 'hacker' }