1 ################################################################################
5 ## $Date: 2009/01/23 18:27:48 +0100 $
7 ################################################################################
9 ## Version 3.x, Copyright (C) 2004-2009, Marcus Holland-Moritz.
10 ## Version 2.x, Copyright (C) 2001, Paul Marquess.
11 ## Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
13 ## This program is free software; you can redistribute it and/or
14 ## modify it under the same terms as Perl itself.
16 ################################################################################
33 __UNDEFINED__ call_sv perl_call_sv
34 __UNDEFINED__ call_pv perl_call_pv
35 __UNDEFINED__ call_argv perl_call_argv
36 __UNDEFINED__ call_method perl_call_method
38 __UNDEFINED__ eval_sv perl_eval_sv
41 __UNDEFINED__ PERL_LOADMOD_DENY 0x1
42 __UNDEFINED__ PERL_LOADMOD_NOIMPORT 0x2
43 __UNDEFINED__ PERL_LOADMOD_IMPORT_OPS 0x4
50 # if { VERSION < 5.6.0 }
51 # define call_sv(sv, flags) ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \
52 (flags) & ~G_METHOD) : perl_call_sv(sv, flags))
54 # define call_sv(sv, flags) ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \
55 (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags))
59 /* Replace perl_eval_pv with eval_pv */
65 eval_pv(char *p, I32 croak_on_error)
68 SV* sv = newSVpv(p, 0);
71 eval_sv(sv, G_SCALAR);
78 if (croak_on_error && SvTRUE(GvSV(errgv)))
79 croak(SvPVx(GvSV(errgv), na));
88 #if { NEED vload_module }
91 vload_module(U32 flags, SV *name, SV *ver, va_list *args)
97 OP * const modname = newSVOP(OP_CONST, 0, name);
98 /* 5.005 has a somewhat hacky force_normal that doesn't croak on
99 SvREADONLY() if PL_compling is true. Current perls take care in
100 ck_require() to correctly turn off SvREADONLY before calling
101 force_normal_flags(). This seems a better fix than fudging PL_compling
103 SvREADONLY_off(((SVOP*)modname)->op_sv);
104 modname->op_private |= OPpCONST_BARE;
106 veop = newSVOP(OP_CONST, 0, ver);
110 if (flags & PERL_LOADMOD_NOIMPORT) {
111 imop = sawparens(newNULLLIST());
113 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
114 imop = va_arg(*args, OP*);
119 sv = va_arg(*args, SV*);
121 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
122 sv = va_arg(*args, SV*);
126 const line_t ocopline = PL_copline;
127 COP * const ocurcop = PL_curcop;
128 const int oexpect = PL_expect;
130 #if { VERSION >= 5.004 }
131 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
132 veop, modname, imop);
134 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(),
138 PL_copline = ocopline;
147 #if { NEED load_module }
150 load_module(U32 flags, SV *name, SV *ver, ...)
154 vload_module(flags, name, ver, &args);
164 #define NEED_load_module
165 #define NEED_vload_module
198 i = eval_sv(sv, flags);
204 eval_pv(p, croak_on_error)
210 PUSHs(eval_pv(p, croak_on_error));
213 call_sv(sv, flags, ...)
219 for (i=0; i<items-2; i++)
220 ST(i) = ST(i+2); /* pop first two args */
224 i = call_sv(sv, flags);
230 call_pv(subname, flags, ...)
236 for (i=0; i<items-2; i++)
237 ST(i) = ST(i+2); /* pop first two args */
241 i = call_pv(subname, flags);
247 call_argv(subname, flags, ...)
254 if (items > 8) /* play safe */
256 for (i=2; i<items; i++)
257 args[i-2] = SvPV_nolen(ST(i));
258 args[items-2] = NULL;
260 i = call_argv(subname, flags, args);
266 call_method(methname, flags, ...)
272 for (i=0; i<items-2; i++)
273 ST(i) = ST(i+2); /* pop first two args */
277 i = call_method(methname, flags);
283 call_sv_G_METHOD(sv, flags, ...)
289 for (i=0; i<items-2; i++)
290 ST(i) = ST(i+2); /* pop first two args */
294 i = call_sv(sv, flags | G_METHOD);
300 load_module(flags, name, version, ...)
305 /* Both SV parameters are donated to the ops built inside
306 load_module, so we need to bump the refcounts. */
307 Perl_load_module(aTHX_ flags, SvREFCNT_inc_simple(name),
308 SvREFCNT_inc_simple(version), NULL);
315 join(':', @$a) eq join(':', @$b);
323 @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z';
326 my $obj = bless [], 'Foo';
330 return 'bad_self' unless @_ && ref $_[0] && ref($_[0]) eq 'Foo';
335 @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z';
341 # flags args expected description
342 [ &Devel::PPPort::G_SCALAR, [ ], [ qw(y 1) ], '0 args, G_SCALAR' ],
343 [ &Devel::PPPort::G_SCALAR, [ qw(a p q) ], [ qw(y 1) ], '3 args, G_SCALAR' ],
344 [ &Devel::PPPort::G_ARRAY, [ ], [ qw(x 1) ], '0 args, G_ARRAY' ],
345 [ &Devel::PPPort::G_ARRAY, [ qw(a p q) ], [ qw(b p x 3) ], '3 args, G_ARRAY' ],
346 [ &Devel::PPPort::G_DISCARD, [ ], [ qw(0) ], '0 args, G_DISCARD' ],
347 [ &Devel::PPPort::G_DISCARD, [ qw(a p q) ], [ qw(0) ], '3 args, G_DISCARD' ],
350 my ($flags, $args, $expected, $description) = @$test;
351 print "# --- $description ---\n";
352 ok(eq_array( [ &Devel::PPPort::call_sv(\&f, $flags, @$args) ], $expected));
353 ok(eq_array( [ &Devel::PPPort::call_sv(*f, $flags, @$args) ], $expected));
354 ok(eq_array( [ &Devel::PPPort::call_sv('f', $flags, @$args) ], $expected));
355 ok(eq_array( [ &Devel::PPPort::call_pv('f', $flags, @$args) ], $expected));
356 ok(eq_array( [ &Devel::PPPort::call_argv('f', $flags, @$args) ], $expected));
357 ok(eq_array( [ &Devel::PPPort::eval_sv("f(qw(@$args))", $flags) ], $expected));
358 ok(eq_array( [ &Devel::PPPort::call_method('meth', $flags, $obj, @$args) ], $expected));
359 ok(eq_array( [ &Devel::PPPort::call_sv_G_METHOD('meth', $flags, $obj, @$args) ], $expected));
362 ok(&Devel::PPPort::eval_pv('f()', 0), 'y');
363 ok(&Devel::PPPort::eval_pv('f(qw(a b c))', 0), 'y');
365 ok(!defined $::{'less::'}, 1, "Hadn't loaded less yet");
366 Devel::PPPort::load_module(0, "less", undef);
367 ok(defined $::{'less::'}, 1, "Have now loaded less");