ext/Devel/PPPort/parts/inc/misc

   1 ################################################################################
   2 ##
   3 ##  $Revision: 20 $
   4 ##  $Author: mhx $
   5 ##  $Date: 2005/02/02 19:17:33 +0100 $
   6 ##
   7 ################################################################################
   8 ##
   9 ##  Version 3.x, Copyright (C) 2004-2005, 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 PERL_UNUSED_DECL
  22 PERL_GCC_BRACE_GROUPS_FORBIDDEN
  23 NVTYPE
  24 INT2PTR
  25 PTRV
  26 NUM2PTR
  27 PTR2IV
  28 PTR2UV
  29 PTR2NV
  30 PTR2ul
  31 START_EXTERN_C
  32 END_EXTERN_C
  33 EXTERN_C
  34 STMT_START
  35 STMT_END
  36 /PL_\w+/
  37
  38 =implementation
  39
  40 #if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5))
  41 /* Replace: 1 */
  42 #  define PL_DBsingle               DBsingle
  43 #  define PL_DBsub                  DBsub
  44 #  define PL_Sv                     Sv
  45 #  define PL_compiling              compiling
  46 #  define PL_copline                copline
  47 #  define PL_curcop                 curcop
  48 #  define PL_curstash               curstash
  49 #  define PL_debstash               debstash
  50 #  define PL_defgv                  defgv
  51 #  define PL_diehook                diehook
  52 #  define PL_dirty                  dirty
  53 #  define PL_dowarn                 dowarn
  54 #  define PL_errgv                  errgv
  55 #  define PL_hexdigit               hexdigit
  56 #  define PL_hints                  hints
  57 #  define PL_na                     na
  58 #  define PL_no_modify              no_modify
  59 #  define PL_perl_destruct_level    perl_destruct_level
  60 #  define PL_perldb                 perldb
  61 #  define PL_ppaddr                 ppaddr
  62 #  define PL_rsfp_filters           rsfp_filters
  63 #  define PL_rsfp                   rsfp
  64 #  define PL_stack_base             stack_base
  65 #  define PL_stack_sp               stack_sp
  66 #  define PL_stdingv                stdingv
  67 #  define PL_sv_arenaroot           sv_arenaroot
  68 #  define PL_sv_no                  sv_no
  69 #  define PL_sv_undef               sv_undef
  70 #  define PL_sv_yes                 sv_yes
  71 #  define PL_tainted                tainted
  72 #  define PL_tainting               tainting
  73 /* Replace: 0 */
  74 #endif
  75
  76 #ifndef PERL_UNUSED_DECL
  77 #  ifdef HASATTRIBUTE
  78 #    if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
  79 #      define PERL_UNUSED_DECL
  80 #    else
  81 #      define PERL_UNUSED_DECL __attribute__((unused))
  82 #    endif
  83 #  else
  84 #    define PERL_UNUSED_DECL
  85 #  endif
  86 #endif
  87
  88 __UNDEFINED__  NOOP          (void)0
  89 __UNDEFINED__  dNOOP         extern int Perl___notused PERL_UNUSED_DECL
  90
  91 #ifndef NVTYPE
  92 #  if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
  93 #    define NVTYPE long double
  94 #  else
  95 #    define NVTYPE double
  96 #  endif
  97 typedef NVTYPE NV;
  98 #endif
  99
 100 #ifndef INT2PTR
 101
 102 #  if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
 103 #    define PTRV                  UV
 104 #    define INT2PTR(any,d)        (any)(d)
 105 #  else
 106 #    if PTRSIZE == LONGSIZE
 107 #      define PTRV                unsigned long
 108 #    else
 109 #      define PTRV                unsigned
 110 #    endif
 111 #    define INT2PTR(any,d)        (any)(PTRV)(d)
 112 #  endif
 113
 114 #  define NUM2PTR(any,d)  (any)(PTRV)(d)
 115 #  define PTR2IV(p)       INT2PTR(IV,p)
 116 #  define PTR2UV(p)       INT2PTR(UV,p)
 117 #  define PTR2NV(p)       NUM2PTR(NV,p)
 118
 119 #  if PTRSIZE == LONGSIZE
 120 #    define PTR2ul(p)     (unsigned long)(p)
 121 #  else
 122 #    define PTR2ul(p)     INT2PTR(unsigned long,p)
 123 #  endif
 124
 125 #endif /* !INT2PTR */
 126
 127 #undef START_EXTERN_C
 128 #undef END_EXTERN_C
 129 #undef EXTERN_C
 130 #ifdef __cplusplus
 131 #  define START_EXTERN_C extern "C" {
 132 #  define END_EXTERN_C }
 133 #  define EXTERN_C extern "C"
 134 #else
 135 #  define START_EXTERN_C
 136 #  define END_EXTERN_C
 137 #  define EXTERN_C extern
 138 #endif
 139
 140 #ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
 141 #  if defined(__STRICT_ANSI__) && defined(PERL_GCC_PEDANTIC)
 142 #    define PERL_GCC_BRACE_GROUPS_FORBIDDEN
 143 #  endif
 144 #endif
 145
 146 #undef STMT_START
 147 #undef STMT_END
 148 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
 149 #  define STMT_START    (void)( /* gcc supports ``({ STATEMENTS; })'' */
 150 #  define STMT_END      )
 151 #else
 152 #  if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__)
 153 #    define STMT_START  if (1)
 154 #    define STMT_END    else (void)0
 155 #  else
 156 #    define STMT_START  do
 157 #    define STMT_END    while (0)
 158 #  endif
 159 #endif
 160
 161 __UNDEFINED__  boolSV(b)    ((b) ? &PL_sv_yes : &PL_sv_no)
 162
 163 /* DEFSV appears first in 5.004_56 */
 164 __UNDEFINED__  DEFSV        GvSV(PL_defgv)
 165 __UNDEFINED__  SAVE_DEFSV   SAVESPTR(GvSV(PL_defgv))
 166
 167 /* Older perls (<=5.003) lack AvFILLp */
 168 __UNDEFINED__  AvFILLp      AvFILL
 169
 170 __UNDEFINED__  ERRSV        get_sv("@",FALSE)
 171
 172 __UNDEFINED__  newSVpvn(data,len)  ((data)                                              \
 173                                     ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \
 174                                     : newSV(0))
 175
 176 /* Hint: gv_stashpvn
 177  * This function's backport doesn't support the length parameter, but
 178  * rather ignores it. Portability can only be ensured if the length
 179  * parameter is used for speed reasons, but the length can always be
 180  * correctly computed from the string argument.
 181  */
 182
 183 __UNDEFINED__  gv_stashpvn(str,len,create)  gv_stashpv(str,create)
 184
 185 /* Replace: 1 */
 186 __UNDEFINED__  get_cv          perl_get_cv
 187 __UNDEFINED__  get_sv          perl_get_sv
 188 __UNDEFINED__  get_av          perl_get_av
 189 __UNDEFINED__  get_hv          perl_get_hv
 190 /* Replace: 0 */
 191
 192 #ifdef HAS_MEMCMP
 193 __UNDEFINED__  memNE(s1,s2,l)  (memcmp(s1,s2,l))
 194 __UNDEFINED__  memEQ(s1,s2,l)  (!memcmp(s1,s2,l))
 195 #else
 196 __UNDEFINED__  memNE(s1,s2,l)  (bcmp(s1,s2,l))
 197 __UNDEFINED__  memEQ(s1,s2,l)  (!bcmp(s1,s2,l))
 198 #endif
 199
 200 __UNDEFINED__  MoveD(s,d,n,t)  memmove((char*)(d),(char*)(s), (n) * sizeof(t))
 201 __UNDEFINED__  CopyD(s,d,n,t)  memcpy((char*)(d),(char*)(s), (n) * sizeof(t))
 202 #ifdef HAS_MEMSET
 203 __UNDEFINED__  ZeroD(d,n,t)    memzero((char*)(d), (n) * sizeof(t))
 204 #else
 205 __UNDEFINED__  ZeroD(d,n,t)    ((void)memzero((char*)(d), (n) * sizeof(t)),d)
 206 #endif
 207
 208 __UNDEFINED__  Poison(d,n,t)   (void)memset((char*)(d), 0xAB, (n) * sizeof(t))
 209
 210 __UNDEFINED__  dUNDERBAR       dNOOP
 211 __UNDEFINED__  UNDERBAR        DEFSV
 212
 213 __UNDEFINED__  dAX             I32 ax = MARK - PL_stack_base + 1
 214 __UNDEFINED__  dITEMS          I32 items = SP - MARK
 215
 216 __UNDEFINED__  dXSTARG         SV * targ = sv_newmortal()
 217
 218 =xsmisc
 219
 220 XS(XS_Devel__PPPort_dXSTARG);  /* prototype */
 221 XS(XS_Devel__PPPort_dXSTARG)
 222 {
 223   dXSARGS;
 224   dXSTARG;
 225   IV iv;
 226   SP -= items;
 227   iv = SvIV(ST(0)) + 1;
 228   PUSHi(iv);
 229   XSRETURN(1);
 230 }
 231
 232 =xsboot
 233
 234 newXS("Devel::PPPort::dXSTARG", XS_Devel__PPPort_dXSTARG, file);
 235
 236 =xsubs
 237
 238 int
 239 gv_stashpvn(name, create)
 240         char *name
 241         I32 create
 242         CODE:
 243                 RETVAL = gv_stashpvn(name, strlen(name), create) != NULL;
 244         OUTPUT:
 245                 RETVAL
 246
 247 int
 248 get_sv(name, create)
 249         char *name
 250         I32 create
 251         CODE:
 252                 RETVAL = get_sv(name, create) != NULL;
 253         OUTPUT:
 254                 RETVAL
 255
 256 int
 257 get_av(name, create)
 258         char *name
 259         I32 create
 260         CODE:
 261                 RETVAL = get_av(name, create) != NULL;
 262         OUTPUT:
 263                 RETVAL
 264
 265 int
 266 get_hv(name, create)
 267         char *name
 268         I32 create
 269         CODE:
 270                 RETVAL = get_hv(name, create) != NULL;
 271         OUTPUT:
 272                 RETVAL
 273
 274 int
 275 get_cv(name, create)
 276         char *name
 277         I32 create
 278         CODE:
 279                 RETVAL = get_cv(name, create) != NULL;
 280         OUTPUT:
 281                 RETVAL
 282
 283 void
 284 newSVpvn()
 285         PPCODE:
 286                 XPUSHs(newSVpvn("test", 4));
 287                 XPUSHs(newSVpvn("test", 2));
 288                 XPUSHs(newSVpvn("test", 0));
 289                 XPUSHs(newSVpvn(NULL, 2));
 290                 XPUSHs(newSVpvn(NULL, 0));
 291                 XSRETURN(5);
 292
 293 SV *
 294 PL_sv_undef()
 295         CODE:
 296                 RETVAL = newSVsv(&PL_sv_undef);
 297         OUTPUT:
 298                 RETVAL
 299
 300 SV *
 301 PL_sv_yes()
 302         CODE:
 303                 RETVAL = newSVsv(&PL_sv_yes);
 304         OUTPUT:
 305                 RETVAL
 306
 307 SV *
 308 PL_sv_no()
 309         CODE:
 310                 RETVAL = newSVsv(&PL_sv_no);
 311         OUTPUT:
 312                 RETVAL
 313
 314 int
 315 PL_na(string)
 316         char *string
 317         CODE:
 318                 PL_na = strlen(string);
 319                 RETVAL = PL_na;
 320         OUTPUT:
 321                 RETVAL
 322
 323 SV*
 324 boolSV(value)
 325         int value
 326         CODE:
 327                 RETVAL = newSVsv(boolSV(value));
 328         OUTPUT:
 329                 RETVAL
 330
 331 SV*
 332 DEFSV()
 333         CODE:
 334                 RETVAL = newSVsv(DEFSV);
 335         OUTPUT:
 336                 RETVAL
 337
 338 int
 339 ERRSV()
 340         CODE:
 341                 RETVAL = SvTRUE(ERRSV);
 342         OUTPUT:
 343                 RETVAL
 344
 345 SV*
 346 UNDERBAR()
 347         CODE:
 348                 {
 349                   dUNDERBAR;
 350                   RETVAL = newSVsv(UNDERBAR);
 351                 }
 352         OUTPUT:
 353                 RETVAL
 354
 355 =tests plan => 32
 356
 357 use vars qw($my_sv @my_av %my_hv);
 358
 359 my @s = &Devel::PPPort::newSVpvn();
 360 ok(@s == 5);
 361 ok($s[0], "test");
 362 ok($s[1], "te");
 363 ok($s[2], "");
 364 ok(!defined($s[3]));
 365 ok(!defined($s[4]));
 366
 367 ok(!defined(&Devel::PPPort::PL_sv_undef()));
 368 ok(&Devel::PPPort::PL_sv_yes());
 369 ok(!&Devel::PPPort::PL_sv_no());
 370 ok(&Devel::PPPort::PL_na("abcd"), 4);
 371
 372 ok(&Devel::PPPort::boolSV(1));
 373 ok(!&Devel::PPPort::boolSV(0));
 374
 375 $_ = "Fred";
 376 ok(&Devel::PPPort::DEFSV(), "Fred");
 377 ok(&Devel::PPPort::UNDERBAR(), "Fred");
 378
 379 eval { 1 };
 380 ok(!&Devel::PPPort::ERRSV());
 381 eval { cannot_call_this_one() };
 382 ok(&Devel::PPPort::ERRSV());
 383
 384 ok(&Devel::PPPort::gv_stashpvn('Devel::PPPort', 0));
 385 ok(!&Devel::PPPort::gv_stashpvn('does::not::exist', 0));
 386 ok(&Devel::PPPort::gv_stashpvn('does::not::exist', 1));
 387
 388 $my_sv = 1;
 389 ok(&Devel::PPPort::get_sv('my_sv', 0));
 390 ok(!&Devel::PPPort::get_sv('not_my_sv', 0));
 391 ok(&Devel::PPPort::get_sv('not_my_sv', 1));
 392
 393 @my_av = (1);
 394 ok(&Devel::PPPort::get_av('my_av', 0));
 395 ok(!&Devel::PPPort::get_av('not_my_av', 0));
 396 ok(&Devel::PPPort::get_av('not_my_av', 1));
 397
 398 %my_hv = (a=>1);
 399 ok(&Devel::PPPort::get_hv('my_hv', 0));
 400 ok(!&Devel::PPPort::get_hv('not_my_hv', 0));
 401 ok(&Devel::PPPort::get_hv('not_my_hv', 1));
 402
 403 sub my_cv { 1 };
 404 ok(&Devel::PPPort::get_cv('my_cv', 0));
 405 ok(!&Devel::PPPort::get_cv('not_my_cv', 0));
 406 ok(&Devel::PPPort::get_cv('not_my_cv', 1));
 407
 408 ok(Devel::PPPort::dXSTARG(42), 43);
 409