Commit | Line | Data |
adfe19db |
1 | ################################################################################ |
2 | ## |
0d0f8426 |
3 | ## $Revision: 9 $ |
adfe19db |
4 | ## $Author: mhx $ |
0d0f8426 |
5 | ## $Date: 2006/01/14 18:07:59 +0100 $ |
adfe19db |
6 | ## |
7 | ################################################################################ |
8 | ## |
0d0f8426 |
9 | ## Version 3.x, Copyright (C) 2004-2006, 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 |
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 | |
44 | SV* |
45 | eval_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 | |
73 | I32 |
74 | G_SCALAR() |
75 | CODE: |
76 | RETVAL = G_SCALAR; |
77 | OUTPUT: |
78 | RETVAL |
79 | |
80 | I32 |
81 | G_ARRAY() |
82 | CODE: |
83 | RETVAL = G_ARRAY; |
84 | OUTPUT: |
85 | RETVAL |
86 | |
87 | I32 |
88 | G_DISCARD() |
89 | CODE: |
90 | RETVAL = G_DISCARD; |
91 | OUTPUT: |
92 | RETVAL |
93 | |
94 | void |
95 | eval_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 | |
107 | void |
108 | eval_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 | |
116 | void |
117 | call_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 | |
133 | void |
134 | call_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 | |
150 | void |
151 | call_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 | |
169 | void |
170 | call_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 | |
188 | sub eq_array |
189 | { |
190 | my($a, $b) = @_; |
191 | join(':', @$a) eq join(':', @$b); |
192 | } |
193 | |
194 | sub f |
195 | { |
196 | shift; |
197 | unshift @_, 'b'; |
198 | pop @_; |
199 | @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z'; |
200 | } |
201 | |
202 | my $obj = bless [], 'Foo'; |
203 | |
204 | sub 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 | |
214 | my $test; |
215 | |
216 | for $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 | |
237 | ok(&Devel::PPPort::eval_pv('f()', 0), 'y'); |
238 | ok(&Devel::PPPort::eval_pv('f(qw(a b c))', 0), 'y'); |
239 | |