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
1 ################################################################################
2 ##
3 ##  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
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
14 eval_pv
15 eval_sv
16 call_sv
17 call_pv
18 call_argv
19 call_method
20 load_module
21 vload_module
22 G_METHOD
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
33 /* Replace: 0 */
34
35 __UNDEFINED__ PERL_LOADMOD_DENY         0x1
36 __UNDEFINED__ PERL_LOADMOD_NOIMPORT     0x2
37 __UNDEFINED__ PERL_LOADMOD_IMPORT_OPS   0x4
38
39 #ifndef G_METHOD
40 # define G_METHOD               64
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), \
46                                 (flags) & ~G_METHOD) : perl_call_sv(sv, flags))
47 # else
48 #  define call_sv(sv, flags)  ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \
49                                 (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags))
50 # endif
51 #endif
52
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
65 /* Replace perl_eval_pv with eval_pv */
66
67 #ifndef eval_pv
68 #if { NEED eval_pv }
69
70 SV*
71 eval_pv(char *p, I32 croak_on_error)
72 {
73     dSP;
74     SV* errsv;
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
85     if (croak_on_error) {
86         errsv = ERRSV;
87         if (SvROK(errsv) || SvTRUE(errsv))
88             croak_sv(errsv);
89     }
90
91     return sv;
92 }
93
94 #endif
95 #endif
96
97 #ifndef vload_module
98 #if { NEED vload_module }
99
100 void
101 vload_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) {
116         veop = newSVOP(OP_CONST, 0, ver);
117     }
118     else
119         veop = NULL;
120     if (flags & PERL_LOADMOD_NOIMPORT) {
121         imop = sawparens(newNULLLIST());
122     }
123     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
124         imop = va_arg(*args, OP*);
125     }
126     else {
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         }
134     }
135     {
136         const line_t ocopline = PL_copline;
137         COP * const ocurcop = PL_curcop;
138         const int oexpect = PL_expect;
139
140 #if { VERSION >= 5.004 }
141         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
142                 veop, modname, imop);
143 #elif { VERSION > 5.003 }
144         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(),
145                 veop, modname, imop);
146 #else
147         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(),
148                 modname, imop);
149 #endif
150         PL_expect = oexpect;
151         PL_copline = ocopline;
152         PL_curcop = ocurcop;
153     }
154 }
155
156 #endif
157 #endif
158
159 #ifndef load_module
160 #if { NEED load_module }
161
162 void
163 load_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
174 =xsinit
175
176 #define NEED_eval_pv
177 #define NEED_load_module
178 #define NEED_vload_module
179
180 =xsubs
181
182 I32
183 G_SCALAR()
184         CODE:
185                 RETVAL = G_SCALAR;
186         OUTPUT:
187                 RETVAL
188
189 I32
190 G_ARRAY()
191         CODE:
192                 RETVAL = G_ARRAY;
193         OUTPUT:
194                 RETVAL
195
196 I32
197 G_DISCARD()
198         CODE:
199                 RETVAL = G_DISCARD;
200         OUTPUT:
201                 RETVAL
202
203 void
204 eval_sv(sv, flags)
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);
215
216 void
217 eval_pv(p, croak_on_error)
218         char* p
219         I32 croak_on_error
220         PPCODE:
221                 PUTBACK;
222                 EXTEND(SP, 1);
223                 PUSHs(eval_pv(p, croak_on_error));
224
225 void
226 call_sv(sv, flags, ...)
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);
241
242 void
243 call_pv(subname, flags, ...)
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);
258
259 void
260 call_argv(subname, flags, ...)
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);
277
278 void
279 call_method(methname, flags, ...)
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);
294
295 void
296 call_sv_G_METHOD(sv, flags, ...)
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);
311
312 void
313 load_module(flags, name, version, ...)
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);
322
323 =tests plan => 69
324
325 sub eq_array
326 {
327   my($a, $b) = @_;
328   join(':', @$a) eq join(':', @$b);
329 }
330
331 sub f
332 {
333   shift;
334   unshift @_, 'b';
335   pop @_;
336   @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z';
337 }
338
339 my $obj = bless [], 'Foo';
340
341 sub 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
351 my $test;
352
353 for $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));
372     ok(eq_array( [ &Devel::PPPort::call_sv_G_METHOD('meth', $flags, $obj, @$args) ], $expected));
373 };
374
375 ok(&Devel::PPPort::eval_pv('f()', 0), 'y');
376 ok(&Devel::PPPort::eval_pv('f(qw(a b c))', 0), 'y');
377
378 ok(!defined $::{'less::'}, 1, "Hadn't loaded less yet");
379 Devel::PPPort::load_module(0, "less", undef);
380 ok(defined $::{'less::'}, 1, "Have now loaded less");
381
382 ok(eval { Devel::PPPort::eval_pv('die', 0); 1 });
383 ok(!eval { Devel::PPPort::eval_pv('die', 1); 1 });
384 ok($@ =~ /^Died at \(eval [0-9]+\) line 1\.\n$/);
385 ok(eval { $@ = 'string1'; Devel::PPPort::eval_pv('', 0); 1 });
386 ok(eval { $@ = 'string1'; Devel::PPPort::eval_pv('', 1); 1 });
387 ok(eval { $@ = 'string1'; Devel::PPPort::eval_pv('$@ = "string2"', 0); 1 });
388 ok(eval { $@ = 'string1'; Devel::PPPort::eval_pv('$@ = "string2"', 1); 1 });
389 ok(eval { $@ = 'string1'; Devel::PPPort::eval_pv('$@ = "string2"; die "string3"', 0); 1 });
390 ok(!eval { $@ = 'string1'; Devel::PPPort::eval_pv('$@ = "string2"; die "string3"', 1); 1 });
391 ok($@ =~ /^string3 at \(eval [0-9]+\) line 1\.\n$/);
392
393 if ($] 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 }