dist/Devel-PPPort/parts/inc/variables

   1 ################################################################################
   2 ##
   3 ##  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
   4 ##  Version 2.x, Copyright (C) 2001, Paul Marquess.
   5 ##  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
   6 ##
   7 ##  This program is free software; you can redistribute it and/or
   8 ##  modify it under the same terms as Perl itself.
   9 ##
  10 ################################################################################
  11
  12 =provides
  13
  14 PL_ppaddr
  15 PL_no_modify
  16 PL_DBsignal
  17 PL_DBsingle
  18 PL_DBsub
  19 PL_DBtrace
  20 PL_Sv
  21 PL_bufend
  22 PL_bufptr
  23 PL_compiling
  24 PL_copline
  25 PL_curcop
  26 PL_curstash
  27 PL_debstash
  28 PL_defgv
  29 PL_diehook
  30 PL_dirty
  31 PL_dowarn
  32 PL_errgv
  33 PL_error_count
  34 PL_expect
  35 PL_hexdigit
  36 PL_hints
  37 PL_in_my
  38 PL_in_my_stash
  39 PL_laststatval
  40 PL_lex_state
  41 PL_lex_stuff
  42 PL_linestr
  43 PL_na
  44 PL_parser
  45 PL_perl_destruct_level
  46 PL_perldb
  47 PL_rsfp_filters
  48 PL_rsfp
  49 PL_stack_base
  50 PL_stack_sp
  51 PL_statcache
  52 PL_stdingv
  53 PL_sv_arenaroot
  54 PL_sv_no
  55 PL_sv_undef
  56 PL_sv_yes
  57 PL_tainted
  58 PL_tainting
  59 PL_tokenbuf
  60 PL_signals
  61 PL_mess_sv
  62 PERL_SIGNALS_UNSAFE_FLAG
  63
  64 =implementation
  65
  66 #ifndef PERL_SIGNALS_UNSAFE_FLAG
  67
  68 #define PERL_SIGNALS_UNSAFE_FLAG 0x0001
  69
  70 #if { VERSION < 5.8.0 }
  71 #  define D_PPP_PERL_SIGNALS_INIT   PERL_SIGNALS_UNSAFE_FLAG
  72 #else
  73 #  define D_PPP_PERL_SIGNALS_INIT   0
  74 #endif
  75
  76 __NEED_VAR__ U32 PL_signals = D_PPP_PERL_SIGNALS_INIT;
  77
  78 #endif
  79
  80 /* Hint: PL_ppaddr
  81  * Calling an op via PL_ppaddr requires passing a context argument
  82  * for threaded builds. Since the context argument is different for
  83  * 5.005 perls, you can use aTHXR (supplied by ppport.h), which will
  84  * automatically be defined as the correct argument.
  85  */
  86
  87 #if { VERSION <= 5.005_05 }
  88 /* Replace: 1 */
  89 #  define PL_ppaddr                 ppaddr
  90 #  define PL_no_modify              no_modify
  91 /* Replace: 0 */
  92 #endif
  93
  94 #if { VERSION <= 5.004_05 }
  95 /* Replace: 1 */
  96 #  define PL_DBsignal               DBsignal
  97 #  define PL_DBsingle               DBsingle
  98 #  define PL_DBsub                  DBsub
  99 #  define PL_DBtrace                DBtrace
 100 #  define PL_Sv                     Sv
 101 #  define PL_bufend                 bufend
 102 #  define PL_bufptr                 bufptr
 103 #  define PL_compiling              compiling
 104 #  define PL_copline                copline
 105 #  define PL_curcop                 curcop
 106 #  define PL_curstash               curstash
 107 #  define PL_debstash               debstash
 108 #  define PL_defgv                  defgv
 109 #  define PL_diehook                diehook
 110 #  define PL_dirty                  dirty
 111 #  define PL_dowarn                 dowarn
 112 #  define PL_errgv                  errgv
 113 #  define PL_error_count            error_count
 114 #  define PL_expect                 expect
 115 #  define PL_hexdigit               hexdigit
 116 #  define PL_hints                  hints
 117 #  define PL_in_my                  in_my
 118 #  define PL_laststatval            laststatval
 119 #  define PL_lex_state              lex_state
 120 #  define PL_lex_stuff              lex_stuff
 121 #  define PL_linestr                linestr
 122 #  define PL_na                     na
 123 #  define PL_perl_destruct_level    perl_destruct_level
 124 #  define PL_perldb                 perldb
 125 #  define PL_rsfp_filters           rsfp_filters
 126 #  define PL_rsfp                   rsfp
 127 #  define PL_stack_base             stack_base
 128 #  define PL_stack_sp               stack_sp
 129 #  define PL_statcache              statcache
 130 #  define PL_stdingv                stdingv
 131 #  define PL_sv_arenaroot           sv_arenaroot
 132 #  define PL_sv_no                  sv_no
 133 #  define PL_sv_undef               sv_undef
 134 #  define PL_sv_yes                 sv_yes
 135 #  define PL_tainted                tainted
 136 #  define PL_tainting               tainting
 137 #  define PL_tokenbuf               tokenbuf
 138 #  define PL_mess_sv                mess_sv
 139 /* Replace: 0 */
 140 #endif
 141
 142 /* Warning: PL_parser
 143  * For perl versions earlier than 5.9.5, this is an always
 144  * non-NULL dummy. Also, it cannot be dereferenced. Don't
 145  * use it if you can avoid is and unless you absolutely know
 146  * what you're doing.
 147  * If you always check that PL_parser is non-NULL, you can
 148  * define DPPP_PL_parser_NO_DUMMY to avoid the creation of
 149  * a dummy parser structure.
 150  */
 151
 152 #if { VERSION >= 5.9.5 }
 153 # ifdef DPPP_PL_parser_NO_DUMMY
 154 #  define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \
 155                 (croak("panic: PL_parser == NULL in %s:%d", \
 156                        __FILE__, __LINE__), (yy_parser *) NULL))->var)
 157 # else
 158 #  ifdef DPPP_PL_parser_NO_DUMMY_WARNING
 159 #   define D_PPP_parser_dummy_warning(var)
 160 #  else
 161 #   define D_PPP_parser_dummy_warning(var) \
 162              warn("warning: dummy PL_" #var " used in %s:%d", __FILE__, __LINE__),
 163 #  endif
 164 #  define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \
 165                 (D_PPP_parser_dummy_warning(var) &DPPP_(dummy_PL_parser)))->var)
 166 __NEED_DUMMY_VAR__ yy_parser PL_parser;
 167 # endif
 168
 169 /* PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf depends on PL_parser */
 170 /* Warning: PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf
 171  * Do not use this variable unless you know exactly what you're
 172  * doing. It is internal to the perl parser and may change or even
 173  * be removed in the future. As of perl 5.9.5, you have to check
 174  * for (PL_parser != NULL) for this variable to have any effect.
 175  * An always non-NULL PL_parser dummy is provided for earlier
 176  * perl versions.
 177  * If PL_parser is NULL when you try to access this variable, a
 178  * dummy is being accessed instead and a warning is issued unless
 179  * you define DPPP_PL_parser_NO_DUMMY_WARNING.
 180  * If DPPP_PL_parser_NO_DUMMY is defined, the code trying to access
 181  * this variable will croak with a panic message.
 182  */
 183
 184 # define PL_expect         D_PPP_my_PL_parser_var(expect)
 185 # define PL_copline        D_PPP_my_PL_parser_var(copline)
 186 # define PL_rsfp           D_PPP_my_PL_parser_var(rsfp)
 187 # define PL_rsfp_filters   D_PPP_my_PL_parser_var(rsfp_filters)
 188 # define PL_linestr        D_PPP_my_PL_parser_var(linestr)
 189 # define PL_bufptr         D_PPP_my_PL_parser_var(bufptr)
 190 # define PL_bufend         D_PPP_my_PL_parser_var(bufend)
 191 # define PL_lex_state      D_PPP_my_PL_parser_var(lex_state)
 192 # define PL_lex_stuff      D_PPP_my_PL_parser_var(lex_stuff)
 193 # define PL_tokenbuf       D_PPP_my_PL_parser_var(tokenbuf)
 194 # define PL_in_my          D_PPP_my_PL_parser_var(in_my)
 195 # define PL_in_my_stash    D_PPP_my_PL_parser_var(in_my_stash)
 196 # define PL_error_count    D_PPP_my_PL_parser_var(error_count)
 197
 198
 199 #else
 200
 201 /* ensure that PL_parser != NULL and cannot be dereferenced */
 202 # define PL_parser         ((void *) 1)
 203
 204 #endif
 205
 206 =xsinit
 207
 208 #define NEED_PL_signals
 209 #define NEED_PL_parser
 210 #define DPPP_PL_parser_NO_DUMMY_WARNING
 211
 212 =xsmisc
 213
 214 U32 get_PL_signals_1(void)
 215 {
 216 #ifdef PERL_NO_GET_CONTEXT
 217   dTHX;
 218 #endif
 219   return PL_signals;
 220 }
 221
 222 extern U32 get_PL_signals_2(void);
 223 extern U32 get_PL_signals_3(void);
 224 int no_dummy_parser_vars(int);
 225 int dummy_parser_warning(void);
 226
 227 /* No PTRSIZE IN 5.004 and below, so PTR2IV would warn and possibly misbehave */
 228 #if { VERSION > 5.004 }
 229   #define ppp_TESTVAR(var)          STMT_START { mXPUSHi(PTR2IV(&var)); count++; } STMT_END
 230 #else
 231   #define ppp_TESTVAR(var)          STMT_START { mXPUSHi(&var); count++; } STMT_END
 232 #endif
 233
 234 #define ppp_PARSERVAR(type, var)  STMT_START {                   \
 235                                     type volatile my_ ## var;    \
 236                                     type volatile *my_p_ ## var; \
 237                                     my_ ## var = var;            \
 238                                     my_p_ ## var = &var;         \
 239                                     var = my_ ## var;            \
 240                                     var = *my_p_ ## var;         \
 241                                     mXPUSHi(&var != NULL);       \
 242                                     count++;                     \
 243                                   } STMT_END
 244
 245 #define ppp_PARSERVAR_dummy       STMT_START {                   \
 246                                     mXPUSHi(1);                  \
 247                                     count++;                     \
 248                                   } STMT_END
 249
 250 #if { VERSION < 5.004 }
 251 # define ppp_rsfp_t FILE *
 252 #else
 253 # define ppp_rsfp_t PerlIO *
 254 #endif
 255
 256 #if { VERSION < 5.6.0 }
 257 # define ppp_expect_t expectation
 258 #elif { VERSION < 5.9.5 }
 259 # define ppp_expect_t int
 260 #else
 261 # define ppp_expect_t U8
 262 #endif
 263
 264 #if { VERSION < 5.9.5 }
 265 # define ppp_lex_state_t U32
 266 #else
 267 # define ppp_lex_state_t U8
 268 #endif
 269
 270 #if { VERSION < 5.6.0 }
 271 # define ppp_in_my_t bool
 272 #elif { VERSION < 5.9.5 }
 273 # define ppp_in_my_t I32
 274 #else
 275 # define ppp_in_my_t U16
 276 #endif
 277
 278 #if { VERSION < 5.9.5 }
 279 # define ppp_error_count_t I32
 280 #else
 281 # define ppp_error_count_t U8
 282 #endif
 283
 284 =xsubs
 285
 286 int
 287 compare_PL_signals()
 288         CODE:
 289                 {
 290                   U32 ref = get_PL_signals_1();
 291                   RETVAL = ref == get_PL_signals_2() && ref == get_PL_signals_3();
 292                 }
 293         OUTPUT:
 294                 RETVAL
 295
 296 SV *
 297 PL_sv_undef()
 298         CODE:
 299                 RETVAL = newSVsv(&PL_sv_undef);
 300         OUTPUT:
 301                 RETVAL
 302
 303 SV *
 304 PL_sv_yes()
 305         CODE:
 306                 RETVAL = newSVsv(&PL_sv_yes);
 307         OUTPUT:
 308                 RETVAL
 309
 310 SV *
 311 PL_sv_no()
 312         CODE:
 313                 RETVAL = newSVsv(&PL_sv_no);
 314         OUTPUT:
 315                 RETVAL
 316
 317 int
 318 PL_na(string)
 319         char *string
 320         CODE:
 321                 PL_na = strlen(string);
 322                 RETVAL = PL_na;
 323         OUTPUT:
 324                 RETVAL
 325
 326 SV *
 327 PL_Sv()
 328         CODE:
 329                 PL_Sv = newSVpv("mhx", 0);
 330                 RETVAL = PL_Sv;
 331         OUTPUT:
 332                 RETVAL
 333
 334 SV *
 335 PL_tokenbuf()
 336         CODE:
 337                 RETVAL = newSViv(PL_tokenbuf[0]);
 338         OUTPUT:
 339                 RETVAL
 340
 341 SV *
 342 PL_parser()
 343         CODE:
 344                 RETVAL = newSViv(PL_parser != NULL);
 345         OUTPUT:
 346                 RETVAL
 347
 348 SV *
 349 PL_hexdigit()
 350         CODE:
 351                 RETVAL = newSVpv((char *) PL_hexdigit, 0);
 352         OUTPUT:
 353                 RETVAL
 354
 355 SV *
 356 PL_hints()
 357         CODE:
 358                 RETVAL = newSViv((IV) PL_hints);
 359         OUTPUT:
 360                 RETVAL
 361
 362 void
 363 PL_ppaddr(string)
 364         char *string
 365         PPCODE:
 366                 PUSHMARK(SP);
 367                 mXPUSHs(newSVpv(string, 0));
 368                 PUTBACK;
 369                 ENTER;
 370                 (void)*(PL_ppaddr[OP_UC])(aTHXR);
 371                 SPAGAIN;
 372                 LEAVE;
 373                 XSRETURN(1);
 374
 375 void
 376 other_variables()
 377         PREINIT:
 378                 int count = 0;
 379         PPCODE:
 380                 ppp_TESTVAR(PL_DBsignal);
 381                 ppp_TESTVAR(PL_DBsingle);
 382                 ppp_TESTVAR(PL_DBsub);
 383                 ppp_TESTVAR(PL_DBtrace);
 384                 ppp_TESTVAR(PL_compiling);
 385                 ppp_TESTVAR(PL_curcop);
 386                 ppp_TESTVAR(PL_curstash);
 387                 ppp_TESTVAR(PL_debstash);
 388                 ppp_TESTVAR(PL_defgv);
 389                 ppp_TESTVAR(PL_diehook);
 390 #if { VERSION >= 5.13.7 }
 391                 /* can't get a pointer any longer */
 392                 mXPUSHi(PL_dirty ? 1 : 1);
 393                 count++;
 394 #else
 395                 ppp_TESTVAR(PL_dirty);
 396 #endif
 397                 ppp_TESTVAR(PL_dowarn);
 398                 ppp_TESTVAR(PL_errgv);
 399                 ppp_TESTVAR(PL_laststatval);
 400                 ppp_TESTVAR(PL_no_modify);
 401                 ppp_TESTVAR(PL_perl_destruct_level);
 402                 ppp_TESTVAR(PL_perldb);
 403                 ppp_TESTVAR(PL_stack_base);
 404                 ppp_TESTVAR(PL_stack_sp);
 405                 ppp_TESTVAR(PL_statcache);
 406                 ppp_TESTVAR(PL_stdingv);
 407                 ppp_TESTVAR(PL_sv_arenaroot);
 408                 ppp_TESTVAR(PL_tainted);
 409                 ppp_TESTVAR(PL_tainting);
 410
 411                 ppp_PARSERVAR(ppp_expect_t, PL_expect);
 412                 ppp_PARSERVAR(line_t, PL_copline);
 413                 ppp_PARSERVAR(ppp_rsfp_t, PL_rsfp);
 414                 ppp_PARSERVAR(AV *, PL_rsfp_filters);
 415                 ppp_PARSERVAR(SV *, PL_linestr);
 416                 ppp_PARSERVAR(char *, PL_bufptr);
 417                 ppp_PARSERVAR(char *, PL_bufend);
 418                 ppp_PARSERVAR(ppp_lex_state_t, PL_lex_state);
 419                 ppp_PARSERVAR(SV *, PL_lex_stuff);
 420                 ppp_PARSERVAR(ppp_error_count_t, PL_error_count);
 421                 ppp_PARSERVAR(ppp_in_my_t, PL_in_my);
 422 #if { VERSION >= 5.5.0 }
 423                 ppp_PARSERVAR(HV*, PL_in_my_stash);
 424 #else
 425                 ppp_PARSERVAR_dummy;
 426 #endif
 427                 XSRETURN(count);
 428
 429 int
 430 no_dummy_parser_vars(check)
 431         int check
 432
 433 int
 434 dummy_parser_warning()
 435
 436 =tests plan => 52
 437
 438 ok(Devel::PPPort::compare_PL_signals());
 439
 440 ok(!defined(&Devel::PPPort::PL_sv_undef()));
 441 ok(&Devel::PPPort::PL_sv_yes());
 442 ok(!&Devel::PPPort::PL_sv_no());
 443 ok(&Devel::PPPort::PL_na("abcd"), 4);
 444 ok(&Devel::PPPort::PL_Sv(), "mhx");
 445 ok(defined &Devel::PPPort::PL_tokenbuf());
 446 ok("$]" >= 5.009005 || &Devel::PPPort::PL_parser());
 447 ok(&Devel::PPPort::PL_hexdigit() =~ /^[0-9a-zA-Z]+$/);
 448 ok(defined &Devel::PPPort::PL_hints());
 449 ok(&Devel::PPPort::PL_ppaddr("mhx"), "MHX");
 450
 451 for (&Devel::PPPort::other_variables()) {
 452   ok($_ != 0);
 453 }
 454
 455 {
 456   my @w;
 457   my $fail = 0;
 458   {
 459     local $SIG{'__WARN__'} = sub { push @w, @_ };
 460     ok(&Devel::PPPort::dummy_parser_warning());
 461   }
 462   if ("$]" >= 5.009005) {
 463     ok(@w >= 0);
 464     for (@w) {
 465       print "# $_";
 466       unless (/^warning: dummy PL_bufptr used in.*module3.*:\d+/i) {
 467         warn $_;
 468         $fail++;
 469       }
 470     }
 471   }
 472   else {
 473     ok(@w == 0);
 474   }
 475   ok($fail, 0);
 476 }
 477
 478 ok(&Devel::PPPort::no_dummy_parser_vars(1) >= ("$]" < 5.009005 ? 1 : 0));
 479
 480 eval { &Devel::PPPort::no_dummy_parser_vars(0) };
 481
 482 if ("$]" < 5.009005) {
 483   ok($@, '');
 484 }
 485 else {
 486   if ($@) {
 487     print "# $@";
 488     ok($@ =~ /^panic: PL_parser == NULL in.*module2.*:\d+/i);
 489   }
 490   else {
 491     ok(1);
 492   }
 493 }