This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix eval_pv for Perl versions prior to 5.31.2
[perl5.git] / dist / Devel-PPPort / parts / inc / call
CommitLineData
adfe19db
MHM
1################################################################################
2##
b2049988 3## Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
adfe19db
MHM
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
14eval_pv
15eval_sv
16call_sv
17call_pv
18call_argv
19call_method
a89b7ab8
MHM
20load_module
21vload_module
ac2e3cea 22G_METHOD
adfe19db
MHM
23
24=implementation
25
26/* Replace: 1 */
27__UNDEFINED__ call_sv perl_call_sv
28__UNDEFINED__ call_pv perl_call_pv
29__UNDEFINED__ call_argv perl_call_argv
30__UNDEFINED__ call_method perl_call_method
31
32__UNDEFINED__ eval_sv perl_eval_sv
ac2e3cea 33/* Replace: 0 */
a89b7ab8 34
b2049988
MHM
35__UNDEFINED__ PERL_LOADMOD_DENY 0x1
36__UNDEFINED__ PERL_LOADMOD_NOIMPORT 0x2
37__UNDEFINED__ PERL_LOADMOD_IMPORT_OPS 0x4
a89b7ab8 38
ac2e3cea 39#ifndef G_METHOD
b2049988 40# define G_METHOD 64
ac2e3cea
MHM
41# ifdef call_sv
42# undef call_sv
43# endif
44# if { VERSION < 5.6.0 }
45# define call_sv(sv, flags) ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \
b2049988 46 (flags) & ~G_METHOD) : perl_call_sv(sv, flags))
ac2e3cea
MHM
47# else
48# define call_sv(sv, flags) ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \
b2049988 49 (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags))
ac2e3cea
MHM
50# endif
51#endif
adfe19db 52
1f8708ac
P
53/* Older Perl versions have broken croak_on_error=1 */
54#if { VERSION < 5.31.2 }
55# ifdef eval_pv
56# undef eval_pv
57# if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
58# define eval_pv(p, croak_on_error) ({ SV *_sv = Perl_eval_pv(aTHX_ p, 0); SV *_errsv = ERRSV; (croak_on_error && (SvROK(_errsv) || SvTRUE(_errsv)) && (croak_sv(_errsv), 1)); _sv; })
59# else
60# define eval_pv(p, croak_on_error) ((PL_Sv = Perl_eval_pv(aTHX_ p, 0)), (croak_on_error && (SvROK(ERRSV) || SvTRUE(ERRSV)) && (croak_sv(ERRSV), 1)), PL_Sv)
61# endif
62# endif
63#endif
64
adfe19db 65/* Replace perl_eval_pv with eval_pv */
adfe19db
MHM
66
67#ifndef eval_pv
68#if { NEED eval_pv }
69
70SV*
71eval_pv(char *p, I32 croak_on_error)
72{
73 dSP;
f1305528 74 SV* errsv;
adfe19db
MHM
75 SV* sv = newSVpv(p, 0);
76
77 PUSHMARK(sp);
78 eval_sv(sv, G_SCALAR);
79 SvREFCNT_dec(sv);
80
81 SPAGAIN;
82 sv = POPs;
83 PUTBACK;
84
f1305528
P
85 if (croak_on_error) {
86 errsv = ERRSV;
1f8708ac 87 if (SvROK(errsv) || SvTRUE(errsv))
f1305528
P
88 croak_sv(errsv);
89 }
adfe19db
MHM
90
91 return sv;
92}
93
94#endif
95#endif
96
a89b7ab8
MHM
97#ifndef vload_module
98#if { NEED vload_module }
99
100void
101vload_module(U32 flags, SV *name, SV *ver, va_list *args)
102{
103 dTHR;
104 dVAR;
105 OP *veop, *imop;
106
107 OP * const modname = newSVOP(OP_CONST, 0, name);
108 /* 5.005 has a somewhat hacky force_normal that doesn't croak on
109 SvREADONLY() if PL_compling is true. Current perls take care in
110 ck_require() to correctly turn off SvREADONLY before calling
111 force_normal_flags(). This seems a better fix than fudging PL_compling
112 */
113 SvREADONLY_off(((SVOP*)modname)->op_sv);
114 modname->op_private |= OPpCONST_BARE;
115 if (ver) {
b2049988 116 veop = newSVOP(OP_CONST, 0, ver);
a89b7ab8
MHM
117 }
118 else
b2049988 119 veop = NULL;
a89b7ab8 120 if (flags & PERL_LOADMOD_NOIMPORT) {
b2049988 121 imop = sawparens(newNULLLIST());
a89b7ab8
MHM
122 }
123 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
b2049988 124 imop = va_arg(*args, OP*);
a89b7ab8
MHM
125 }
126 else {
b2049988
MHM
127 SV *sv;
128 imop = NULL;
129 sv = va_arg(*args, SV*);
130 while (sv) {
131 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
132 sv = va_arg(*args, SV*);
133 }
a89b7ab8
MHM
134 }
135 {
b2049988
MHM
136 const line_t ocopline = PL_copline;
137 COP * const ocurcop = PL_curcop;
138 const int oexpect = PL_expect;
a89b7ab8
MHM
139
140#if { VERSION >= 5.004 }
b2049988
MHM
141 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
142 veop, modname, imop);
ea4b7f32
JH
143#elif { VERSION > 5.003 }
144 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(),
145 veop, modname, imop);
a89b7ab8 146#else
b2049988
MHM
147 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(),
148 modname, imop);
a89b7ab8 149#endif
b2049988
MHM
150 PL_expect = oexpect;
151 PL_copline = ocopline;
152 PL_curcop = ocurcop;
a89b7ab8
MHM
153 }
154}
155
156#endif
157#endif
158
a89b7ab8
MHM
159#ifndef load_module
160#if { NEED load_module }
161
162void
163load_module(U32 flags, SV *name, SV *ver, ...)
164{
165 va_list args;
166 va_start(args, ver);
167 vload_module(flags, name, ver, &args);
168 va_end(args);
169}
170
171#endif
172#endif
173
adfe19db
MHM
174=xsinit
175
176#define NEED_eval_pv
a89b7ab8
MHM
177#define NEED_load_module
178#define NEED_vload_module
adfe19db
MHM
179
180=xsubs
181
182I32
183G_SCALAR()
b2049988
MHM
184 CODE:
185 RETVAL = G_SCALAR;
186 OUTPUT:
187 RETVAL
adfe19db
MHM
188
189I32
190G_ARRAY()
b2049988
MHM
191 CODE:
192 RETVAL = G_ARRAY;
193 OUTPUT:
194 RETVAL
adfe19db
MHM
195
196I32
197G_DISCARD()
b2049988
MHM
198 CODE:
199 RETVAL = G_DISCARD;
200 OUTPUT:
201 RETVAL
adfe19db
MHM
202
203void
204eval_sv(sv, flags)
b2049988
MHM
205 SV* sv
206 I32 flags
207 PREINIT:
208 I32 i;
209 PPCODE:
210 PUTBACK;
211 i = eval_sv(sv, flags);
212 SPAGAIN;
213 EXTEND(SP, 1);
214 mPUSHi(i);
adfe19db
MHM
215
216void
217eval_pv(p, croak_on_error)
b2049988
MHM
218 char* p
219 I32 croak_on_error
220 PPCODE:
221 PUTBACK;
222 EXTEND(SP, 1);
223 PUSHs(eval_pv(p, croak_on_error));
adfe19db
MHM
224
225void
226call_sv(sv, flags, ...)
b2049988
MHM
227 SV* sv
228 I32 flags
229 PREINIT:
230 I32 i;
231 PPCODE:
232 for (i=0; i<items-2; i++)
233 ST(i) = ST(i+2); /* pop first two args */
234 PUSHMARK(SP);
235 SP += items - 2;
236 PUTBACK;
237 i = call_sv(sv, flags);
238 SPAGAIN;
239 EXTEND(SP, 1);
240 mPUSHi(i);
adfe19db
MHM
241
242void
243call_pv(subname, flags, ...)
b2049988
MHM
244 char* subname
245 I32 flags
246 PREINIT:
247 I32 i;
248 PPCODE:
249 for (i=0; i<items-2; i++)
250 ST(i) = ST(i+2); /* pop first two args */
251 PUSHMARK(SP);
252 SP += items - 2;
253 PUTBACK;
254 i = call_pv(subname, flags);
255 SPAGAIN;
256 EXTEND(SP, 1);
257 mPUSHi(i);
adfe19db
MHM
258
259void
260call_argv(subname, flags, ...)
b2049988
MHM
261 char* subname
262 I32 flags
263 PREINIT:
264 I32 i;
265 char *args[8];
266 PPCODE:
267 if (items > 8) /* play safe */
268 XSRETURN_UNDEF;
269 for (i=2; i<items; i++)
270 args[i-2] = SvPV_nolen(ST(i));
271 args[items-2] = NULL;
272 PUTBACK;
273 i = call_argv(subname, flags, args);
274 SPAGAIN;
275 EXTEND(SP, 1);
276 mPUSHi(i);
adfe19db
MHM
277
278void
279call_method(methname, flags, ...)
b2049988
MHM
280 char* methname
281 I32 flags
282 PREINIT:
283 I32 i;
284 PPCODE:
285 for (i=0; i<items-2; i++)
286 ST(i) = ST(i+2); /* pop first two args */
287 PUSHMARK(SP);
288 SP += items - 2;
289 PUTBACK;
290 i = call_method(methname, flags);
291 SPAGAIN;
292 EXTEND(SP, 1);
293 mPUSHi(i);
adfe19db 294
a89b7ab8 295void
ac2e3cea 296call_sv_G_METHOD(sv, flags, ...)
b2049988
MHM
297 SV* sv
298 I32 flags
299 PREINIT:
300 I32 i;
301 PPCODE:
302 for (i=0; i<items-2; i++)
303 ST(i) = ST(i+2); /* pop first two args */
304 PUSHMARK(SP);
305 SP += items - 2;
306 PUTBACK;
307 i = call_sv(sv, flags | G_METHOD);
308 SPAGAIN;
309 EXTEND(SP, 1);
310 mPUSHi(i);
ac2e3cea
MHM
311
312void
a89b7ab8 313load_module(flags, name, version, ...)
b2049988
MHM
314 U32 flags
315 SV *name
316 SV *version
317 CODE:
318 /* Both SV parameters are donated to the ops built inside
319 load_module, so we need to bump the refcounts. */
320 Perl_load_module(aTHX_ flags, SvREFCNT_inc_simple(name),
321 SvREFCNT_inc_simple(version), NULL);
a89b7ab8 322
1f8708ac 323=tests plan => 69
adfe19db
MHM
324
325sub eq_array
326{
327 my($a, $b) = @_;
328 join(':', @$a) eq join(':', @$b);
329}
330
331sub f
332{
333 shift;
334 unshift @_, 'b';
335 pop @_;
336 @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z';
337}
338
339my $obj = bless [], 'Foo';
340
341sub Foo::meth
342{
343 return 'bad_self' unless @_ && ref $_[0] && ref($_[0]) eq 'Foo';
344 shift;
345 shift;
346 unshift @_, 'b';
347 pop @_;
348 @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z';
349}
350
351my $test;
352
353for $test (
354 # flags args expected description
355 [ &Devel::PPPort::G_SCALAR, [ ], [ qw(y 1) ], '0 args, G_SCALAR' ],
356 [ &Devel::PPPort::G_SCALAR, [ qw(a p q) ], [ qw(y 1) ], '3 args, G_SCALAR' ],
357 [ &Devel::PPPort::G_ARRAY, [ ], [ qw(x 1) ], '0 args, G_ARRAY' ],
358 [ &Devel::PPPort::G_ARRAY, [ qw(a p q) ], [ qw(b p x 3) ], '3 args, G_ARRAY' ],
359 [ &Devel::PPPort::G_DISCARD, [ ], [ qw(0) ], '0 args, G_DISCARD' ],
360 [ &Devel::PPPort::G_DISCARD, [ qw(a p q) ], [ qw(0) ], '3 args, G_DISCARD' ],
361)
362{
363 my ($flags, $args, $expected, $description) = @$test;
364 print "# --- $description ---\n";
365 ok(eq_array( [ &Devel::PPPort::call_sv(\&f, $flags, @$args) ], $expected));
366 ok(eq_array( [ &Devel::PPPort::call_sv(*f, $flags, @$args) ], $expected));
367 ok(eq_array( [ &Devel::PPPort::call_sv('f', $flags, @$args) ], $expected));
368 ok(eq_array( [ &Devel::PPPort::call_pv('f', $flags, @$args) ], $expected));
369 ok(eq_array( [ &Devel::PPPort::call_argv('f', $flags, @$args) ], $expected));
370 ok(eq_array( [ &Devel::PPPort::eval_sv("f(qw(@$args))", $flags) ], $expected));
371 ok(eq_array( [ &Devel::PPPort::call_method('meth', $flags, $obj, @$args) ], $expected));
ac2e3cea 372 ok(eq_array( [ &Devel::PPPort::call_sv_G_METHOD('meth', $flags, $obj, @$args) ], $expected));
adfe19db
MHM
373};
374
375ok(&Devel::PPPort::eval_pv('f()', 0), 'y');
376ok(&Devel::PPPort::eval_pv('f(qw(a b c))', 0), 'y');
377
a89b7ab8 378ok(!defined $::{'less::'}, 1, "Hadn't loaded less yet");
c83e6f19 379Devel::PPPort::load_module(0, "less", undef);
a89b7ab8 380ok(defined $::{'less::'}, 1, "Have now loaded less");
1f8708ac
P
381
382ok(eval { Devel::PPPort::eval_pv('die', 0); 1 });
383ok(!eval { Devel::PPPort::eval_pv('die', 1); 1 });
384ok($@ =~ /^Died at \(eval [0-9]+\) line 1\.\n$/);
385ok(eval { $@ = 'string1'; Devel::PPPort::eval_pv('', 0); 1 });
386ok(eval { $@ = 'string1'; Devel::PPPort::eval_pv('', 1); 1 });
387ok(eval { $@ = 'string1'; Devel::PPPort::eval_pv('$@ = "string2"', 0); 1 });
388ok(eval { $@ = 'string1'; Devel::PPPort::eval_pv('$@ = "string2"', 1); 1 });
389ok(eval { $@ = 'string1'; Devel::PPPort::eval_pv('$@ = "string2"; die "string3"', 0); 1 });
390ok(!eval { $@ = 'string1'; Devel::PPPort::eval_pv('$@ = "string2"; die "string3"', 1); 1 });
391ok($@ =~ /^string3 at \(eval [0-9]+\) line 1\.\n$/);
392
393if ($] ge '5.007003' or ($] ge '5.006001' and $] lt '5.007')) {
394 my $hashref = { key => 'value' };
395 ok(eval { Devel::PPPort::eval_pv('die $hashref', 1); 1 }, undef, 'check plain hashref is rethrown');
396 ok(ref($@), 'HASH', 'check $@ is hashref') and
397 ok($@->{key}, 'value', 'check $@ hashref has correct value');
398
399 my $false = False->new;
400 ok(!$false);
401 ok(eval { Devel::PPPort::eval_pv('die $false', 1); 1 }, undef, 'check false objects are rethrown');
402 ok(ref($@), 'False', 'check that $@ contains False object');
403 ok("$@", "$false", 'check we got the expected object');
404} else {
405 skip 'skip: no support for references in $@', 0 for 1..7;
406}
407
408{
409 package False;
410 use overload bool => sub { 0 }, '""' => sub { 'Foo' };
411 sub new { bless {}, shift }
412}