cpan/Devel-PPPort/parts/inc/magic

   1 ################################################################################
   2 ##
   3 ##  $Revision: 21 $
   4 ##  $Author: mhx $
   5 ##  $Date: 2010/03/07 13:15:49 +0100 $
   6 ##
   7 ################################################################################
   8 ##
   9 ##  Version 3.x, Copyright (C) 2004-2010, 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 /sv_\w+_mg/
  22 sv_magic_portable
  23
  24 =implementation
  25
  26 __UNDEFINED__  SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
  27
  28 __UNDEFINED__  PERL_MAGIC_sv              '\0'
  29 __UNDEFINED__  PERL_MAGIC_overload        'A'
  30 __UNDEFINED__  PERL_MAGIC_overload_elem   'a'
  31 __UNDEFINED__  PERL_MAGIC_overload_table  'c'
  32 __UNDEFINED__  PERL_MAGIC_bm              'B'
  33 __UNDEFINED__  PERL_MAGIC_regdata         'D'
  34 __UNDEFINED__  PERL_MAGIC_regdatum        'd'
  35 __UNDEFINED__  PERL_MAGIC_env             'E'
  36 __UNDEFINED__  PERL_MAGIC_envelem         'e'
  37 __UNDEFINED__  PERL_MAGIC_fm              'f'
  38 __UNDEFINED__  PERL_MAGIC_regex_global    'g'
  39 __UNDEFINED__  PERL_MAGIC_isa             'I'
  40 __UNDEFINED__  PERL_MAGIC_isaelem         'i'
  41 __UNDEFINED__  PERL_MAGIC_nkeys           'k'
  42 __UNDEFINED__  PERL_MAGIC_dbfile          'L'
  43 __UNDEFINED__  PERL_MAGIC_dbline          'l'
  44 __UNDEFINED__  PERL_MAGIC_mutex           'm'
  45 __UNDEFINED__  PERL_MAGIC_shared          'N'
  46 __UNDEFINED__  PERL_MAGIC_shared_scalar   'n'
  47 __UNDEFINED__  PERL_MAGIC_collxfrm        'o'
  48 __UNDEFINED__  PERL_MAGIC_tied            'P'
  49 __UNDEFINED__  PERL_MAGIC_tiedelem        'p'
  50 __UNDEFINED__  PERL_MAGIC_tiedscalar      'q'
  51 __UNDEFINED__  PERL_MAGIC_qr              'r'
  52 __UNDEFINED__  PERL_MAGIC_sig             'S'
  53 __UNDEFINED__  PERL_MAGIC_sigelem         's'
  54 __UNDEFINED__  PERL_MAGIC_taint           't'
  55 __UNDEFINED__  PERL_MAGIC_uvar            'U'
  56 __UNDEFINED__  PERL_MAGIC_uvar_elem       'u'
  57 __UNDEFINED__  PERL_MAGIC_vstring         'V'
  58 __UNDEFINED__  PERL_MAGIC_vec             'v'
  59 __UNDEFINED__  PERL_MAGIC_utf8            'w'
  60 __UNDEFINED__  PERL_MAGIC_substr          'x'
  61 __UNDEFINED__  PERL_MAGIC_defelem         'y'
  62 __UNDEFINED__  PERL_MAGIC_glob            '*'
  63 __UNDEFINED__  PERL_MAGIC_arylen          '#'
  64 __UNDEFINED__  PERL_MAGIC_pos             '.'
  65 __UNDEFINED__  PERL_MAGIC_backref         '<'
  66 __UNDEFINED__  PERL_MAGIC_ext             '~'
  67
  68 /* That's the best we can do... */
  69 __UNDEFINED__  sv_catpvn_nomg     sv_catpvn
  70 __UNDEFINED__  sv_catsv_nomg      sv_catsv
  71 __UNDEFINED__  sv_setsv_nomg      sv_setsv
  72 __UNDEFINED__  sv_pvn_nomg        sv_pvn
  73 __UNDEFINED__  SvIV_nomg          SvIV
  74 __UNDEFINED__  SvUV_nomg          SvUV
  75
  76 #ifndef sv_catpv_mg
  77 #  define sv_catpv_mg(sv, ptr)          \
  78    STMT_START {                         \
  79      SV *TeMpSv = sv;                   \
  80      sv_catpv(TeMpSv,ptr);              \
  81      SvSETMAGIC(TeMpSv);                \
  82    } STMT_END
  83 #endif
  84
  85 #ifndef sv_catpvn_mg
  86 #  define sv_catpvn_mg(sv, ptr, len)    \
  87    STMT_START {                         \
  88      SV *TeMpSv = sv;                   \
  89      sv_catpvn(TeMpSv,ptr,len);         \
  90      SvSETMAGIC(TeMpSv);                \
  91    } STMT_END
  92 #endif
  93
  94 #ifndef sv_catsv_mg
  95 #  define sv_catsv_mg(dsv, ssv)         \
  96    STMT_START {                         \
  97      SV *TeMpSv = dsv;                  \
  98      sv_catsv(TeMpSv,ssv);              \
  99      SvSETMAGIC(TeMpSv);                \
 100    } STMT_END
 101 #endif
 102
 103 #ifndef sv_setiv_mg
 104 #  define sv_setiv_mg(sv, i)            \
 105    STMT_START {                         \
 106      SV *TeMpSv = sv;                   \
 107      sv_setiv(TeMpSv,i);                \
 108      SvSETMAGIC(TeMpSv);                \
 109    } STMT_END
 110 #endif
 111
 112 #ifndef sv_setnv_mg
 113 #  define sv_setnv_mg(sv, num)          \
 114    STMT_START {                         \
 115      SV *TeMpSv = sv;                   \
 116      sv_setnv(TeMpSv,num);              \
 117      SvSETMAGIC(TeMpSv);                \
 118    } STMT_END
 119 #endif
 120
 121 #ifndef sv_setpv_mg
 122 #  define sv_setpv_mg(sv, ptr)          \
 123    STMT_START {                         \
 124      SV *TeMpSv = sv;                   \
 125      sv_setpv(TeMpSv,ptr);              \
 126      SvSETMAGIC(TeMpSv);                \
 127    } STMT_END
 128 #endif
 129
 130 #ifndef sv_setpvn_mg
 131 #  define sv_setpvn_mg(sv, ptr, len)    \
 132    STMT_START {                         \
 133      SV *TeMpSv = sv;                   \
 134      sv_setpvn(TeMpSv,ptr,len);         \
 135      SvSETMAGIC(TeMpSv);                \
 136    } STMT_END
 137 #endif
 138
 139 #ifndef sv_setsv_mg
 140 #  define sv_setsv_mg(dsv, ssv)         \
 141    STMT_START {                         \
 142      SV *TeMpSv = dsv;                  \
 143      sv_setsv(TeMpSv,ssv);              \
 144      SvSETMAGIC(TeMpSv);                \
 145    } STMT_END
 146 #endif
 147
 148 #ifndef sv_setuv_mg
 149 #  define sv_setuv_mg(sv, i)            \
 150    STMT_START {                         \
 151      SV *TeMpSv = sv;                   \
 152      sv_setuv(TeMpSv,i);                \
 153      SvSETMAGIC(TeMpSv);                \
 154    } STMT_END
 155 #endif
 156
 157 #ifndef sv_usepvn_mg
 158 #  define sv_usepvn_mg(sv, ptr, len)    \
 159    STMT_START {                         \
 160      SV *TeMpSv = sv;                   \
 161      sv_usepvn(TeMpSv,ptr,len);         \
 162      SvSETMAGIC(TeMpSv);                \
 163    } STMT_END
 164 #endif
 165
 166 __UNDEFINED__  SvVSTRING_mg(sv)  (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL)
 167
 168 /* Hint: sv_magic_portable
 169  * This is a compatibility function that is only available with
 170  * Devel::PPPort. It is NOT in the perl core.
 171  * Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when
 172  * it is being passed a name pointer with namlen == 0. In that
 173  * case, perl 5.8.0 and later store the pointer, not a copy of it.
 174  * The compatibility can be provided back to perl 5.004. With
 175  * earlier versions, the code will not compile.
 176  */
 177
 178 #if { VERSION < 5.004 }
 179
 180   /* code that uses sv_magic_portable will not compile */
 181
 182 #elif { VERSION < 5.8.0 }
 183
 184 #  define sv_magic_portable(sv, obj, how, name, namlen)     \
 185    STMT_START {                                             \
 186      SV *SvMp_sv = (sv);                                    \
 187      char *SvMp_name = (char *) (name);                     \
 188      I32 SvMp_namlen = (namlen);                            \
 189      if (SvMp_name && SvMp_namlen == 0)                     \
 190      {                                                      \
 191        MAGIC *mg;                                           \
 192        sv_magic(SvMp_sv, obj, how, 0, 0);                   \
 193        mg = SvMAGIC(SvMp_sv);                               \
 194        mg->mg_len = -42; /* XXX: this is the tricky part */ \
 195        mg->mg_ptr = SvMp_name;                              \
 196      }                                                      \
 197      else                                                   \
 198      {                                                      \
 199        sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \
 200      }                                                      \
 201    } STMT_END
 202
 203 #else
 204
 205 #  define sv_magic_portable(a, b, c, d, e)  sv_magic(a, b, c, d, e)
 206
 207 #endif
 208
 209 =xsubs
 210
 211 void
 212 sv_catpv_mg(sv, string)
 213         SV *sv;
 214         char *string;
 215         CODE:
 216                 sv_catpv_mg(sv, string);
 217
 218 void
 219 sv_catpvn_mg(sv, sv2)
 220         SV *sv;
 221         SV *sv2;
 222         PREINIT:
 223                 char *str;
 224                 STRLEN len;
 225         CODE:
 226                 str = SvPV(sv2, len);
 227                 sv_catpvn_mg(sv, str, len);
 228
 229 void
 230 sv_catsv_mg(sv, sv2)
 231         SV *sv;
 232         SV *sv2;
 233         CODE:
 234                 sv_catsv_mg(sv, sv2);
 235
 236 void
 237 sv_setiv_mg(sv, iv)
 238         SV *sv;
 239         IV iv;
 240         CODE:
 241                 sv_setiv_mg(sv, iv);
 242
 243 void
 244 sv_setnv_mg(sv, nv)
 245         SV *sv;
 246         NV nv;
 247         CODE:
 248                 sv_setnv_mg(sv, nv);
 249
 250 void
 251 sv_setpv_mg(sv, pv)
 252         SV *sv;
 253         char *pv;
 254         CODE:
 255                 sv_setpv_mg(sv, pv);
 256
 257 void
 258 sv_setpvn_mg(sv, sv2)
 259         SV *sv;
 260         SV *sv2;
 261         PREINIT:
 262                 char *str;
 263                 STRLEN len;
 264         CODE:
 265                 str = SvPV(sv2, len);
 266                 sv_setpvn_mg(sv, str, len);
 267
 268 void
 269 sv_setsv_mg(sv, sv2)
 270         SV *sv;
 271         SV *sv2;
 272         CODE:
 273                 sv_setsv_mg(sv, sv2);
 274
 275 void
 276 sv_setuv_mg(sv, uv)
 277         SV *sv;
 278         UV uv;
 279         CODE:
 280                 sv_setuv_mg(sv, uv);
 281
 282 void
 283 sv_usepvn_mg(sv, sv2)
 284         SV *sv;
 285         SV *sv2;
 286         PREINIT:
 287                 char *str, *copy;
 288                 STRLEN len;
 289         CODE:
 290                 str = SvPV(sv2, len);
 291                 New(42, copy, len+1, char);
 292                 Copy(str, copy, len+1, char);
 293                 sv_usepvn_mg(sv, copy, len);
 294
 295 int
 296 SvVSTRING_mg(sv)
 297         SV *sv;
 298         CODE:
 299                 RETVAL = SvVSTRING_mg(sv) != NULL;
 300         OUTPUT:
 301                 RETVAL
 302
 303 int
 304 sv_magic_portable(sv)
 305         SV *sv
 306         PREINIT:
 307                 MAGIC *mg;
 308                 const char *foo = "foo";
 309         CODE:
 310 #if { VERSION >= 5.004 }
 311                 sv_magic_portable(sv, 0, '~', foo, 0);
 312                 mg = mg_find(sv, '~');
 313                 RETVAL = mg->mg_ptr == foo;
 314 #else
 315                 sv_magic(sv, 0, '~', (char *) foo, strlen(foo));
 316                 mg = mg_find(sv, '~');
 317                 RETVAL = strEQ(mg->mg_ptr, foo);
 318 #endif
 319                 sv_unmagic(sv, '~');
 320         OUTPUT:
 321                 RETVAL
 322
 323 =tests plan => 15
 324
 325 use Tie::Hash;
 326 my %h;
 327 tie %h, 'Tie::StdHash';
 328 $h{foo} = 'foo';
 329 $h{bar} = '';
 330
 331 &Devel::PPPort::sv_catpv_mg($h{foo}, 'bar');
 332 ok($h{foo}, 'foobar');
 333
 334 &Devel::PPPort::sv_catpvn_mg($h{bar}, 'baz');
 335 ok($h{bar}, 'baz');
 336
 337 &Devel::PPPort::sv_catsv_mg($h{foo}, '42');
 338 ok($h{foo}, 'foobar42');
 339
 340 &Devel::PPPort::sv_setiv_mg($h{bar}, 42);
 341 ok($h{bar}, 42);
 342
 343 &Devel::PPPort::sv_setnv_mg($h{PI}, 3.14159);
 344 ok(abs($h{PI} - 3.14159) < 0.01);
 345
 346 &Devel::PPPort::sv_setpv_mg($h{mhx}, 'mhx');
 347 ok($h{mhx}, 'mhx');
 348
 349 &Devel::PPPort::sv_setpvn_mg($h{mhx}, 'Marcus');
 350 ok($h{mhx}, 'Marcus');
 351
 352 &Devel::PPPort::sv_setsv_mg($h{sv}, 'SV');
 353 ok($h{sv}, 'SV');
 354
 355 &Devel::PPPort::sv_setuv_mg($h{sv}, 4711);
 356 ok($h{sv}, 4711);
 357
 358 &Devel::PPPort::sv_usepvn_mg($h{sv}, 'Perl');
 359 ok($h{sv}, 'Perl');
 360
 361 # v1 is treated as a bareword in older perls...
 362 my $ver = do { local $SIG{'__WARN__'} = sub {}; eval qq[v1.2.0] };
 363 ok($] < 5.009 || $@ eq '');
 364 ok($] < 5.009 || Devel::PPPort::SvVSTRING_mg($ver));
 365 ok(!Devel::PPPort::SvVSTRING_mg(4711));
 366
 367 my $foo = 'bar';
 368 ok(Devel::PPPort::sv_magic_portable($foo));
 369 ok($foo eq 'bar');
 370