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