| Commit | Line | Data |
|---|
| 96ad942f |
1 | ################################################################################ |
| 2 | ## |
| 0d0f8426 |
3 | ## $Revision: 4 $ |
| 96ad942f |
4 | ## $Author: mhx $ |
| 0d0f8426 |
5 | ## $Date: 2006/01/14 18:07:59 +0100 $ |
| 96ad942f |
6 | ## |
| 7 | ################################################################################ |
| 8 | ## |
| 0d0f8426 |
9 | ## Version 3.x, Copyright (C) 2004-2006, Marcus Holland-Moritz. |
| 96ad942f |
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 | |
| 20 | vnewSVpvf |
| 21 | sv_vcatpvf |
| 22 | sv_vsetpvf |
| 23 | |
| 24 | sv_catpvf_mg |
| 25 | sv_catpvf_mg_nocontext |
| 26 | sv_vcatpvf_mg |
| 27 | |
| 28 | sv_setpvf_mg |
| 29 | sv_setpvf_mg_nocontext |
| 30 | sv_vsetpvf_mg |
| 31 | |
| 32 | =implementation |
| 33 | |
| 34 | #if { VERSION >= 5.004 } && !defined(vnewSVpvf) |
| 35 | #if { NEED vnewSVpvf } |
| 36 | |
| 37 | SV * |
| 38 | vnewSVpvf(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 | |
| 62 | void |
| 63 | sv_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 | |
| 80 | void |
| 81 | sv_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 | |
| 116 | void |
| 117 | sv_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 | |
| 134 | void |
| 135 | sv_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 | |
| 176 | static 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 | |
| 190 | static 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 | |
| 202 | static 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 | |
| 216 | SV * |
| 217 | vnewSVpvf() |
| 218 | CODE: |
| 219 | RETVAL = test_vnewSVpvf(aTHX_ "%s-%d", "Perl", 42); |
| 220 | OUTPUT: |
| 221 | RETVAL |
| 222 | |
| 223 | SV * |
| 224 | sv_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 | |
| 232 | SV * |
| 233 | sv_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 | |
| 241 | void |
| 242 | sv_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 | |
| 249 | void |
| 250 | Perl_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 | |
| 257 | void |
| 258 | sv_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 | |
| 269 | void |
| 270 | sv_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 | |
| 277 | void |
| 278 | Perl_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 | |
| 285 | void |
| 286 | sv_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 | |
| 299 | use Tie::Hash; |
| 300 | my %h; |
| 301 | tie %h, 'Tie::StdHash'; |
| 302 | $h{foo} = 'foo-'; |
| 303 | $h{bar} = ''; |
| 304 | |
| 305 | ok(&Devel::PPPort::vnewSVpvf(), $] >= 5.004 ? 'Perl-42' : '%s-%d'); |
| 306 | ok(&Devel::PPPort::sv_vcatpvf('1-2-3-'), $] >= 5.004 ? '1-2-3-Perl-42' : '1-2-3-%s-%d'); |
| 307 | ok(&Devel::PPPort::sv_vsetpvf('1-2-3-'), $] >= 5.004 ? 'Perl-42' : '%s-%d'); |
| 308 | |
| 309 | &Devel::PPPort::sv_catpvf_mg($h{foo}); |
| 310 | ok($h{foo}, $] >= 5.004 ? 'foo-Perl-42' : 'foo-'); |
| 311 | |
| 312 | &Devel::PPPort::Perl_sv_catpvf_mg($h{foo}); |
| 313 | ok($h{foo}, $] >= 5.004 ? 'foo-Perl-42-Perl-43' : 'foo-'); |
| 314 | |
| 315 | &Devel::PPPort::sv_catpvf_mg_nocontext($h{foo}); |
| 316 | ok($h{foo}, $] >= 5.004 ? 'foo-Perl-42-Perl-43-Perl-44' : 'foo-'); |
| 317 | |
| 318 | &Devel::PPPort::sv_setpvf_mg($h{bar}); |
| 319 | ok($h{bar}, $] >= 5.004 ? 'mhx-42' : ''); |
| 320 | |
| 321 | &Devel::PPPort::Perl_sv_setpvf_mg($h{bar}); |
| 322 | ok($h{bar}, $] >= 5.004 ? 'foo-43' : ''); |
| 323 | |
| 324 | &Devel::PPPort::sv_setpvf_mg_nocontext($h{bar}); |
| 325 | ok($h{bar}, $] >= 5.004 ? 'bar-44' : ''); |
| 326 | |
| 327 | |
projects / p5sagit/p5-mst-13.2.git / blame