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(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
  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 is(&Devel::PPPort::vnewSVpvf(), ivers($]) >= ivers("5.004") ? 'Perl-42' : '%s-%d');
 287 is(&Devel::PPPort::sv_vcatpvf('1-2-3-'), ivers($]) >= ivers("5.004") ? '1-2-3-Perl-42' : '1-2-3-%s-%d');
 288 is(&Devel::PPPort::sv_vsetpvf('1-2-3-'), ivers($]) >= ivers("5.004") ? 'Perl-42' : '%s-%d');
 289
 290 &Devel::PPPort::sv_catpvf_mg($h{foo});
 291 is($h{foo}, ivers($]) >= ivers("5.004") ? 'foo-Perl-42' : 'foo-');
 292
 293 &Devel::PPPort::Perl_sv_catpvf_mg($h{foo});
 294 is($h{foo}, ivers($]) >= ivers("5.004") ? 'foo-Perl-42-Perl-43' : 'foo-');
 295
 296 &Devel::PPPort::sv_catpvf_mg_nocontext($h{foo});
 297 is($h{foo}, ivers($]) >= ivers("5.004") ? 'foo-Perl-42-Perl-43-Perl-44' : 'foo-');
 298
 299 &Devel::PPPort::sv_setpvf_mg($h{bar});
 300 is($h{bar}, ivers($]) >= ivers("5.004") ? 'mhx-42' : '');
 301
 302 &Devel::PPPort::Perl_sv_setpvf_mg($h{bar});
 303 is($h{bar}, ivers($]) >= ivers("5.004") ? 'foo-43' : '');
 304
 305 &Devel::PPPort::sv_setpvf_mg_nocontext($h{bar});
 306 is($h{bar}, ivers($]) >= ivers("5.004") ? 'bar-44' : '');