Commit | Line | Data |
0d0f8426 |
1 | ################################################################################ |
2 | ## |
bfc37ff7 |
3 | ## $Revision: 21 $ |
0d0f8426 |
4 | ## $Author: mhx $ |
bfc37ff7 |
5 | ## $Date: 2010/03/07 13:15:46 +0100 $ |
0d0f8426 |
6 | ## |
7 | ################################################################################ |
8 | ## |
bfc37ff7 |
9 | ## Version 3.x, Copyright (C) 2004-2010, 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 |
8565c31a |
39 | PL_error_count |
679ad62d |
40 | PL_expect |
41 | PL_hexdigit |
42 | PL_hints |
8565c31a |
43 | PL_in_my |
44 | PL_in_my_stash |
679ad62d |
45 | PL_laststatval |
c01be2ce |
46 | PL_lex_state |
47 | PL_lex_stuff |
48 | PL_linestr |
679ad62d |
49 | PL_na |
c01be2ce |
50 | PL_parser |
679ad62d |
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 |
c01be2ce |
65 | PL_tokenbuf |
679ad62d |
66 | PL_signals |
0d0f8426 |
67 | PERL_SIGNALS_UNSAFE_FLAG |
68 | |
69 | =implementation |
70 | |
71 | #ifndef PERL_SIGNALS_UNSAFE_FLAG |
72 | |
73 | #define PERL_SIGNALS_UNSAFE_FLAG 0x0001 |
74 | |
cac25305 |
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 |
0d0f8426 |
84 | |
cac25305 |
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 | |
c58e738a |
92 | #if { VERSION <= 5.005_05 } |
cac25305 |
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 |
c01be2ce |
106 | # define PL_bufend bufend |
107 | # define PL_bufptr bufptr |
cac25305 |
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 |
8565c31a |
118 | # define PL_error_count error_count |
a89b7ab8 |
119 | # define PL_expect expect |
cac25305 |
120 | # define PL_hexdigit hexdigit |
121 | # define PL_hints hints |
8565c31a |
122 | # define PL_in_my in_my |
cac25305 |
123 | # define PL_laststatval laststatval |
c01be2ce |
124 | # define PL_lex_state lex_state |
125 | # define PL_lex_stuff lex_stuff |
126 | # define PL_linestr linestr |
cac25305 |
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 |
c01be2ce |
142 | # define PL_tokenbuf tokenbuf |
cac25305 |
143 | /* Replace: 0 */ |
0d0f8426 |
144 | #endif |
145 | |
c01be2ce |
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. |
679ad62d |
154 | */ |
155 | |
53a7735b |
156 | #if { VERSION >= 5.9.5 } |
c01be2ce |
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) |
8565c31a |
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 | |
c01be2ce |
202 | |
203 | #else |
204 | |
205 | /* ensure that PL_parser != NULL and cannot be dereferenced */ |
206 | # define PL_parser ((void *) 1) |
207 | |
53a7735b |
208 | #endif |
209 | |
0d0f8426 |
210 | =xsinit |
211 | |
212 | #define NEED_PL_signals |
c01be2ce |
213 | #define NEED_PL_parser |
214 | #define DPPP_PL_parser_NO_DUMMY_WARNING |
0d0f8426 |
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); |
c01be2ce |
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 | |
8565c31a |
241 | #define ppp_PARSERVAR_dummy STMT_START { \ |
242 | mXPUSHi(1); \ |
243 | count++; \ |
244 | } STMT_END |
245 | |
fd7af155 |
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 } |
c01be2ce |
253 | # define ppp_expect_t expectation |
fd7af155 |
254 | #elif { VERSION < 5.9.5 } |
c01be2ce |
255 | # define ppp_expect_t int |
256 | #else |
257 | # define ppp_expect_t U8 |
258 | #endif |
0d0f8426 |
259 | |
fd7af155 |
260 | #if { VERSION < 5.9.5 } |
c01be2ce |
261 | # define ppp_lex_state_t U32 |
262 | #else |
263 | # define ppp_lex_state_t U8 |
264 | #endif |
cac25305 |
265 | |
8565c31a |
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 | |
0d0f8426 |
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 | |
cac25305 |
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 * |
c01be2ce |
331 | PL_tokenbuf() |
679ad62d |
332 | CODE: |
c01be2ce |
333 | RETVAL = newSViv(PL_tokenbuf[0]); |
679ad62d |
334 | OUTPUT: |
335 | RETVAL |
336 | |
337 | SV * |
c01be2ce |
338 | PL_parser() |
679ad62d |
339 | CODE: |
c01be2ce |
340 | RETVAL = newSViv(PL_parser != NULL); |
679ad62d |
341 | OUTPUT: |
342 | RETVAL |
343 | |
344 | SV * |
cac25305 |
345 | PL_hexdigit() |
346 | CODE: |
aab9a3b6 |
347 | RETVAL = newSVpv((char *) PL_hexdigit, 0); |
cac25305 |
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); |
c1a049cb |
363 | mXPUSHs(newSVpv(string, 0)); |
cac25305 |
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 | ppp_TESTVAR(PL_dirty); |
387 | ppp_TESTVAR(PL_dowarn); |
388 | ppp_TESTVAR(PL_errgv); |
389 | ppp_TESTVAR(PL_laststatval); |
390 | ppp_TESTVAR(PL_no_modify); |
391 | ppp_TESTVAR(PL_perl_destruct_level); |
392 | ppp_TESTVAR(PL_perldb); |
cac25305 |
393 | ppp_TESTVAR(PL_stack_base); |
394 | ppp_TESTVAR(PL_stack_sp); |
395 | ppp_TESTVAR(PL_statcache); |
396 | ppp_TESTVAR(PL_stdingv); |
397 | ppp_TESTVAR(PL_sv_arenaroot); |
398 | ppp_TESTVAR(PL_tainted); |
399 | ppp_TESTVAR(PL_tainting); |
c01be2ce |
400 | |
401 | ppp_PARSERVAR(ppp_expect_t, PL_expect); |
402 | ppp_PARSERVAR(line_t, PL_copline); |
fd7af155 |
403 | ppp_PARSERVAR(ppp_rsfp_t, PL_rsfp); |
c01be2ce |
404 | ppp_PARSERVAR(AV *, PL_rsfp_filters); |
405 | ppp_PARSERVAR(SV *, PL_linestr); |
406 | ppp_PARSERVAR(char *, PL_bufptr); |
407 | ppp_PARSERVAR(char *, PL_bufend); |
408 | ppp_PARSERVAR(ppp_lex_state_t, PL_lex_state); |
409 | ppp_PARSERVAR(SV *, PL_lex_stuff); |
8565c31a |
410 | ppp_PARSERVAR(ppp_error_count_t, PL_error_count); |
411 | ppp_PARSERVAR(ppp_in_my_t, PL_in_my); |
412 | #if { VERSION >= 5.5.0 } |
413 | ppp_PARSERVAR(HV*, PL_in_my_stash); |
414 | #else |
415 | ppp_PARSERVAR_dummy; |
416 | #endif |
cac25305 |
417 | XSRETURN(count); |
418 | |
c01be2ce |
419 | int |
420 | no_dummy_parser_vars(check) |
421 | int check |
422 | |
423 | int |
424 | dummy_parser_warning() |
425 | |
8565c31a |
426 | =tests plan => 52 |
0d0f8426 |
427 | |
428 | ok(Devel::PPPort::compare_PL_signals()); |
429 | |
cac25305 |
430 | ok(!defined(&Devel::PPPort::PL_sv_undef())); |
431 | ok(&Devel::PPPort::PL_sv_yes()); |
432 | ok(!&Devel::PPPort::PL_sv_no()); |
433 | ok(&Devel::PPPort::PL_na("abcd"), 4); |
434 | ok(&Devel::PPPort::PL_Sv(), "mhx"); |
c01be2ce |
435 | ok(defined &Devel::PPPort::PL_tokenbuf()); |
436 | ok($] >= 5.009005 || &Devel::PPPort::PL_parser()); |
cac25305 |
437 | ok(&Devel::PPPort::PL_hexdigit() =~ /^[0-9a-zA-Z]+$/); |
438 | ok(defined &Devel::PPPort::PL_hints()); |
439 | ok(&Devel::PPPort::PL_ppaddr("mhx"), "MHX"); |
440 | |
441 | for (&Devel::PPPort::other_variables()) { |
442 | ok($_ != 0); |
443 | } |
c01be2ce |
444 | |
445 | { |
446 | my @w; |
447 | my $fail = 0; |
448 | { |
449 | local $SIG{'__WARN__'} = sub { push @w, @_ }; |
450 | ok(&Devel::PPPort::dummy_parser_warning()); |
451 | } |
452 | if ($] >= 5.009005) { |
453 | ok(@w >= 0); |
454 | for (@w) { |
455 | print "# $_"; |
456 | unless (/^warning: dummy PL_bufptr used in.*module3.*:\d+/i) { |
457 | warn $_; |
458 | $fail++; |
459 | } |
460 | } |
461 | } |
462 | else { |
463 | ok(@w == 0); |
464 | } |
465 | ok($fail, 0); |
466 | } |
467 | |
468 | ok(&Devel::PPPort::no_dummy_parser_vars(1) >= ($] < 5.009005 ? 1 : 0)); |
469 | |
470 | eval { &Devel::PPPort::no_dummy_parser_vars(0) }; |
471 | |
472 | if ($] < 5.009005) { |
473 | ok($@, ''); |
474 | } |
475 | else { |
476 | if ($@) { |
477 | print "# $@"; |
478 | ok($@ =~ /^panic: PL_parser == NULL in.*module2.*:\d+/i); |
479 | } |
480 | else { |
481 | ok(1); |
482 | } |
483 | } |