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