Commit | Line | Data |
adfe19db |
1 | ################################################################################ |
2 | ## |
c83e6f19 |
3 | ## $Revision: 15 $ |
adfe19db |
4 | ## $Author: mhx $ |
c83e6f19 |
5 | ## $Date: 2007/08/18 20:16:11 +0200 $ |
adfe19db |
6 | ## |
7 | ################################################################################ |
8 | ## |
d2dacc4f |
9 | ## Version 3.x, Copyright (C) 2004-2007, Marcus Holland-Moritz. |
adfe19db |
10 | ## Version 2.x, Copyright (C) 2001, Paul Marquess. |
11 | ## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. |
12 | ## |
13 | ## This program is free software; you can redistribute it and/or |
14 | ## modify it under the same terms as Perl itself. |
15 | ## |
16 | ################################################################################ |
17 | |
18 | =provides |
19 | |
20 | eval_pv |
21 | eval_sv |
22 | call_sv |
23 | call_pv |
24 | call_argv |
25 | call_method |
a89b7ab8 |
26 | load_module |
27 | vload_module |
adfe19db |
28 | |
29 | =implementation |
30 | |
31 | /* Replace: 1 */ |
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 |
36 | |
37 | __UNDEFINED__ eval_sv perl_eval_sv |
a89b7ab8 |
38 | |
39 | __UNDEFINED__ PERL_LOADMOD_DENY 0x1 |
40 | __UNDEFINED__ PERL_LOADMOD_NOIMPORT 0x2 |
41 | __UNDEFINED__ PERL_LOADMOD_IMPORT_OPS 0x4 |
42 | |
adfe19db |
43 | /* Replace: 0 */ |
44 | |
45 | /* Replace perl_eval_pv with eval_pv */ |
adfe19db |
46 | |
47 | #ifndef eval_pv |
48 | #if { NEED eval_pv } |
49 | |
50 | SV* |
51 | eval_pv(char *p, I32 croak_on_error) |
52 | { |
53 | dSP; |
54 | SV* sv = newSVpv(p, 0); |
55 | |
56 | PUSHMARK(sp); |
57 | eval_sv(sv, G_SCALAR); |
58 | SvREFCNT_dec(sv); |
59 | |
60 | SPAGAIN; |
61 | sv = POPs; |
62 | PUTBACK; |
63 | |
64 | if (croak_on_error && SvTRUE(GvSV(errgv))) |
65 | croak(SvPVx(GvSV(errgv), na)); |
66 | |
67 | return sv; |
68 | } |
69 | |
70 | #endif |
71 | #endif |
72 | |
a89b7ab8 |
73 | #ifndef vload_module |
74 | #if { NEED vload_module } |
75 | |
76 | void |
77 | vload_module(U32 flags, SV *name, SV *ver, va_list *args) |
78 | { |
79 | dTHR; |
80 | dVAR; |
81 | OP *veop, *imop; |
82 | |
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 |
88 | */ |
89 | SvREADONLY_off(((SVOP*)modname)->op_sv); |
90 | modname->op_private |= OPpCONST_BARE; |
91 | if (ver) { |
92 | veop = newSVOP(OP_CONST, 0, ver); |
93 | } |
94 | else |
95 | veop = NULL; |
96 | if (flags & PERL_LOADMOD_NOIMPORT) { |
97 | imop = sawparens(newNULLLIST()); |
98 | } |
99 | else if (flags & PERL_LOADMOD_IMPORT_OPS) { |
100 | imop = va_arg(*args, OP*); |
101 | } |
102 | else { |
103 | SV *sv; |
104 | imop = NULL; |
105 | sv = va_arg(*args, SV*); |
106 | while (sv) { |
107 | imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); |
108 | sv = va_arg(*args, SV*); |
109 | } |
110 | } |
111 | { |
112 | const line_t ocopline = PL_copline; |
113 | COP * const ocurcop = PL_curcop; |
114 | const int oexpect = PL_expect; |
115 | |
116 | #if { VERSION >= 5.004 } |
117 | utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), |
118 | veop, modname, imop); |
119 | #else |
120 | utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), |
121 | modname, imop); |
122 | #endif |
123 | PL_expect = oexpect; |
124 | PL_copline = ocopline; |
125 | PL_curcop = ocurcop; |
126 | } |
127 | } |
128 | |
129 | #endif |
130 | #endif |
131 | |
a89b7ab8 |
132 | #ifndef load_module |
133 | #if { NEED load_module } |
134 | |
135 | void |
136 | load_module(U32 flags, SV *name, SV *ver, ...) |
137 | { |
138 | va_list args; |
139 | va_start(args, ver); |
140 | vload_module(flags, name, ver, &args); |
141 | va_end(args); |
142 | } |
143 | |
144 | #endif |
145 | #endif |
146 | |
adfe19db |
147 | =xsinit |
148 | |
149 | #define NEED_eval_pv |
a89b7ab8 |
150 | #define NEED_load_module |
151 | #define NEED_vload_module |
adfe19db |
152 | |
153 | =xsubs |
154 | |
155 | I32 |
156 | G_SCALAR() |
157 | CODE: |
158 | RETVAL = G_SCALAR; |
159 | OUTPUT: |
160 | RETVAL |
161 | |
162 | I32 |
163 | G_ARRAY() |
164 | CODE: |
165 | RETVAL = G_ARRAY; |
166 | OUTPUT: |
167 | RETVAL |
168 | |
169 | I32 |
170 | G_DISCARD() |
171 | CODE: |
172 | RETVAL = G_DISCARD; |
173 | OUTPUT: |
174 | RETVAL |
175 | |
176 | void |
177 | eval_sv(sv, flags) |
178 | SV* sv |
179 | I32 flags |
180 | PREINIT: |
181 | I32 i; |
182 | PPCODE: |
183 | PUTBACK; |
184 | i = eval_sv(sv, flags); |
185 | SPAGAIN; |
186 | EXTEND(SP, 1); |
187 | PUSHs(sv_2mortal(newSViv(i))); |
188 | |
189 | void |
190 | eval_pv(p, croak_on_error) |
191 | char* p |
192 | I32 croak_on_error |
193 | PPCODE: |
194 | PUTBACK; |
195 | EXTEND(SP, 1); |
196 | PUSHs(eval_pv(p, croak_on_error)); |
197 | |
198 | void |
199 | call_sv(sv, flags, ...) |
200 | SV* sv |
201 | I32 flags |
202 | PREINIT: |
203 | I32 i; |
204 | PPCODE: |
205 | for (i=0; i<items-2; i++) |
206 | ST(i) = ST(i+2); /* pop first two args */ |
207 | PUSHMARK(SP); |
208 | SP += items - 2; |
209 | PUTBACK; |
210 | i = call_sv(sv, flags); |
211 | SPAGAIN; |
212 | EXTEND(SP, 1); |
213 | PUSHs(sv_2mortal(newSViv(i))); |
214 | |
215 | void |
216 | call_pv(subname, flags, ...) |
217 | char* subname |
218 | I32 flags |
219 | PREINIT: |
220 | I32 i; |
221 | PPCODE: |
222 | for (i=0; i<items-2; i++) |
223 | ST(i) = ST(i+2); /* pop first two args */ |
224 | PUSHMARK(SP); |
225 | SP += items - 2; |
226 | PUTBACK; |
227 | i = call_pv(subname, flags); |
228 | SPAGAIN; |
229 | EXTEND(SP, 1); |
230 | PUSHs(sv_2mortal(newSViv(i))); |
231 | |
232 | void |
233 | call_argv(subname, flags, ...) |
234 | char* subname |
235 | I32 flags |
236 | PREINIT: |
237 | I32 i; |
238 | char *args[8]; |
239 | PPCODE: |
240 | if (items > 8) /* play safe */ |
241 | XSRETURN_UNDEF; |
242 | for (i=2; i<items; i++) |
243 | args[i-2] = SvPV_nolen(ST(i)); |
244 | args[items-2] = NULL; |
245 | PUTBACK; |
246 | i = call_argv(subname, flags, args); |
247 | SPAGAIN; |
248 | EXTEND(SP, 1); |
249 | PUSHs(sv_2mortal(newSViv(i))); |
250 | |
251 | void |
252 | call_method(methname, flags, ...) |
253 | char* methname |
254 | I32 flags |
255 | PREINIT: |
256 | I32 i; |
257 | PPCODE: |
258 | for (i=0; i<items-2; i++) |
259 | ST(i) = ST(i+2); /* pop first two args */ |
260 | PUSHMARK(SP); |
261 | SP += items - 2; |
262 | PUTBACK; |
263 | i = call_method(methname, flags); |
264 | SPAGAIN; |
265 | EXTEND(SP, 1); |
266 | PUSHs(sv_2mortal(newSViv(i))); |
267 | |
a89b7ab8 |
268 | void |
269 | load_module(flags, name, version, ...) |
270 | U32 flags |
271 | SV *name |
272 | SV *version |
273 | CODE: |
274 | /* Both SV parameters are donated to the ops built inside |
275 | load_module, so we need to bump the refcounts. */ |
679ad62d |
276 | Perl_load_module(aTHX_ flags, SvREFCNT_inc_simple(name), |
277 | SvREFCNT_inc_simple(version), NULL); |
a89b7ab8 |
278 | |
279 | =tests plan => 46 |
adfe19db |
280 | |
281 | sub eq_array |
282 | { |
283 | my($a, $b) = @_; |
284 | join(':', @$a) eq join(':', @$b); |
285 | } |
286 | |
287 | sub f |
288 | { |
289 | shift; |
290 | unshift @_, 'b'; |
291 | pop @_; |
292 | @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z'; |
293 | } |
294 | |
295 | my $obj = bless [], 'Foo'; |
296 | |
297 | sub Foo::meth |
298 | { |
299 | return 'bad_self' unless @_ && ref $_[0] && ref($_[0]) eq 'Foo'; |
300 | shift; |
301 | shift; |
302 | unshift @_, 'b'; |
303 | pop @_; |
304 | @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z'; |
305 | } |
306 | |
307 | my $test; |
308 | |
309 | for $test ( |
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' ], |
317 | ) |
318 | { |
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)); |
328 | }; |
329 | |
330 | ok(&Devel::PPPort::eval_pv('f()', 0), 'y'); |
331 | ok(&Devel::PPPort::eval_pv('f(qw(a b c))', 0), 'y'); |
332 | |
a89b7ab8 |
333 | ok(!defined $::{'less::'}, 1, "Hadn't loaded less yet"); |
c83e6f19 |
334 | Devel::PPPort::load_module(0, "less", undef); |
a89b7ab8 |
335 | ok(defined $::{'less::'}, 1, "Have now loaded less"); |