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