ext/Devel/PPPort/parts/inc/sv_xpvf

   1 ################################################################################
   2 ##
   3 ##  $Revision: 2 $
   4 ##  $Author: mhx $
   5 ##  $Date: 2004/08/17 20:02:25 +0200 $
   6 ##
   7 ################################################################################
   8 ##
   9 ##  Version 3.x, Copyright (C) 2004, 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 /* 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