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