ext/Devel/PPPort/parts/inc/variables

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