This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Move CHECK_WORD in regcomp.c to a more generic memEQs() in handy.h
[perl5.git] / ext / Devel / PPPort / parts / inc / call
CommitLineData
adfe19db
MHM		 1################################################################################
2##
d2dacc4f 3## $Revision: 10 $
adfe19db 4## $Author: mhx $
d2dacc4f 5## $Date: 2007/01/02 12:32:32 +0100 $
adfe19db
MHM		 6##
7################################################################################
8##
d2dacc4f 9## Version 3.x, Copyright (C) 2004-2007, Marcus Holland-Moritz.
adfe19db
MHM		 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
20eval_pv
21eval_sv
22call_sv
23call_pv
24call_argv
25call_method
26
27=implementation
28
29/* Replace: 1 */
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
34
35__UNDEFINED__ eval_sv perl_eval_sv
36/* Replace: 0 */
37
38/* Replace perl_eval_pv with eval_pv */
39/* eval_pv depends on eval_sv */
40
41#ifndef eval_pv
42#if { NEED eval_pv }
43
44SV*
45eval_pv(char *p, I32 croak_on_error)
46{
47 dSP;
48 SV* sv = newSVpv(p, 0);
49
50 PUSHMARK(sp);
51 eval_sv(sv, G_SCALAR);
52 SvREFCNT_dec(sv);
53
54 SPAGAIN;
55 sv = POPs;
56 PUTBACK;
57
58 if (croak_on_error && SvTRUE(GvSV(errgv)))
59 croak(SvPVx(GvSV(errgv), na));
60
61 return sv;
62}
63
64#endif
65#endif
66
67=xsinit
68
69#define NEED_eval_pv
70
71=xsubs
72
73I32
74G_SCALAR()
75 CODE:
76 RETVAL = G_SCALAR;
77 OUTPUT:
78 RETVAL
79
80I32
81G_ARRAY()
82 CODE:
83 RETVAL = G_ARRAY;
84 OUTPUT:
85 RETVAL
86
87I32
88G_DISCARD()
89 CODE:
90 RETVAL = G_DISCARD;
91 OUTPUT:
92 RETVAL
93
94void
95eval_sv(sv, flags)
96 SV* sv
97 I32 flags
98 PREINIT:
99 I32 i;
100 PPCODE:
101 PUTBACK;
102 i = eval_sv(sv, flags);
103 SPAGAIN;
104 EXTEND(SP, 1);
105 PUSHs(sv_2mortal(newSViv(i)));
106
107void
108eval_pv(p, croak_on_error)
109 char* p
110 I32 croak_on_error
111 PPCODE:
112 PUTBACK;
113 EXTEND(SP, 1);
114 PUSHs(eval_pv(p, croak_on_error));
115
116void
117call_sv(sv, flags, ...)
118 SV* sv
119 I32 flags
120 PREINIT:
121 I32 i;
122 PPCODE:
123 for (i=0; i<items-2; i++)
124 ST(i) = ST(i+2); /* pop first two args */
125 PUSHMARK(SP);
126 SP += items - 2;
127 PUTBACK;
128 i = call_sv(sv, flags);
129 SPAGAIN;
130 EXTEND(SP, 1);
131 PUSHs(sv_2mortal(newSViv(i)));
132
133void
134call_pv(subname, flags, ...)
135 char* subname
136 I32 flags
137 PREINIT:
138 I32 i;
139 PPCODE:
140 for (i=0; i<items-2; i++)
141 ST(i) = ST(i+2); /* pop first two args */
142 PUSHMARK(SP);
143 SP += items - 2;
144 PUTBACK;
145 i = call_pv(subname, flags);
146 SPAGAIN;
147 EXTEND(SP, 1);
148 PUSHs(sv_2mortal(newSViv(i)));
149
150void
151call_argv(subname, flags, ...)
152 char* subname
153 I32 flags
154 PREINIT:
155 I32 i;
156 char *args[8];
157 PPCODE:
158 if (items > 8) /* play safe */
159 XSRETURN_UNDEF;
160 for (i=2; i<items; i++)
161 args[i-2] = SvPV_nolen(ST(i));
162 args[items-2] = NULL;
163 PUTBACK;
164 i = call_argv(subname, flags, args);
165 SPAGAIN;
166 EXTEND(SP, 1);
167 PUSHs(sv_2mortal(newSViv(i)));
168
169void
170call_method(methname, flags, ...)
171 char* methname
172 I32 flags
173 PREINIT:
174 I32 i;
175 PPCODE:
176 for (i=0; i<items-2; i++)
177 ST(i) = ST(i+2); /* pop first two args */
178 PUSHMARK(SP);
179 SP += items - 2;
180 PUTBACK;
181 i = call_method(methname, flags);
182 SPAGAIN;
183 EXTEND(SP, 1);
184 PUSHs(sv_2mortal(newSViv(i)));
185
186=tests plan => 44
187
188sub eq_array
189{
190 my($a, $b) = @_;
191 join(':', @$a) eq join(':', @$b);
192}
193
194sub f
195{
196 shift;
197 unshift @_, 'b';
198 pop @_;
199 @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z';
200}
201
202my $obj = bless [], 'Foo';
203
204sub Foo::meth
205{
206 return 'bad_self' unless @_ && ref $_[0] && ref($_[0]) eq 'Foo';
207 shift;
208 shift;
209 unshift @_, 'b';
210 pop @_;
211 @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z';
212}
213
214my $test;
215
216for $test (
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' ],
224)
225{
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));
235};
236
237ok(&Devel::PPPort::eval_pv('f()', 0), 'y');
238ok(&Devel::PPPort::eval_pv('f(qw(a b c))', 0), 'y');
239
Unnamed repository; edit this file 'description' to name the repository.