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