Commit | Line | Data |
96ad942f |
1 | ################################################################################ |
2 | ## |
bfc37ff7 |
3 | ## $Revision: 11 $ |
96ad942f |
4 | ## $Author: mhx $ |
bfc37ff7 |
5 | ## $Date: 2010/03/07 13:15:46 +0100 $ |
96ad942f |
6 | ## |
7 | ################################################################################ |
8 | ## |
bfc37ff7 |
9 | ## Version 3.x, Copyright (C) 2004-2010, Marcus Holland-Moritz. |
96ad942f |
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 | vnewSVpvf |
21 | sv_vcatpvf |
22 | sv_vsetpvf |
23 | |
24 | sv_catpvf_mg |
25 | sv_catpvf_mg_nocontext |
26 | sv_vcatpvf_mg |
27 | |
28 | sv_setpvf_mg |
29 | sv_setpvf_mg_nocontext |
30 | sv_vsetpvf_mg |
31 | |
32 | =implementation |
33 | |
34 | #if { VERSION >= 5.004 } && !defined(vnewSVpvf) |
35 | #if { NEED vnewSVpvf } |
36 | |
37 | SV * |
38 | vnewSVpvf(pTHX_ const char *pat, va_list *args) |
39 | { |
40 | register SV *sv = newSV(0); |
41 | sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); |
42 | return sv; |
43 | } |
44 | |
45 | #endif |
46 | #endif |
47 | |
96ad942f |
48 | #if { VERSION >= 5.004 } && !defined(sv_vcatpvf) |
49 | # define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) |
50 | #endif |
51 | |
96ad942f |
52 | #if { VERSION >= 5.004 } && !defined(sv_vsetpvf) |
53 | # define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) |
54 | #endif |
55 | |
96ad942f |
56 | #if { VERSION >= 5.004 } && !defined(sv_catpvf_mg) |
57 | #if { NEED sv_catpvf_mg } |
58 | |
59 | void |
60 | sv_catpvf_mg(pTHX_ SV *sv, const char *pat, ...) |
61 | { |
62 | va_list args; |
63 | va_start(args, pat); |
64 | sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); |
65 | SvSETMAGIC(sv); |
66 | va_end(args); |
67 | } |
68 | |
69 | #endif |
70 | #endif |
71 | |
96ad942f |
72 | #ifdef PERL_IMPLICIT_CONTEXT |
73 | #if { VERSION >= 5.004 } && !defined(sv_catpvf_mg_nocontext) |
74 | #if { NEED sv_catpvf_mg_nocontext } |
75 | |
76 | void |
77 | sv_catpvf_mg_nocontext(SV *sv, const char *pat, ...) |
78 | { |
79 | dTHX; |
80 | va_list args; |
81 | va_start(args, pat); |
82 | sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); |
83 | SvSETMAGIC(sv); |
84 | va_end(args); |
85 | } |
86 | |
87 | #endif |
88 | #endif |
89 | #endif |
90 | |
679ad62d |
91 | /* sv_catpvf_mg depends on sv_catpvf_mg_nocontext */ |
96ad942f |
92 | #ifndef sv_catpvf_mg |
93 | # ifdef PERL_IMPLICIT_CONTEXT |
94 | # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext |
95 | # else |
96 | # define sv_catpvf_mg Perl_sv_catpvf_mg |
97 | # endif |
98 | #endif |
99 | |
96ad942f |
100 | #if { VERSION >= 5.004 } && !defined(sv_vcatpvf_mg) |
101 | # define sv_vcatpvf_mg(sv, pat, args) \ |
102 | STMT_START { \ |
103 | sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ |
104 | SvSETMAGIC(sv); \ |
105 | } STMT_END |
106 | #endif |
107 | |
96ad942f |
108 | #if { VERSION >= 5.004 } && !defined(sv_setpvf_mg) |
109 | #if { NEED sv_setpvf_mg } |
110 | |
111 | void |
112 | sv_setpvf_mg(pTHX_ SV *sv, const char *pat, ...) |
113 | { |
114 | va_list args; |
115 | va_start(args, pat); |
116 | sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); |
117 | SvSETMAGIC(sv); |
118 | va_end(args); |
119 | } |
120 | |
121 | #endif |
122 | #endif |
123 | |
96ad942f |
124 | #ifdef PERL_IMPLICIT_CONTEXT |
125 | #if { VERSION >= 5.004 } && !defined(sv_setpvf_mg_nocontext) |
126 | #if { NEED sv_setpvf_mg_nocontext } |
127 | |
128 | void |
129 | sv_setpvf_mg_nocontext(SV *sv, const char *pat, ...) |
130 | { |
131 | dTHX; |
132 | va_list args; |
133 | va_start(args, pat); |
134 | sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); |
135 | SvSETMAGIC(sv); |
136 | va_end(args); |
137 | } |
138 | |
139 | #endif |
140 | #endif |
141 | #endif |
142 | |
679ad62d |
143 | /* sv_setpvf_mg depends on sv_setpvf_mg_nocontext */ |
96ad942f |
144 | #ifndef sv_setpvf_mg |
145 | # ifdef PERL_IMPLICIT_CONTEXT |
146 | # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext |
147 | # else |
148 | # define sv_setpvf_mg Perl_sv_setpvf_mg |
149 | # endif |
150 | #endif |
151 | |
96ad942f |
152 | #if { VERSION >= 5.004 } && !defined(sv_vsetpvf_mg) |
153 | # define sv_vsetpvf_mg(sv, pat, args) \ |
154 | STMT_START { \ |
155 | sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ |
156 | SvSETMAGIC(sv); \ |
157 | } STMT_END |
158 | #endif |
159 | |
160 | =xsinit |
161 | |
162 | #define NEED_vnewSVpvf |
163 | #define NEED_sv_catpvf_mg |
164 | #define NEED_sv_catpvf_mg_nocontext |
165 | #define NEED_sv_setpvf_mg |
166 | #define NEED_sv_setpvf_mg_nocontext |
167 | |
168 | =xsmisc |
169 | |
170 | static SV * test_vnewSVpvf(pTHX_ const char *pat, ...) |
171 | { |
172 | SV *sv; |
173 | va_list args; |
174 | va_start(args, pat); |
175 | #if { VERSION >= 5.004 } |
176 | sv = vnewSVpvf(pat, &args); |
177 | #else |
aab9a3b6 |
178 | sv = newSVpv((char *) pat, 0); |
96ad942f |
179 | #endif |
180 | va_end(args); |
181 | return sv; |
182 | } |
183 | |
184 | static void test_sv_vcatpvf(pTHX_ SV *sv, const char *pat, ...) |
185 | { |
186 | va_list args; |
187 | va_start(args, pat); |
188 | #if { VERSION >= 5.004 } |
189 | sv_vcatpvf(sv, pat, &args); |
190 | #else |
aab9a3b6 |
191 | sv_catpv(sv, (char *) pat); |
96ad942f |
192 | #endif |
193 | va_end(args); |
194 | } |
195 | |
196 | static void test_sv_vsetpvf(pTHX_ SV *sv, const char *pat, ...) |
197 | { |
198 | va_list args; |
199 | va_start(args, pat); |
200 | #if { VERSION >= 5.004 } |
201 | sv_vsetpvf(sv, pat, &args); |
202 | #else |
aab9a3b6 |
203 | sv_setpv(sv, (char *) pat); |
96ad942f |
204 | #endif |
205 | va_end(args); |
206 | } |
207 | |
208 | =xsubs |
209 | |
210 | SV * |
211 | vnewSVpvf() |
212 | CODE: |
213 | RETVAL = test_vnewSVpvf(aTHX_ "%s-%d", "Perl", 42); |
214 | OUTPUT: |
215 | RETVAL |
216 | |
217 | SV * |
218 | sv_vcatpvf(sv) |
219 | SV *sv |
220 | CODE: |
221 | RETVAL = newSVsv(sv); |
222 | test_sv_vcatpvf(aTHX_ RETVAL, "%s-%d", "Perl", 42); |
223 | OUTPUT: |
224 | RETVAL |
225 | |
226 | SV * |
227 | sv_vsetpvf(sv) |
228 | SV *sv |
229 | CODE: |
230 | RETVAL = newSVsv(sv); |
231 | test_sv_vsetpvf(aTHX_ RETVAL, "%s-%d", "Perl", 42); |
232 | OUTPUT: |
233 | RETVAL |
234 | |
235 | void |
236 | sv_catpvf_mg(sv) |
237 | SV *sv |
238 | CODE: |
239 | #if { VERSION >= 5.004 } |
240 | sv_catpvf_mg(sv, "%s-%d", "Perl", 42); |
241 | #endif |
242 | |
243 | void |
244 | Perl_sv_catpvf_mg(sv) |
245 | SV *sv |
246 | CODE: |
247 | #if { VERSION >= 5.004 } |
248 | Perl_sv_catpvf_mg(aTHX_ sv, "%s-%d", "-Perl", 43); |
249 | #endif |
250 | |
251 | void |
252 | sv_catpvf_mg_nocontext(sv) |
253 | SV *sv |
254 | CODE: |
255 | #if { VERSION >= 5.004 } |
256 | #ifdef PERL_IMPLICIT_CONTEXT |
257 | sv_catpvf_mg_nocontext(sv, "%s-%d", "-Perl", 44); |
258 | #else |
259 | sv_catpvf_mg(sv, "%s-%d", "-Perl", 44); |
260 | #endif |
261 | #endif |
262 | |
263 | void |
264 | sv_setpvf_mg(sv) |
265 | SV *sv |
266 | CODE: |
267 | #if { VERSION >= 5.004 } |
268 | sv_setpvf_mg(sv, "%s-%d", "mhx", 42); |
269 | #endif |
270 | |
271 | void |
272 | Perl_sv_setpvf_mg(sv) |
273 | SV *sv |
274 | CODE: |
275 | #if { VERSION >= 5.004 } |
276 | Perl_sv_setpvf_mg(aTHX_ sv, "%s-%d", "foo", 43); |
277 | #endif |
278 | |
279 | void |
280 | sv_setpvf_mg_nocontext(sv) |
281 | SV *sv |
282 | CODE: |
283 | #if { VERSION >= 5.004 } |
284 | #ifdef PERL_IMPLICIT_CONTEXT |
285 | sv_setpvf_mg_nocontext(sv, "%s-%d", "bar", 44); |
286 | #else |
287 | sv_setpvf_mg(sv, "%s-%d", "bar", 44); |
288 | #endif |
289 | #endif |
290 | |
291 | =tests plan => 9 |
292 | |
293 | use Tie::Hash; |
294 | my %h; |
295 | tie %h, 'Tie::StdHash'; |
296 | $h{foo} = 'foo-'; |
297 | $h{bar} = ''; |
298 | |
299 | ok(&Devel::PPPort::vnewSVpvf(), $] >= 5.004 ? 'Perl-42' : '%s-%d'); |
300 | ok(&Devel::PPPort::sv_vcatpvf('1-2-3-'), $] >= 5.004 ? '1-2-3-Perl-42' : '1-2-3-%s-%d'); |
301 | ok(&Devel::PPPort::sv_vsetpvf('1-2-3-'), $] >= 5.004 ? 'Perl-42' : '%s-%d'); |
302 | |
303 | &Devel::PPPort::sv_catpvf_mg($h{foo}); |
304 | ok($h{foo}, $] >= 5.004 ? 'foo-Perl-42' : 'foo-'); |
305 | |
306 | &Devel::PPPort::Perl_sv_catpvf_mg($h{foo}); |
307 | ok($h{foo}, $] >= 5.004 ? 'foo-Perl-42-Perl-43' : 'foo-'); |
308 | |
309 | &Devel::PPPort::sv_catpvf_mg_nocontext($h{foo}); |
310 | ok($h{foo}, $] >= 5.004 ? 'foo-Perl-42-Perl-43-Perl-44' : 'foo-'); |
311 | |
312 | &Devel::PPPort::sv_setpvf_mg($h{bar}); |
313 | ok($h{bar}, $] >= 5.004 ? 'mhx-42' : ''); |
314 | |
315 | &Devel::PPPort::Perl_sv_setpvf_mg($h{bar}); |
316 | ok($h{bar}, $] >= 5.004 ? 'foo-43' : ''); |
317 | |
318 | &Devel::PPPort::sv_setpvf_mg_nocontext($h{bar}); |
319 | ok($h{bar}, $] >= 5.004 ? 'bar-44' : ''); |
320 | |
321 | |