1 ################################################################################
5 ## $Date: 2007/08/12 23:57:09 +0200 $
7 ################################################################################
9 ## Version 3.x, Copyright (C) 2004-2007, 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 ################################################################################
32 __UNDEFINED__ call_sv perl_call_sv
33 __UNDEFINED__ call_pv perl_call_pv
34 __UNDEFINED__ call_argv perl_call_argv
35 __UNDEFINED__ call_method perl_call_method
37 __UNDEFINED__ eval_sv perl_eval_sv
39 __UNDEFINED__ PERL_LOADMOD_DENY 0x1
40 __UNDEFINED__ PERL_LOADMOD_NOIMPORT 0x2
41 __UNDEFINED__ PERL_LOADMOD_IMPORT_OPS 0x4
45 /* Replace perl_eval_pv with eval_pv */
51 eval_pv(char *p, I32 croak_on_error)
54 SV* sv = newSVpv(p, 0);
57 eval_sv(sv, G_SCALAR);
64 if (croak_on_error && SvTRUE(GvSV(errgv)))
65 croak(SvPVx(GvSV(errgv), na));
74 #if { NEED vload_module }
77 vload_module(U32 flags, SV *name, SV *ver, va_list *args)
83 OP * const modname = newSVOP(OP_CONST, 0, name);
84 /* 5.005 has a somewhat hacky force_normal that doesn't croak on
85 SvREADONLY() if PL_compling is true. Current perls take care in
86 ck_require() to correctly turn off SvREADONLY before calling
87 force_normal_flags(). This seems a better fix than fudging PL_compling
89 SvREADONLY_off(((SVOP*)modname)->op_sv);
90 modname->op_private |= OPpCONST_BARE;
92 veop = newSVOP(OP_CONST, 0, ver);
96 if (flags & PERL_LOADMOD_NOIMPORT) {
97 imop = sawparens(newNULLLIST());
99 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
100 imop = va_arg(*args, OP*);
105 sv = va_arg(*args, SV*);
107 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
108 sv = va_arg(*args, SV*);
112 const line_t ocopline = PL_copline;
113 COP * const ocurcop = PL_curcop;
114 const int oexpect = PL_expect;
116 #if { VERSION >= 5.004 }
117 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
118 veop, modname, imop);
120 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(),
124 PL_copline = ocopline;
133 #if { NEED load_module }
136 load_module(U32 flags, SV *name, SV *ver, ...)
140 vload_module(flags, name, ver, &args);
150 #define NEED_load_module
151 #define NEED_vload_module
184 i = eval_sv(sv, flags);
187 PUSHs(sv_2mortal(newSViv(i)));
190 eval_pv(p, croak_on_error)
196 PUSHs(eval_pv(p, croak_on_error));
199 call_sv(sv, flags, ...)
205 for (i=0; i<items-2; i++)
206 ST(i) = ST(i+2); /* pop first two args */
210 i = call_sv(sv, flags);
213 PUSHs(sv_2mortal(newSViv(i)));
216 call_pv(subname, flags, ...)
222 for (i=0; i<items-2; i++)
223 ST(i) = ST(i+2); /* pop first two args */
227 i = call_pv(subname, flags);
230 PUSHs(sv_2mortal(newSViv(i)));
233 call_argv(subname, flags, ...)
240 if (items > 8) /* play safe */
242 for (i=2; i<items; i++)
243 args[i-2] = SvPV_nolen(ST(i));
244 args[items-2] = NULL;
246 i = call_argv(subname, flags, args);
249 PUSHs(sv_2mortal(newSViv(i)));
252 call_method(methname, flags, ...)
258 for (i=0; i<items-2; i++)
259 ST(i) = ST(i+2); /* pop first two args */
263 i = call_method(methname, flags);
266 PUSHs(sv_2mortal(newSViv(i)));
269 load_module(flags, name, version, ...)
274 /* Both SV parameters are donated to the ops built inside
275 load_module, so we need to bump the refcounts. */
276 Perl_load_module(aTHX_ flags, SvREFCNT_inc_simple(name),
277 SvREFCNT_inc_simple(version), NULL);
284 join(':', @$a) eq join(':', @$b);
292 @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z';
295 my $obj = bless [], 'Foo';
299 return 'bad_self' unless @_ && ref $_[0] && ref($_[0]) eq 'Foo';
304 @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z';
310 # flags args expected description
311 [ &Devel::PPPort::G_SCALAR, [ ], [ qw(y 1) ], '0 args, G_SCALAR' ],
312 [ &Devel::PPPort::G_SCALAR, [ qw(a p q) ], [ qw(y 1) ], '3 args, G_SCALAR' ],
313 [ &Devel::PPPort::G_ARRAY, [ ], [ qw(x 1) ], '0 args, G_ARRAY' ],
314 [ &Devel::PPPort::G_ARRAY, [ qw(a p q) ], [ qw(b p x 3) ], '3 args, G_ARRAY' ],
315 [ &Devel::PPPort::G_DISCARD, [ ], [ qw(0) ], '0 args, G_DISCARD' ],
316 [ &Devel::PPPort::G_DISCARD, [ qw(a p q) ], [ qw(0) ], '3 args, G_DISCARD' ],
319 my ($flags, $args, $expected, $description) = @$test;
320 print "# --- $description ---\n";
321 ok(eq_array( [ &Devel::PPPort::call_sv(\&f, $flags, @$args) ], $expected));
322 ok(eq_array( [ &Devel::PPPort::call_sv(*f, $flags, @$args) ], $expected));
323 ok(eq_array( [ &Devel::PPPort::call_sv('f', $flags, @$args) ], $expected));
324 ok(eq_array( [ &Devel::PPPort::call_pv('f', $flags, @$args) ], $expected));
325 ok(eq_array( [ &Devel::PPPort::call_argv('f', $flags, @$args) ], $expected));
326 ok(eq_array( [ &Devel::PPPort::eval_sv("f(qw(@$args))", $flags) ], $expected));
327 ok(eq_array( [ &Devel::PPPort::call_method('meth', $flags, $obj, @$args) ], $expected));
330 ok(&Devel::PPPort::eval_pv('f()', 0), 'y');
331 ok(&Devel::PPPort::eval_pv('f(qw(a b c))', 0), 'y');
333 ok(!defined $::{'less::'}, 1, "Hadn't loaded less yet");
334 Devel::PPPort::load_module(0, "less", undef);
335 ok(defined $::{'less::'}, 1, "Have now loaded less");