This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
parts/inc/sv_xpvf: Adjust prototype to match blead
[perl5.git] / dist / Devel-PPPort / parts / inc / sv_xpvf
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
14 vnewSVpvf
15 sv_vcatpvf
16 sv_vsetpvf
17
18 sv_catpvf_mg
19 sv_catpvf_mg_nocontext
20 sv_vcatpvf_mg
21
22 sv_setpvf_mg
23 sv_setpvf_mg_nocontext
24 sv_vsetpvf_mg
25
26 =implementation
27
28 #if { VERSION >= 5.004 } && !defined(vnewSVpvf)
29 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
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
47 void
48 sv_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
64 void
65 sv_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
99 void
100 sv_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
116 void
117 sv_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
157 static 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
171 static 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
183 static 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
197 SV *
198 vnewSVpvf()
199         CODE:
200                 RETVAL = test_vnewSVpvf(aTHX_ "%s-%d", "Perl", 42);
201         OUTPUT:
202                 RETVAL
203
204 SV *
205 sv_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
213 SV *
214 sv_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
222 void
223 sv_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
230 void
231 Perl_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
238 void
239 sv_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
250 void
251 sv_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
258 void
259 Perl_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
266 void
267 sv_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
280 use Tie::Hash;
281 my %h;
282 tie %h, 'Tie::StdHash';
283 $h{foo} = 'foo-';
284 $h{bar} = '';
285
286 ok(&Devel::PPPort::vnewSVpvf(), "$]" >= 5.004 ? 'Perl-42' : '%s-%d');
287 ok(&Devel::PPPort::sv_vcatpvf('1-2-3-'), "$]" >= 5.004 ? '1-2-3-Perl-42' : '1-2-3-%s-%d');
288 ok(&Devel::PPPort::sv_vsetpvf('1-2-3-'), "$]" >= 5.004 ? 'Perl-42' : '%s-%d');
289
290 &Devel::PPPort::sv_catpvf_mg($h{foo});
291 ok($h{foo}, "$]" >= 5.004 ? 'foo-Perl-42' : 'foo-');
292
293 &Devel::PPPort::Perl_sv_catpvf_mg($h{foo});
294 ok($h{foo}, "$]" >= 5.004 ? 'foo-Perl-42-Perl-43' : 'foo-');
295
296 &Devel::PPPort::sv_catpvf_mg_nocontext($h{foo});
297 ok($h{foo}, "$]" >= 5.004 ? 'foo-Perl-42-Perl-43-Perl-44' : 'foo-');
298
299 &Devel::PPPort::sv_setpvf_mg($h{bar});
300 ok($h{bar}, "$]" >= 5.004 ? 'mhx-42' : '');
301
302 &Devel::PPPort::Perl_sv_setpvf_mg($h{bar});
303 ok($h{bar}, "$]" >= 5.004 ? 'foo-43' : '');
304
305 &Devel::PPPort::sv_setpvf_mg_nocontext($h{bar});
306 ok($h{bar}, "$]" >= 5.004 ? 'bar-44' : '');