This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
126ed2e7ff92f234cd550fd283a8fdd48dbcdd42
[perl5.git] / dist / Devel-PPPort / parts / inc / call
1 ################################################################################
2 ##
3 ##  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
4 ##  Version 2.x, Copyright (C) 2001, Paul Marquess.
5 ##  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
6 ##
7 ##  This program is free software; you can redistribute it and/or
8 ##  modify it under the same terms as Perl itself.
9 ##
10 ################################################################################
11
12 =provides
13
14 eval_pv
15 eval_sv
16 call_sv
17 call_pv
18 call_argv
19 call_method
20 load_module
21 vload_module
22 G_METHOD
23
24 =implementation
25
26 /* Replace: 1 */
27 __UNDEFINED__  call_sv       perl_call_sv
28 __UNDEFINED__  call_pv       perl_call_pv
29 __UNDEFINED__  call_argv     perl_call_argv
30 __UNDEFINED__  call_method   perl_call_method
31
32 __UNDEFINED__  eval_sv       perl_eval_sv
33 /* Replace: 0 */
34
35 __UNDEFINED__ PERL_LOADMOD_DENY         0x1
36 __UNDEFINED__ PERL_LOADMOD_NOIMPORT     0x2
37 __UNDEFINED__ PERL_LOADMOD_IMPORT_OPS   0x4
38
39 #ifndef G_METHOD
40 # define G_METHOD               64
41 # ifdef call_sv
42 #  undef call_sv
43 # endif
44 # if { VERSION < 5.6.0 }
45 #  define call_sv(sv, flags)  ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \
46                                 (flags) & ~G_METHOD) : perl_call_sv(sv, flags))
47 # else
48 #  define call_sv(sv, flags)  ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \
49                                 (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags))
50 # endif
51 #endif
52
53 /* Replace perl_eval_pv with eval_pv */
54
55 #ifndef eval_pv
56 #if { NEED eval_pv }
57
58 SV*
59 eval_pv(char *p, I32 croak_on_error)
60 {
61     dSP;
62     SV* errsv;
63     SV* sv = newSVpv(p, 0);
64
65     PUSHMARK(sp);
66     eval_sv(sv, G_SCALAR);
67     SvREFCNT_dec(sv);
68
69     SPAGAIN;
70     sv = POPs;
71     PUTBACK;
72
73     if (croak_on_error) {
74         errsv = ERRSV;
75         if (SvTRUE(errsv))
76             croak_sv(errsv);
77     }
78
79     return sv;
80 }
81
82 #endif
83 #endif
84
85 #ifndef vload_module
86 #if { NEED vload_module }
87
88 void
89 vload_module(U32 flags, SV *name, SV *ver, va_list *args)
90 {
91     dTHR;
92     dVAR;
93     OP *veop, *imop;
94
95     OP * const modname = newSVOP(OP_CONST, 0, name);
96     /* 5.005 has a somewhat hacky force_normal that doesn't croak on
97        SvREADONLY() if PL_compling is true. Current perls take care in
98        ck_require() to correctly turn off SvREADONLY before calling
99        force_normal_flags(). This seems a better fix than fudging PL_compling
100      */
101     SvREADONLY_off(((SVOP*)modname)->op_sv);
102     modname->op_private |= OPpCONST_BARE;
103     if (ver) {
104         veop = newSVOP(OP_CONST, 0, ver);
105     }
106     else
107         veop = NULL;
108     if (flags & PERL_LOADMOD_NOIMPORT) {
109         imop = sawparens(newNULLLIST());
110     }
111     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
112         imop = va_arg(*args, OP*);
113     }
114     else {
115         SV *sv;
116         imop = NULL;
117         sv = va_arg(*args, SV*);
118         while (sv) {
119             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
120             sv = va_arg(*args, SV*);
121         }
122     }
123     {
124         const line_t ocopline = PL_copline;
125         COP * const ocurcop = PL_curcop;
126         const int oexpect = PL_expect;
127
128 #if { VERSION >= 5.004 }
129         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
130                 veop, modname, imop);
131 #elif { VERSION > 5.003 }
132         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(),
133                 veop, modname, imop);
134 #else
135         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(),
136                 modname, imop);
137 #endif
138         PL_expect = oexpect;
139         PL_copline = ocopline;
140         PL_curcop = ocurcop;
141     }
142 }
143
144 #endif
145 #endif
146
147 #ifndef load_module
148 #if { NEED load_module }
149
150 void
151 load_module(U32 flags, SV *name, SV *ver, ...)
152 {
153     va_list args;
154     va_start(args, ver);
155     vload_module(flags, name, ver, &args);
156     va_end(args);
157 }
158
159 #endif
160 #endif
161
162 =xsinit
163
164 #define NEED_eval_pv
165 #define NEED_load_module
166 #define NEED_vload_module
167
168 =xsubs
169
170 I32
171 G_SCALAR()
172         CODE:
173                 RETVAL = G_SCALAR;
174         OUTPUT:
175                 RETVAL
176
177 I32
178 G_ARRAY()
179         CODE:
180                 RETVAL = G_ARRAY;
181         OUTPUT:
182                 RETVAL
183
184 I32
185 G_DISCARD()
186         CODE:
187                 RETVAL = G_DISCARD;
188         OUTPUT:
189                 RETVAL
190
191 void
192 eval_sv(sv, flags)
193         SV* sv
194         I32 flags
195         PREINIT:
196                 I32 i;
197         PPCODE:
198                 PUTBACK;
199                 i = eval_sv(sv, flags);
200                 SPAGAIN;
201                 EXTEND(SP, 1);
202                 mPUSHi(i);
203
204 void
205 eval_pv(p, croak_on_error)
206         char* p
207         I32 croak_on_error
208         PPCODE:
209                 PUTBACK;
210                 EXTEND(SP, 1);
211                 PUSHs(eval_pv(p, croak_on_error));
212
213 void
214 call_sv(sv, flags, ...)
215         SV* sv
216         I32 flags
217         PREINIT:
218                 I32 i;
219         PPCODE:
220                 for (i=0; i<items-2; i++)
221                   ST(i) = ST(i+2); /* pop first two args */
222                 PUSHMARK(SP);
223                 SP += items - 2;
224                 PUTBACK;
225                 i = call_sv(sv, flags);
226                 SPAGAIN;
227                 EXTEND(SP, 1);
228                 mPUSHi(i);
229
230 void
231 call_pv(subname, flags, ...)
232         char* subname
233         I32 flags
234         PREINIT:
235                 I32 i;
236         PPCODE:
237                 for (i=0; i<items-2; i++)
238                   ST(i) = ST(i+2); /* pop first two args */
239                 PUSHMARK(SP);
240                 SP += items - 2;
241                 PUTBACK;
242                 i = call_pv(subname, flags);
243                 SPAGAIN;
244                 EXTEND(SP, 1);
245                 mPUSHi(i);
246
247 void
248 call_argv(subname, flags, ...)
249         char* subname
250         I32 flags
251         PREINIT:
252                 I32 i;
253                 char *args[8];
254         PPCODE:
255                 if (items > 8)  /* play safe */
256                   XSRETURN_UNDEF;
257                 for (i=2; i<items; i++)
258                   args[i-2] = SvPV_nolen(ST(i));
259                 args[items-2] = NULL;
260                 PUTBACK;
261                 i = call_argv(subname, flags, args);
262                 SPAGAIN;
263                 EXTEND(SP, 1);
264                 mPUSHi(i);
265
266 void
267 call_method(methname, flags, ...)
268         char* methname
269         I32 flags
270         PREINIT:
271                 I32 i;
272         PPCODE:
273                 for (i=0; i<items-2; i++)
274                   ST(i) = ST(i+2); /* pop first two args */
275                 PUSHMARK(SP);
276                 SP += items - 2;
277                 PUTBACK;
278                 i = call_method(methname, flags);
279                 SPAGAIN;
280                 EXTEND(SP, 1);
281                 mPUSHi(i);
282
283 void
284 call_sv_G_METHOD(sv, flags, ...)
285         SV* sv
286         I32 flags
287         PREINIT:
288                 I32 i;
289         PPCODE:
290                 for (i=0; i<items-2; i++)
291                   ST(i) = ST(i+2); /* pop first two args */
292                 PUSHMARK(SP);
293                 SP += items - 2;
294                 PUTBACK;
295                 i = call_sv(sv, flags | G_METHOD);
296                 SPAGAIN;
297                 EXTEND(SP, 1);
298                 mPUSHi(i);
299
300 void
301 load_module(flags, name, version, ...)
302         U32 flags
303         SV *name
304         SV *version
305         CODE:
306                 /* Both SV parameters are donated to the ops built inside
307                    load_module, so we need to bump the refcounts.  */
308                 Perl_load_module(aTHX_ flags, SvREFCNT_inc_simple(name),
309                                  SvREFCNT_inc_simple(version), NULL);
310
311 =tests plan => 52
312
313 sub eq_array
314 {
315   my($a, $b) = @_;
316   join(':', @$a) eq join(':', @$b);
317 }
318
319 sub f
320 {
321   shift;
322   unshift @_, 'b';
323   pop @_;
324   @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z';
325 }
326
327 my $obj = bless [], 'Foo';
328
329 sub Foo::meth
330 {
331   return 'bad_self' unless @_ && ref $_[0] && ref($_[0]) eq 'Foo';
332   shift;
333   shift;
334   unshift @_, 'b';
335   pop @_;
336   @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z';
337 }
338
339 my $test;
340
341 for $test (
342     # flags                      args           expected         description
343     [ &Devel::PPPort::G_SCALAR,  [ ],           [ qw(y 1) ],     '0 args, G_SCALAR'  ],
344     [ &Devel::PPPort::G_SCALAR,  [ qw(a p q) ], [ qw(y 1) ],     '3 args, G_SCALAR'  ],
345     [ &Devel::PPPort::G_ARRAY,   [ ],           [ qw(x 1) ],     '0 args, G_ARRAY'   ],
346     [ &Devel::PPPort::G_ARRAY,   [ qw(a p q) ], [ qw(b p x 3) ], '3 args, G_ARRAY'   ],
347     [ &Devel::PPPort::G_DISCARD, [ ],           [ qw(0) ],       '0 args, G_DISCARD' ],
348     [ &Devel::PPPort::G_DISCARD, [ qw(a p q) ], [ qw(0) ],       '3 args, G_DISCARD' ],
349 )
350 {
351     my ($flags, $args, $expected, $description) = @$test;
352     print "# --- $description ---\n";
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_sv('f', $flags, @$args) ], $expected));
356     ok(eq_array( [ &Devel::PPPort::call_pv('f', $flags, @$args) ], $expected));
357     ok(eq_array( [ &Devel::PPPort::call_argv('f', $flags, @$args) ], $expected));
358     ok(eq_array( [ &Devel::PPPort::eval_sv("f(qw(@$args))", $flags) ], $expected));
359     ok(eq_array( [ &Devel::PPPort::call_method('meth', $flags, $obj, @$args) ], $expected));
360     ok(eq_array( [ &Devel::PPPort::call_sv_G_METHOD('meth', $flags, $obj, @$args) ], $expected));
361 };
362
363 ok(&Devel::PPPort::eval_pv('f()', 0), 'y');
364 ok(&Devel::PPPort::eval_pv('f(qw(a b c))', 0), 'y');
365
366 ok(!defined $::{'less::'}, 1, "Hadn't loaded less yet");
367 Devel::PPPort::load_module(0, "less", undef);
368 ok(defined $::{'less::'}, 1, "Have now loaded less");