ext/Devel-PPPort/parts/inc/sv_xpvf

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