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