ext/Devel/PPPort/parts/inc/misc

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