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