cpan/Devel-PPPort/parts/inc/misc

   1 ################################################################################
   2 ##
   3 ##  $Revision: 56 $
   4 ##  $Author: mhx $
   5 ##  $Date: 2011/09/10 20:38:10 +0200 $
   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 PERL_UNUSED_DECL
  22 PERL_UNUSED_ARG
  23 PERL_UNUSED_VAR
  24 PERL_UNUSED_CONTEXT
  25 PERL_GCC_BRACE_GROUPS_FORBIDDEN
  26 PERL_USE_GCC_BRACE_GROUPS
  27 PERLIO_FUNCS_DECL
  28 PERLIO_FUNCS_CAST
  29 NVTYPE
  30 INT2PTR
  31 PTRV
  32 NUM2PTR
  33 PERL_HASH
  34 PTR2IV
  35 PTR2UV
  36 PTR2NV
  37 PTR2ul
  38 START_EXTERN_C
  39 END_EXTERN_C
  40 EXTERN_C
  41 STMT_START
  42 STMT_END
  43 UTF8_MAXBYTES
  44 XSRETURN
  45
  46 =implementation
  47
  48 #ifndef PERL_UNUSED_DECL
  49 #  ifdef HASATTRIBUTE
  50 #    if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
  51 #      define PERL_UNUSED_DECL
  52 #    else
  53 #      define PERL_UNUSED_DECL __attribute__((unused))
  54 #    endif
  55 #  else
  56 #    define PERL_UNUSED_DECL
  57 #  endif
  58 #endif
  59
  60 #ifndef PERL_UNUSED_ARG
  61 #  if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */
  62 #    include <note.h>
  63 #    define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x))
  64 #  else
  65 #    define PERL_UNUSED_ARG(x) ((void)x)
  66 #  endif
  67 #endif
  68
  69 #ifndef PERL_UNUSED_VAR
  70 #  define PERL_UNUSED_VAR(x) ((void)x)
  71 #endif
  72
  73 #ifndef PERL_UNUSED_CONTEXT
  74 #  ifdef USE_ITHREADS
  75 #    define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl)
  76 #  else
  77 #    define PERL_UNUSED_CONTEXT
  78 #  endif
  79 #endif
  80
  81 __UNDEFINED__  NOOP          /*EMPTY*/(void)0
  82 __UNDEFINED__  dNOOP         extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL
  83
  84 #ifndef NVTYPE
  85 #  if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
  86 #    define NVTYPE long double
  87 #  else
  88 #    define NVTYPE double
  89 #  endif
  90 typedef NVTYPE NV;
  91 #endif
  92
  93 #ifndef INT2PTR
  94 #  if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
  95 #    define PTRV                  UV
  96 #    define INT2PTR(any,d)        (any)(d)
  97 #  else
  98 #    if PTRSIZE == LONGSIZE
  99 #      define PTRV                unsigned long
 100 #    else
 101 #      define PTRV                unsigned
 102 #    endif
 103 #    define INT2PTR(any,d)        (any)(PTRV)(d)
 104 #  endif
 105 #endif
 106
 107 #ifndef PTR2ul
 108 #  if PTRSIZE == LONGSIZE
 109 #    define PTR2ul(p)     (unsigned long)(p)
 110 #  else
 111 #    define PTR2ul(p)     INT2PTR(unsigned long,p)
 112 #  endif
 113 #endif
 114
 115 __UNDEFINED__  PTR2nat(p)      (PTRV)(p)
 116 __UNDEFINED__  NUM2PTR(any,d)  (any)PTR2nat(d)
 117 __UNDEFINED__  PTR2IV(p)       INT2PTR(IV,p)
 118 __UNDEFINED__  PTR2UV(p)       INT2PTR(UV,p)
 119 __UNDEFINED__  PTR2NV(p)       NUM2PTR(NV,p)
 120
 121 #undef START_EXTERN_C
 122 #undef END_EXTERN_C
 123 #undef EXTERN_C
 124 #ifdef __cplusplus
 125 #  define START_EXTERN_C extern "C" {
 126 #  define END_EXTERN_C }
 127 #  define EXTERN_C extern "C"
 128 #else
 129 #  define START_EXTERN_C
 130 #  define END_EXTERN_C
 131 #  define EXTERN_C extern
 132 #endif
 133
 134 #if defined(PERL_GCC_PEDANTIC)
 135 #  ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
 136 #    define PERL_GCC_BRACE_GROUPS_FORBIDDEN
 137 #  endif
 138 #endif
 139
 140 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
 141 #  ifndef PERL_USE_GCC_BRACE_GROUPS
 142 #    define PERL_USE_GCC_BRACE_GROUPS
 143 #  endif
 144 #endif
 145
 146 #undef STMT_START
 147 #undef STMT_END
 148 #ifdef PERL_USE_GCC_BRACE_GROUPS
 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 __UNDEFINED__  DEFSV_set(sv) (DEFSV = (sv))
 167
 168 /* Older perls (<=5.003) lack AvFILLp */
 169 __UNDEFINED__  AvFILLp      AvFILL
 170
 171 __UNDEFINED__  ERRSV        get_sv("@",FALSE)
 172
 173 /* Hint: gv_stashpvn
 174  * This function's backport doesn't support the length parameter, but
 175  * rather ignores it. Portability can only be ensured if the length
 176  * parameter is used for speed reasons, but the length can always be
 177  * correctly computed from the string argument.
 178  */
 179
 180 __UNDEFINED__  gv_stashpvn(str,len,create)  gv_stashpv(str,create)
 181
 182 /* Replace: 1 */
 183 __UNDEFINED__  get_cv          perl_get_cv
 184 __UNDEFINED__  get_sv          perl_get_sv
 185 __UNDEFINED__  get_av          perl_get_av
 186 __UNDEFINED__  get_hv          perl_get_hv
 187 /* Replace: 0 */
 188
 189 __UNDEFINED__  dUNDERBAR       dNOOP
 190 __UNDEFINED__  UNDERBAR        DEFSV
 191
 192 __UNDEFINED__  dAX             I32 ax = MARK - PL_stack_base + 1
 193 __UNDEFINED__  dITEMS          I32 items = SP - MARK
 194
 195 __UNDEFINED__  dXSTARG         SV * targ = sv_newmortal()
 196
 197 __UNDEFINED__  dAXMARK         I32 ax = POPMARK; \
 198                                register SV ** const mark = PL_stack_base + ax++
 199
 200
 201 __UNDEFINED__  XSprePUSH       (sp = PL_stack_base + ax - 1)
 202
 203 #if { VERSION < 5.005 }
 204 #  undef XSRETURN
 205 #  define XSRETURN(off)                                   \
 206       STMT_START {                                        \
 207           PL_stack_sp = PL_stack_base + ax + ((off) - 1); \
 208           return;                                         \
 209       } STMT_END
 210 #endif
 211
 212 __UNDEFINED__  XSPROTO(name)   void name(pTHX_ CV* cv)
 213 __UNDEFINED__  SVfARG(p)       ((void*)(p))
 214
 215 __UNDEFINED__  PERL_ABS(x)     ((x) < 0 ? -(x) : (x))
 216
 217 __UNDEFINED__  dVAR            dNOOP
 218
 219 __UNDEFINED__  SVf             "_"
 220
 221 __UNDEFINED__  UTF8_MAXBYTES   UTF8_MAXLEN
 222
 223 __UNDEFINED__  CPERLscope(x)   x
 224
 225 __UNDEFINED__  PERL_HASH(hash,str,len) \
 226      STMT_START { \
 227         const char *s_PeRlHaSh = str; \
 228         I32 i_PeRlHaSh = len; \
 229         U32 hash_PeRlHaSh = 0; \
 230         while (i_PeRlHaSh--) \
 231             hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \
 232         (hash) = hash_PeRlHaSh; \
 233     } STMT_END
 234
 235 #ifndef PERLIO_FUNCS_DECL
 236 # ifdef PERLIO_FUNCS_CONST
 237 #  define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs
 238 #  define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs)
 239 # else
 240 #  define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs
 241 #  define PERLIO_FUNCS_CAST(funcs) (funcs)
 242 # endif
 243 #endif
 244
 245 /* provide these typedefs for older perls */
 246 #if { VERSION < 5.9.3 }
 247
 248 # ifdef ARGSproto
 249 typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto);
 250 # else
 251 typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX);
 252 # endif
 253
 254 typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*);
 255
 256 #endif
 257
 258 __UNDEFINED__ isPSXSPC(c)       (isSPACE(c) || (c) == '\v')
 259 __UNDEFINED__ isBLANK(c)        ((c) == ' ' || (c) == '\t')
 260 #ifdef EBCDIC
 261 __UNDEFINED__ isALNUMC(c)       isalnum(c)
 262 __UNDEFINED__ isASCII(c)        isascii(c)
 263 __UNDEFINED__ isCNTRL(c)        iscntrl(c)
 264 __UNDEFINED__ isGRAPH(c)        isgraph(c)
 265 __UNDEFINED__ isPRINT(c)        isprint(c)
 266 __UNDEFINED__ isPUNCT(c)        ispunct(c)
 267 __UNDEFINED__ isXDIGIT(c)       isxdigit(c)
 268 #else
 269 # if { VERSION < 5.10.0 }
 270 /* Hint: isPRINT
 271  * The implementation in older perl versions includes all of the
 272  * isSPACE() characters, which is wrong. The version provided by
 273  * Devel::PPPort always overrides a present buggy version.
 274  */
 275 #  undef isPRINT
 276 # endif
 277 __UNDEFINED__ isALNUMC(c)       (isALPHA(c) || isDIGIT(c))
 278 __UNDEFINED__ isASCII(c)        ((U8) (c) <= 127)
 279 __UNDEFINED__ isCNTRL(c)        ((U8) (c) < ' ' || (c) == 127)
 280 __UNDEFINED__ isGRAPH(c)        (isALNUM(c) || isPUNCT(c))
 281 __UNDEFINED__ isPRINT(c)        (((c) >= 32 && (c) < 127))
 282 __UNDEFINED__ isPUNCT(c)        (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64)  || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126))
 283 __UNDEFINED__ isXDIGIT(c)       (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F'))
 284 #endif
 285
 286 =xsmisc
 287
 288 typedef XSPROTO(XSPROTO_test_t);
 289 typedef XSPROTO_test_t *XSPROTO_test_t_ptr;
 290
 291 XS(XS_Devel__PPPort_dXSTARG);  /* prototype */
 292 XS(XS_Devel__PPPort_dXSTARG)
 293 {
 294   dXSARGS;
 295   dXSTARG;
 296   IV iv;
 297   SP -= items;
 298   iv = SvIV(ST(0)) + 1;
 299   PUSHi(iv);
 300   XSRETURN(1);
 301 }
 302
 303 XS(XS_Devel__PPPort_dAXMARK);  /* prototype */
 304 XS(XS_Devel__PPPort_dAXMARK)
 305 {
 306   dSP;
 307   dAXMARK;
 308   dITEMS;
 309   IV iv;
 310   SP -= items;
 311   iv = SvIV(ST(0)) - 1;
 312   mPUSHi(iv);
 313   XSRETURN(1);
 314 }
 315
 316 =xsboot
 317
 318 {
 319   XSPROTO_test_t_ptr p = &XS_Devel__PPPort_dXSTARG;
 320   newXS("Devel::PPPort::dXSTARG", *p, file);
 321 }
 322 newXS("Devel::PPPort::dAXMARK", XS_Devel__PPPort_dAXMARK, file);
 323
 324 =xsubs
 325
 326 int
 327 ptrtests()
 328         PREINIT:
 329                 int var, *p = &var;
 330
 331         CODE:
 332                 RETVAL = 0;
 333                 RETVAL += PTR2nat(p) != 0       ?  1 : 0;
 334                 RETVAL += PTR2ul(p) != 0UL      ?  2 : 0;
 335                 RETVAL += PTR2UV(p) != (UV) 0   ?  4 : 0;
 336                 RETVAL += PTR2IV(p) != (IV) 0   ?  8 : 0;
 337                 RETVAL += PTR2NV(p) != (NV) 0   ? 16 : 0;
 338                 RETVAL += p > NUM2PTR(int *, 0) ? 32 : 0;
 339
 340         OUTPUT:
 341                 RETVAL
 342
 343 int
 344 gv_stashpvn(name, create)
 345         char *name
 346         I32 create
 347         CODE:
 348                 RETVAL = gv_stashpvn(name, strlen(name), create) != NULL;
 349         OUTPUT:
 350                 RETVAL
 351
 352 int
 353 get_sv(name, create)
 354         char *name
 355         I32 create
 356         CODE:
 357                 RETVAL = get_sv(name, create) != NULL;
 358         OUTPUT:
 359                 RETVAL
 360
 361 int
 362 get_av(name, create)
 363         char *name
 364         I32 create
 365         CODE:
 366                 RETVAL = get_av(name, create) != NULL;
 367         OUTPUT:
 368                 RETVAL
 369
 370 int
 371 get_hv(name, create)
 372         char *name
 373         I32 create
 374         CODE:
 375                 RETVAL = get_hv(name, create) != NULL;
 376         OUTPUT:
 377                 RETVAL
 378
 379 int
 380 get_cv(name, create)
 381         char *name
 382         I32 create
 383         CODE:
 384                 RETVAL = get_cv(name, create) != NULL;
 385         OUTPUT:
 386                 RETVAL
 387
 388 void
 389 xsreturn(two)
 390         int two
 391         PPCODE:
 392                 mXPUSHp("test1", 5);
 393                 if (two)
 394                   mXPUSHp("test2", 5);
 395                 if (two)
 396                   XSRETURN(2);
 397                 else
 398                   XSRETURN(1);
 399
 400 SV*
 401 boolSV(value)
 402         int value
 403         CODE:
 404                 RETVAL = newSVsv(boolSV(value));
 405         OUTPUT:
 406                 RETVAL
 407
 408 SV*
 409 DEFSV()
 410         CODE:
 411                 RETVAL = newSVsv(DEFSV);
 412         OUTPUT:
 413                 RETVAL
 414
 415 void
 416 DEFSV_modify()
 417         PPCODE:
 418                 XPUSHs(sv_mortalcopy(DEFSV));
 419                 ENTER;
 420                 SAVE_DEFSV;
 421                 DEFSV_set(newSVpvs("DEFSV"));
 422                 XPUSHs(sv_mortalcopy(DEFSV));
 423                 /* Yes, this leaks the above scalar; 5.005 with threads for some reason */
 424                 /* frees it upon LEAVE, thus mortalizing it causes "attempt to free..." */
 425                 /* sv_2mortal(DEFSV); */
 426                 LEAVE;
 427                 XPUSHs(sv_mortalcopy(DEFSV));
 428                 XSRETURN(3);
 429
 430 int
 431 ERRSV()
 432         CODE:
 433                 RETVAL = SvTRUE(ERRSV);
 434         OUTPUT:
 435                 RETVAL
 436
 437 SV*
 438 UNDERBAR()
 439         CODE:
 440                 {
 441                   dUNDERBAR;
 442                   RETVAL = newSVsv(UNDERBAR);
 443                 }
 444         OUTPUT:
 445                 RETVAL
 446
 447 void
 448 prepush()
 449         CODE:
 450                 {
 451                   dXSTARG;
 452                   XSprePUSH;
 453                   PUSHi(42);
 454                   XSRETURN(1);
 455                 }
 456
 457 int
 458 PERL_ABS(a)
 459         int a
 460
 461 void
 462 SVf(x)
 463         SV *x
 464         PPCODE:
 465 #if { VERSION >= 5.004 }
 466                 x = sv_2mortal(newSVpvf("[%"SVf"]", SVfARG(x)));
 467 #endif
 468                 XPUSHs(x);
 469                 XSRETURN(1);
 470
 471 void
 472 Perl_ppaddr_t(string)
 473         char *string
 474         PREINIT:
 475                 Perl_ppaddr_t lower;
 476         PPCODE:
 477                 lower = PL_ppaddr[OP_LC];
 478                 mXPUSHs(newSVpv(string, 0));
 479                 PUTBACK;
 480                 ENTER;
 481                 (void)*(lower)(aTHXR);
 482                 SPAGAIN;
 483                 LEAVE;
 484                 XSRETURN(1);
 485
 486 =tests plan => 39
 487
 488 use vars qw($my_sv @my_av %my_hv);
 489
 490 ok(&Devel::PPPort::boolSV(1));
 491 ok(!&Devel::PPPort::boolSV(0));
 492
 493 $_ = "Fred";
 494 ok(&Devel::PPPort::DEFSV(), "Fred");
 495 ok(&Devel::PPPort::UNDERBAR(), "Fred");
 496
 497 if ($] >= 5.009002) {
 498   eval q{
 499     my $_ = "Tony";
 500     ok(&Devel::PPPort::DEFSV(), "Fred");
 501     ok(&Devel::PPPort::UNDERBAR(), "Tony");
 502   };
 503 }
 504 else {
 505   ok(1);
 506   ok(1);
 507 }
 508
 509 my @r = &Devel::PPPort::DEFSV_modify();
 510
 511 ok(@r == 3);
 512 ok($r[0], 'Fred');
 513 ok($r[1], 'DEFSV');
 514 ok($r[2], 'Fred');
 515
 516 ok(&Devel::PPPort::DEFSV(), "Fred");
 517
 518 eval { 1 };
 519 ok(!&Devel::PPPort::ERRSV());
 520 eval { cannot_call_this_one() };
 521 ok(&Devel::PPPort::ERRSV());
 522
 523 ok(&Devel::PPPort::gv_stashpvn('Devel::PPPort', 0));
 524 ok(!&Devel::PPPort::gv_stashpvn('does::not::exist', 0));
 525 ok(&Devel::PPPort::gv_stashpvn('does::not::exist', 1));
 526
 527 $my_sv = 1;
 528 ok(&Devel::PPPort::get_sv('my_sv', 0));
 529 ok(!&Devel::PPPort::get_sv('not_my_sv', 0));
 530 ok(&Devel::PPPort::get_sv('not_my_sv', 1));
 531
 532 @my_av = (1);
 533 ok(&Devel::PPPort::get_av('my_av', 0));
 534 ok(!&Devel::PPPort::get_av('not_my_av', 0));
 535 ok(&Devel::PPPort::get_av('not_my_av', 1));
 536
 537 %my_hv = (a=>1);
 538 ok(&Devel::PPPort::get_hv('my_hv', 0));
 539 ok(!&Devel::PPPort::get_hv('not_my_hv', 0));
 540 ok(&Devel::PPPort::get_hv('not_my_hv', 1));
 541
 542 sub my_cv { 1 };
 543 ok(&Devel::PPPort::get_cv('my_cv', 0));
 544 ok(!&Devel::PPPort::get_cv('not_my_cv', 0));
 545 ok(&Devel::PPPort::get_cv('not_my_cv', 1));
 546
 547 ok(Devel::PPPort::dXSTARG(42), 43);
 548 ok(Devel::PPPort::dAXMARK(4711), 4710);
 549
 550 ok(Devel::PPPort::prepush(), 42);
 551
 552 ok(join(':', Devel::PPPort::xsreturn(0)), 'test1');
 553 ok(join(':', Devel::PPPort::xsreturn(1)), 'test1:test2');
 554
 555 ok(Devel::PPPort::PERL_ABS(42), 42);
 556 ok(Devel::PPPort::PERL_ABS(-13), 13);
 557
 558 ok(Devel::PPPort::SVf(42), $] >= 5.004 ? '[42]' : '42');
 559 ok(Devel::PPPort::SVf('abc'), $] >= 5.004 ? '[abc]' : 'abc');
 560
 561 ok(&Devel::PPPort::Perl_ppaddr_t("FOO"), "foo");
 562
 563 ok(&Devel::PPPort::ptrtests(), 63);
 564