ext/Devel-PPPort/parts/inc/misc

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