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