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