ext/Devel/PPPort/parts/inc/misc

   1 ################################################################################
   2 ##
   3 ##  $Revision: 41 $
   4 ##  $Author: mhx $
   5 ##  $Date: 2007/08/20 18:33:10 +0200 $
   6 ##
   7 ################################################################################
   8 ##
   9 ##  Version 3.x, Copyright (C) 2004-2007, 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 NVTYPE
  28 INT2PTR
  29 PTRV
  30 NUM2PTR
  31 PERL_HASH
  32 PTR2IV
  33 PTR2UV
  34 PTR2NV
  35 PTR2ul
  36 START_EXTERN_C
  37 END_EXTERN_C
  38 EXTERN_C
  39 STMT_START
  40 STMT_END
  41 UTF8_MAXBYTES
  42 XSRETURN
  43
  44 =implementation
  45
  46 #ifndef PERL_UNUSED_DECL
  47 #  ifdef HASATTRIBUTE
  48 #    if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
  49 #      define PERL_UNUSED_DECL
  50 #    else
  51 #      define PERL_UNUSED_DECL __attribute__((unused))
  52 #    endif
  53 #  else
  54 #    define PERL_UNUSED_DECL
  55 #  endif
  56 #endif
  57
  58 #ifndef PERL_UNUSED_ARG
  59 #  if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */
  60 #    include <note.h>
  61 #    define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x))
  62 #  else
  63 #    define PERL_UNUSED_ARG(x) ((void)x)
  64 #  endif
  65 #endif
  66
  67 #ifndef PERL_UNUSED_VAR
  68 #  define PERL_UNUSED_VAR(x) ((void)x)
  69 #endif
  70
  71 #ifndef PERL_UNUSED_CONTEXT
  72 #  ifdef USE_ITHREADS
  73 #    define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl)
  74 #  else
  75 #    define PERL_UNUSED_CONTEXT
  76 #  endif
  77 #endif
  78
  79 __UNDEFINED__  NOOP          /*EMPTY*/(void)0
  80 __UNDEFINED__  dNOOP         extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL
  81
  82 #ifndef NVTYPE
  83 #  if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
  84 #    define NVTYPE long double
  85 #  else
  86 #    define NVTYPE double
  87 #  endif
  88 typedef NVTYPE NV;
  89 #endif
  90
  91 #ifndef INT2PTR
  92
  93 #  if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
  94 #    define PTRV                  UV
  95 #    define INT2PTR(any,d)        (any)(d)
  96 #  else
  97 #    if PTRSIZE == LONGSIZE
  98 #      define PTRV                unsigned long
  99 #    else
 100 #      define PTRV                unsigned
 101 #    endif
 102 #    define INT2PTR(any,d)        (any)(PTRV)(d)
 103 #  endif
 104
 105 #  define NUM2PTR(any,d)  (any)(PTRV)(d)
 106 #  define PTR2IV(p)       INT2PTR(IV,p)
 107 #  define PTR2UV(p)       INT2PTR(UV,p)
 108 #  define PTR2NV(p)       NUM2PTR(NV,p)
 109
 110 #  if PTRSIZE == LONGSIZE
 111 #    define PTR2ul(p)     (unsigned long)(p)
 112 #  else
 113 #    define PTR2ul(p)     INT2PTR(unsigned long,p)
 114 #  endif
 115
 116 #endif /* !INT2PTR */
 117
 118 #undef START_EXTERN_C
 119 #undef END_EXTERN_C
 120 #undef EXTERN_C
 121 #ifdef __cplusplus
 122 #  define START_EXTERN_C extern "C" {
 123 #  define END_EXTERN_C }
 124 #  define EXTERN_C extern "C"
 125 #else
 126 #  define START_EXTERN_C
 127 #  define END_EXTERN_C
 128 #  define EXTERN_C extern
 129 #endif
 130
 131 #if defined(PERL_GCC_PEDANTIC)
 132 #  ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
 133 #    define PERL_GCC_BRACE_GROUPS_FORBIDDEN
 134 #  endif
 135 #endif
 136
 137 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
 138 #  ifndef PERL_USE_GCC_BRACE_GROUPS
 139 #    define PERL_USE_GCC_BRACE_GROUPS
 140 #  endif
 141 #endif
 142
 143 #undef STMT_START
 144 #undef STMT_END
 145 #ifdef PERL_USE_GCC_BRACE_GROUPS
 146 #  define STMT_START    (void)( /* gcc supports ``({ STATEMENTS; })'' */
 147 #  define STMT_END      )
 148 #else
 149 #  if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__)
 150 #    define STMT_START  if (1)
 151 #    define STMT_END    else (void)0
 152 #  else
 153 #    define STMT_START  do
 154 #    define STMT_END    while (0)
 155 #  endif
 156 #endif
 157
 158 __UNDEFINED__  boolSV(b)    ((b) ? &PL_sv_yes : &PL_sv_no)
 159
 160 /* DEFSV appears first in 5.004_56 */
 161 __UNDEFINED__  DEFSV        GvSV(PL_defgv)
 162 __UNDEFINED__  SAVE_DEFSV   SAVESPTR(GvSV(PL_defgv))
 163
 164 /* Older perls (<=5.003) lack AvFILLp */
 165 __UNDEFINED__  AvFILLp      AvFILL
 166
 167 __UNDEFINED__  ERRSV        get_sv("@",FALSE)
 168
 169 __UNDEFINED__  newSVpvn(data,len)  ((data)                                              \
 170                                     ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \
 171                                     : newSV(0))
 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__  PERL_ABS(x)     ((x) < 0 ? -(x) : (x))
 213
 214 __UNDEFINED__  dVAR            dNOOP
 215
 216 __UNDEFINED__  SVf             "_"
 217
 218 __UNDEFINED__  UTF8_MAXBYTES   UTF8_MAXLEN
 219
 220 __UNDEFINED__  PERL_HASH(hash,str,len) \
 221      STMT_START { \
 222         const char *s_PeRlHaSh = str; \
 223         I32 i_PeRlHaSh = len; \
 224         U32 hash_PeRlHaSh = 0; \
 225         while (i_PeRlHaSh--) \
 226             hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \
 227         (hash) = hash_PeRlHaSh; \
 228     } STMT_END
 229
 230 =xsmisc
 231
 232 XS(XS_Devel__PPPort_dXSTARG);  /* prototype */
 233 XS(XS_Devel__PPPort_dXSTARG)
 234 {
 235   dXSARGS;
 236   dXSTARG;
 237   IV iv;
 238   SP -= items;
 239   iv = SvIV(ST(0)) + 1;
 240   PUSHi(iv);
 241   XSRETURN(1);
 242 }
 243
 244 XS(XS_Devel__PPPort_dAXMARK);  /* prototype */
 245 XS(XS_Devel__PPPort_dAXMARK)
 246 {
 247   dSP;
 248   dAXMARK;
 249   dITEMS;
 250   IV iv;
 251   SP -= items;
 252   iv = SvIV(ST(0)) - 1;
 253   PUSHs(sv_2mortal(newSViv(iv)));
 254   XSRETURN(1);
 255 }
 256
 257 =xsboot
 258
 259 newXS("Devel::PPPort::dXSTARG", XS_Devel__PPPort_dXSTARG, file);
 260 newXS("Devel::PPPort::dAXMARK", XS_Devel__PPPort_dAXMARK, file);
 261
 262 =xsubs
 263
 264 int
 265 gv_stashpvn(name, create)
 266         char *name
 267         I32 create
 268         CODE:
 269                 RETVAL = gv_stashpvn(name, strlen(name), create) != NULL;
 270         OUTPUT:
 271                 RETVAL
 272
 273 int
 274 get_sv(name, create)
 275         char *name
 276         I32 create
 277         CODE:
 278                 RETVAL = get_sv(name, create) != NULL;
 279         OUTPUT:
 280                 RETVAL
 281
 282 int
 283 get_av(name, create)
 284         char *name
 285         I32 create
 286         CODE:
 287                 RETVAL = get_av(name, create) != NULL;
 288         OUTPUT:
 289                 RETVAL
 290
 291 int
 292 get_hv(name, create)
 293         char *name
 294         I32 create
 295         CODE:
 296                 RETVAL = get_hv(name, create) != NULL;
 297         OUTPUT:
 298                 RETVAL
 299
 300 int
 301 get_cv(name, create)
 302         char *name
 303         I32 create
 304         CODE:
 305                 RETVAL = get_cv(name, create) != NULL;
 306         OUTPUT:
 307                 RETVAL
 308
 309 void
 310 newSVpvn()
 311         PPCODE:
 312                 XPUSHs(newSVpvn("test", 4));
 313                 XPUSHs(newSVpvn("test", 2));
 314                 XPUSHs(newSVpvn("test", 0));
 315                 XPUSHs(newSVpvn(NULL, 2));
 316                 XPUSHs(newSVpvn(NULL, 0));
 317                 XSRETURN(5);
 318
 319 void
 320 xsreturn(two)
 321         int two
 322         PPCODE:
 323                 XPUSHs(newSVpvn("test1", 5));
 324                 if (two)
 325                   XPUSHs(newSVpvn("test2", 5));
 326                 if (two)
 327                   XSRETURN(2);
 328                 else
 329                   XSRETURN(1);
 330
 331 SV*
 332 boolSV(value)
 333         int value
 334         CODE:
 335                 RETVAL = newSVsv(boolSV(value));
 336         OUTPUT:
 337                 RETVAL
 338
 339 SV*
 340 DEFSV()
 341         CODE:
 342                 RETVAL = newSVsv(DEFSV);
 343         OUTPUT:
 344                 RETVAL
 345
 346 int
 347 ERRSV()
 348         CODE:
 349                 RETVAL = SvTRUE(ERRSV);
 350         OUTPUT:
 351                 RETVAL
 352
 353 SV*
 354 UNDERBAR()
 355         CODE:
 356                 {
 357                   dUNDERBAR;
 358                   RETVAL = newSVsv(UNDERBAR);
 359                 }
 360         OUTPUT:
 361                 RETVAL
 362
 363 void
 364 prepush()
 365         CODE:
 366                 {
 367                   dXSTARG;
 368                   XSprePUSH;
 369                   PUSHi(42);
 370                   XSRETURN(1);
 371                 }
 372
 373 int
 374 PERL_ABS(a)
 375         int a
 376
 377 void
 378 SVf(x)
 379         SV *x
 380         PPCODE:
 381 #if { VERSION >= 5.004 }
 382                 x = newSVpvf("[%"SVf"]", x);
 383 #endif
 384                 XPUSHs(x);
 385                 XSRETURN(1);
 386
 387 =tests plan => 38
 388
 389 use vars qw($my_sv @my_av %my_hv);
 390
 391 my @s = &Devel::PPPort::newSVpvn();
 392 ok(@s == 5);
 393 ok($s[0], "test");
 394 ok($s[1], "te");
 395 ok($s[2], "");
 396 ok(!defined($s[3]));
 397 ok(!defined($s[4]));
 398
 399 ok(&Devel::PPPort::boolSV(1));
 400 ok(!&Devel::PPPort::boolSV(0));
 401
 402 $_ = "Fred";
 403 ok(&Devel::PPPort::DEFSV(), "Fred");
 404 ok(&Devel::PPPort::UNDERBAR(), "Fred");
 405
 406 if ($] >= 5.009002) {
 407   eval q{
 408     my $_ = "Tony";
 409     ok(&Devel::PPPort::DEFSV(), "Fred");
 410     ok(&Devel::PPPort::UNDERBAR(), "Tony");
 411   };
 412 }
 413 else {
 414   ok(1);
 415   ok(1);
 416 }
 417
 418 eval { 1 };
 419 ok(!&Devel::PPPort::ERRSV());
 420 eval { cannot_call_this_one() };
 421 ok(&Devel::PPPort::ERRSV());
 422
 423 ok(&Devel::PPPort::gv_stashpvn('Devel::PPPort', 0));
 424 ok(!&Devel::PPPort::gv_stashpvn('does::not::exist', 0));
 425 ok(&Devel::PPPort::gv_stashpvn('does::not::exist', 1));
 426
 427 $my_sv = 1;
 428 ok(&Devel::PPPort::get_sv('my_sv', 0));
 429 ok(!&Devel::PPPort::get_sv('not_my_sv', 0));
 430 ok(&Devel::PPPort::get_sv('not_my_sv', 1));
 431
 432 @my_av = (1);
 433 ok(&Devel::PPPort::get_av('my_av', 0));
 434 ok(!&Devel::PPPort::get_av('not_my_av', 0));
 435 ok(&Devel::PPPort::get_av('not_my_av', 1));
 436
 437 %my_hv = (a=>1);
 438 ok(&Devel::PPPort::get_hv('my_hv', 0));
 439 ok(!&Devel::PPPort::get_hv('not_my_hv', 0));
 440 ok(&Devel::PPPort::get_hv('not_my_hv', 1));
 441
 442 sub my_cv { 1 };
 443 ok(&Devel::PPPort::get_cv('my_cv', 0));
 444 ok(!&Devel::PPPort::get_cv('not_my_cv', 0));
 445 ok(&Devel::PPPort::get_cv('not_my_cv', 1));
 446
 447 ok(Devel::PPPort::dXSTARG(42), 43);
 448 ok(Devel::PPPort::dAXMARK(4711), 4710);
 449
 450 ok(Devel::PPPort::prepush(), 42);
 451
 452 ok(join(':', Devel::PPPort::xsreturn(0)), 'test1');
 453 ok(join(':', Devel::PPPort::xsreturn(1)), 'test1:test2');
 454
 455 ok(Devel::PPPort::PERL_ABS(42), 42);
 456 ok(Devel::PPPort::PERL_ABS(-13), 13);
 457
 458 ok(Devel::PPPort::SVf(42), $] >= 5.004 ? '[42]' : '42');
 459 ok(Devel::PPPort::SVf('abc'), $] >= 5.004 ? '[abc]' : 'abc');
 460