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