1 ################################################################################
5 ## $Date: 2006/01/14 18:07:59 +0100 $
7 ################################################################################
9 ## Version 3.x, Copyright (C) 2004-2006, 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 ################################################################################
30 __UNDEFINED__ call_sv perl_call_sv
31 __UNDEFINED__ call_pv perl_call_pv
32 __UNDEFINED__ call_argv perl_call_argv
33 __UNDEFINED__ call_method perl_call_method
35 __UNDEFINED__ eval_sv perl_eval_sv
38 /* Replace perl_eval_pv with eval_pv */
39 /* eval_pv depends on eval_sv */
45 eval_pv(char *p, I32 croak_on_error)
48 SV* sv = newSVpv(p, 0);
51 eval_sv(sv, G_SCALAR);
58 if (croak_on_error && SvTRUE(GvSV(errgv)))
59 croak(SvPVx(GvSV(errgv), na));
102 i = eval_sv(sv, flags);
105 PUSHs(sv_2mortal(newSViv(i)));
108 eval_pv(p, croak_on_error)
114 PUSHs(eval_pv(p, croak_on_error));
117 call_sv(sv, flags, ...)
123 for (i=0; i<items-2; i++)
124 ST(i) = ST(i+2); /* pop first two args */
128 i = call_sv(sv, flags);
131 PUSHs(sv_2mortal(newSViv(i)));
134 call_pv(subname, flags, ...)
140 for (i=0; i<items-2; i++)
141 ST(i) = ST(i+2); /* pop first two args */
145 i = call_pv(subname, flags);
148 PUSHs(sv_2mortal(newSViv(i)));
151 call_argv(subname, flags, ...)
158 if (items > 8) /* play safe */
160 for (i=2; i<items; i++)
161 args[i-2] = SvPV_nolen(ST(i));
162 args[items-2] = NULL;
164 i = call_argv(subname, flags, args);
167 PUSHs(sv_2mortal(newSViv(i)));
170 call_method(methname, flags, ...)
176 for (i=0; i<items-2; i++)
177 ST(i) = ST(i+2); /* pop first two args */
181 i = call_method(methname, flags);
184 PUSHs(sv_2mortal(newSViv(i)));
191 join(':', @$a) eq join(':', @$b);
199 @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z';
202 my $obj = bless [], 'Foo';
206 return 'bad_self' unless @_ && ref $_[0] && ref($_[0]) eq 'Foo';
211 @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z';
217 # flags args expected description
218 [ &Devel::PPPort::G_SCALAR, [ ], [ qw(y 1) ], '0 args, G_SCALAR' ],
219 [ &Devel::PPPort::G_SCALAR, [ qw(a p q) ], [ qw(y 1) ], '3 args, G_SCALAR' ],
220 [ &Devel::PPPort::G_ARRAY, [ ], [ qw(x 1) ], '0 args, G_ARRAY' ],
221 [ &Devel::PPPort::G_ARRAY, [ qw(a p q) ], [ qw(b p x 3) ], '3 args, G_ARRAY' ],
222 [ &Devel::PPPort::G_DISCARD, [ ], [ qw(0) ], '0 args, G_DISCARD' ],
223 [ &Devel::PPPort::G_DISCARD, [ qw(a p q) ], [ qw(0) ], '3 args, G_DISCARD' ],
226 my ($flags, $args, $expected, $description) = @$test;
227 print "# --- $description ---\n";
228 ok(eq_array( [ &Devel::PPPort::call_sv(\&f, $flags, @$args) ], $expected));
229 ok(eq_array( [ &Devel::PPPort::call_sv(*f, $flags, @$args) ], $expected));
230 ok(eq_array( [ &Devel::PPPort::call_sv('f', $flags, @$args) ], $expected));
231 ok(eq_array( [ &Devel::PPPort::call_pv('f', $flags, @$args) ], $expected));
232 ok(eq_array( [ &Devel::PPPort::call_argv('f', $flags, @$args) ], $expected));
233 ok(eq_array( [ &Devel::PPPort::eval_sv("f(qw(@$args))", $flags) ], $expected));
234 ok(eq_array( [ &Devel::PPPort::call_method('meth', $flags, $obj, @$args) ], $expected));
237 ok(&Devel::PPPort::eval_pv('f()', 0), 'y');
238 ok(&Devel::PPPort::eval_pv('f(qw(a b c))', 0), 'y');