Commit | Line | Data |
0d0f8426 |
1 | ################################################################################ |
2 | ## |
51d6c659 |
3 | ## $Revision: 19 $ |
0d0f8426 |
4 | ## $Author: mhx $ |
51d6c659 |
5 | ## $Date: 2009/01/18 14:10:53 +0100 $ |
0d0f8426 |
6 | ## |
7 | ################################################################################ |
8 | ## |
51d6c659 |
9 | ## Version 3.x, Copyright (C) 2004-2009, Marcus Holland-Moritz. |
0d0f8426 |
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 | |
679ad62d |
20 | PL_ppaddr |
21 | PL_no_modify |
22 | PL_DBsignal |
23 | PL_DBsingle |
24 | PL_DBsub |
25 | PL_DBtrace |
26 | PL_Sv |
c01be2ce |
27 | PL_bufend |
28 | PL_bufptr |
679ad62d |
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 |
c01be2ce |
43 | PL_lex_state |
44 | PL_lex_stuff |
45 | PL_linestr |
679ad62d |
46 | PL_na |
c01be2ce |
47 | PL_parser |
679ad62d |
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 |
c01be2ce |
62 | PL_tokenbuf |
679ad62d |
63 | PL_signals |
0d0f8426 |
64 | PERL_SIGNALS_UNSAFE_FLAG |
65 | |
66 | =implementation |
67 | |
68 | #ifndef PERL_SIGNALS_UNSAFE_FLAG |
69 | |
70 | #define PERL_SIGNALS_UNSAFE_FLAG 0x0001 |
71 | |
cac25305 |
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 |
0d0f8426 |
81 | |
cac25305 |
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 | |
c58e738a |
89 | #if { VERSION <= 5.005_05 } |
cac25305 |
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 |
c01be2ce |
103 | # define PL_bufend bufend |
104 | # define PL_bufptr bufptr |
cac25305 |
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 |
a89b7ab8 |
115 | # define PL_expect expect |
cac25305 |
116 | # define PL_hexdigit hexdigit |
117 | # define PL_hints hints |
118 | # define PL_laststatval laststatval |
c01be2ce |
119 | # define PL_lex_state lex_state |
120 | # define PL_lex_stuff lex_stuff |
121 | # define PL_linestr linestr |
cac25305 |
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 |
c01be2ce |
137 | # define PL_tokenbuf tokenbuf |
cac25305 |
138 | /* Replace: 0 */ |
0d0f8426 |
139 | #endif |
140 | |
c01be2ce |
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. |
679ad62d |
149 | */ |
150 | |
53a7735b |
151 | #if { VERSION >= 5.9.5 } |
c01be2ce |
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 | |
53a7735b |
199 | #endif |
200 | |
0d0f8426 |
201 | =xsinit |
202 | |
203 | #define NEED_PL_signals |
c01be2ce |
204 | #define NEED_PL_parser |
205 | #define DPPP_PL_parser_NO_DUMMY_WARNING |
0d0f8426 |
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); |
c01be2ce |
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 | |
fd7af155 |
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 } |
c01be2ce |
239 | # define ppp_expect_t expectation |
fd7af155 |
240 | #elif { VERSION < 5.9.5 } |
c01be2ce |
241 | # define ppp_expect_t int |
242 | #else |
243 | # define ppp_expect_t U8 |
244 | #endif |
0d0f8426 |
245 | |
fd7af155 |
246 | #if { VERSION < 5.9.5 } |
c01be2ce |
247 | # define ppp_lex_state_t U32 |
248 | #else |
249 | # define ppp_lex_state_t U8 |
250 | #endif |
cac25305 |
251 | |
0d0f8426 |
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 | |
cac25305 |
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 * |
c01be2ce |
303 | PL_tokenbuf() |
679ad62d |
304 | CODE: |
c01be2ce |
305 | RETVAL = newSViv(PL_tokenbuf[0]); |
679ad62d |
306 | OUTPUT: |
307 | RETVAL |
308 | |
309 | SV * |
c01be2ce |
310 | PL_parser() |
679ad62d |
311 | CODE: |
c01be2ce |
312 | RETVAL = newSViv(PL_parser != NULL); |
679ad62d |
313 | OUTPUT: |
314 | RETVAL |
315 | |
316 | SV * |
cac25305 |
317 | PL_hexdigit() |
318 | CODE: |
aab9a3b6 |
319 | RETVAL = newSVpv((char *) PL_hexdigit, 0); |
cac25305 |
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); |
c1a049cb |
335 | mXPUSHs(newSVpv(string, 0)); |
cac25305 |
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); |
cac25305 |
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); |
c01be2ce |
372 | |
373 | ppp_PARSERVAR(ppp_expect_t, PL_expect); |
374 | ppp_PARSERVAR(line_t, PL_copline); |
fd7af155 |
375 | ppp_PARSERVAR(ppp_rsfp_t, PL_rsfp); |
c01be2ce |
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 | |
cac25305 |
383 | XSRETURN(count); |
384 | |
c01be2ce |
385 | int |
386 | no_dummy_parser_vars(check) |
387 | int check |
388 | |
389 | int |
390 | dummy_parser_warning() |
391 | |
392 | =tests plan => 49 |
0d0f8426 |
393 | |
394 | ok(Devel::PPPort::compare_PL_signals()); |
395 | |
cac25305 |
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"); |
c01be2ce |
401 | ok(defined &Devel::PPPort::PL_tokenbuf()); |
402 | ok($] >= 5.009005 || &Devel::PPPort::PL_parser()); |
cac25305 |
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 | } |
c01be2ce |
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 | } |