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