[perl5.git] / dist / Devel-PPPort / parts / inc / sv_xpvf

################################################################################
##
##  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
##  Version 2.x, Copyright (C) 2001, Paul Marquess.
##  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
##
##  This program is free software; you can redistribute it and/or
##  modify it under the same terms as Perl itself.
##
################################################################################

=provides

vnewSVpvf
sv_vcatpvf
sv_vsetpvf

sv_catpvf_mg
sv_catpvf_mg_nocontext
sv_vcatpvf_mg

sv_setpvf_mg
sv_setpvf_mg_nocontext
sv_vsetpvf_mg

=implementation

#if { VERSION >= 5.004 } && !defined(vnewSVpvf)
#if defined(PERL_USE_GCC_BRACE_GROUPS)
#  define vnewSVpvf(pat, args) ({ SV *_sv = newSV(0); sv_vsetpvfn(_sv, (pat), strlen((pat)), (args), Null(SV**), 0, Null(bool*)); _sv; })
#else
#  define vnewSVpvf(pat, args) ((PL_Sv = newSV(0)), sv_vsetpvfn(PL_Sv, (pat), strlen((pat)), (args), Null(SV**), 0, Null(bool*)), PL_Sv)
#endif
#endif

#if { VERSION >= 5.004 } && !defined(sv_vcatpvf)
#  define sv_vcatpvf(sv, pat, args)  sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*))
#endif

#if { VERSION >= 5.004 } && !defined(sv_vsetpvf)
#  define sv_vsetpvf(sv, pat, args)  sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*))
#endif

#if { VERSION >= 5.004 } && !defined(sv_catpvf_mg)
#if { NEED sv_catpvf_mg }

void
sv_catpvf_mg(pTHX_ SV * const sv, const char * const pat, ...)
{
  va_list args;
  va_start(args, pat);
  sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
  SvSETMAGIC(sv);
  va_end(args);
}

#endif
#endif

#ifdef PERL_IMPLICIT_CONTEXT
#if { VERSION >= 5.004 } && !defined(sv_catpvf_mg_nocontext)
#if { NEED sv_catpvf_mg_nocontext }

void
sv_catpvf_mg_nocontext(SV * const sv, const char * const pat, ...)
{
  dTHX;
  va_list args;
  va_start(args, pat);
  sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
  SvSETMAGIC(sv);
  va_end(args);
}

#endif
#endif
#endif

/* sv_catpvf_mg depends on sv_catpvf_mg_nocontext */
#ifndef sv_catpvf_mg
#  ifdef PERL_IMPLICIT_CONTEXT
#    define sv_catpvf_mg   Perl_sv_catpvf_mg_nocontext
#  else
#    define sv_catpvf_mg   Perl_sv_catpvf_mg
#  endif
#endif

#if { VERSION >= 5.004 } && !defined(sv_vcatpvf_mg)
#  define sv_vcatpvf_mg(sv, pat, args)                                     \
   STMT_START {                                                            \
     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));  \
     SvSETMAGIC(sv);                                                       \
   } STMT_END
#endif

#if { VERSION >= 5.004 } && !defined(sv_setpvf_mg)
#if { NEED sv_setpvf_mg }

void
sv_setpvf_mg(pTHX_ SV * const sv, const char * const pat, ...)
{
  va_list args;
  va_start(args, pat);
  sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
  SvSETMAGIC(sv);
  va_end(args);
}

#endif
#endif

#ifdef PERL_IMPLICIT_CONTEXT
#if { VERSION >= 5.004 } && !defined(sv_setpvf_mg_nocontext)
#if { NEED sv_setpvf_mg_nocontext }

void
sv_setpvf_mg_nocontext(SV * const sv, const char * const pat, ...)
{
  dTHX;
  va_list args;
  va_start(args, pat);
  sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
  SvSETMAGIC(sv);
  va_end(args);
}

#endif
#endif
#endif

/* sv_setpvf_mg depends on sv_setpvf_mg_nocontext */
#ifndef sv_setpvf_mg
#  ifdef PERL_IMPLICIT_CONTEXT
#    define sv_setpvf_mg   Perl_sv_setpvf_mg_nocontext
#  else
#    define sv_setpvf_mg   Perl_sv_setpvf_mg
#  endif
#endif

#if { VERSION >= 5.004 } && !defined(sv_vsetpvf_mg)
#  define sv_vsetpvf_mg(sv, pat, args)                                     \
   STMT_START {                                                            \
     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));  \
     SvSETMAGIC(sv);                                                       \
   } STMT_END
#endif

=xsinit

#define NEED_sv_catpvf_mg
#define NEED_sv_catpvf_mg_nocontext
#define NEED_sv_setpvf_mg
#define NEED_sv_setpvf_mg_nocontext

=xsmisc

static SV * test_vnewSVpvf(pTHX_ const char *pat, ...)
{
  SV *sv;
  va_list args;
  va_start(args, pat);
#if { VERSION >= 5.004 }
  sv = vnewSVpvf(pat, &args);
#else
  sv = newSVpv((char *) pat, 0);
#endif
  va_end(args);
  return sv;
}

static void test_sv_vcatpvf(pTHX_ SV *sv, const char *pat, ...)
{
  va_list args;
  va_start(args, pat);
#if { VERSION >= 5.004 }
  sv_vcatpvf(sv, pat, &args);
#else
  sv_catpv(sv, (char *) pat);
#endif
  va_end(args);
}

static void test_sv_vsetpvf(pTHX_ SV *sv, const char *pat, ...)
{
  va_list args;
  va_start(args, pat);
#if { VERSION >= 5.004 }
  sv_vsetpvf(sv, pat, &args);
#else
  sv_setpv(sv, (char *) pat);
#endif
  va_end(args);
}

=xsubs

SV *
vnewSVpvf()
        CODE:
                RETVAL = test_vnewSVpvf(aTHX_ "%s-%d", "Perl", 42);
        OUTPUT:
                RETVAL

SV *
sv_vcatpvf(sv)
        SV *sv
        CODE:
                RETVAL = newSVsv(sv);
                test_sv_vcatpvf(aTHX_ RETVAL, "%s-%d", "Perl", 42);
        OUTPUT:
                RETVAL

SV *
sv_vsetpvf(sv)
        SV *sv
        CODE:
                RETVAL = newSVsv(sv);
                test_sv_vsetpvf(aTHX_ RETVAL, "%s-%d", "Perl", 42);
        OUTPUT:
                RETVAL

void
sv_catpvf_mg(sv)
        SV *sv
        CODE:
#if { VERSION >= 5.004 }
                sv_catpvf_mg(sv, "%s-%d", "Perl", 42);
#endif

void
Perl_sv_catpvf_mg(sv)
        SV *sv
        CODE:
#if { VERSION >= 5.004 }
                Perl_sv_catpvf_mg(aTHX_ sv, "%s-%d", "-Perl", 43);
#endif

void
sv_catpvf_mg_nocontext(sv)
        SV *sv
        CODE:
#if { VERSION >= 5.004 }
#ifdef PERL_IMPLICIT_CONTEXT
                sv_catpvf_mg_nocontext(sv, "%s-%d", "-Perl", 44);
#else
                sv_catpvf_mg(sv, "%s-%d", "-Perl", 44);
#endif
#endif

void
sv_setpvf_mg(sv)
        SV *sv
        CODE:
#if { VERSION >= 5.004 }
                sv_setpvf_mg(sv, "%s-%d", "mhx", 42);
#endif

void
Perl_sv_setpvf_mg(sv)
        SV *sv
        CODE:
#if { VERSION >= 5.004 }
                Perl_sv_setpvf_mg(aTHX_ sv, "%s-%d", "foo", 43);
#endif

void
sv_setpvf_mg_nocontext(sv)
        SV *sv
        CODE:
#if { VERSION >= 5.004 }
#ifdef PERL_IMPLICIT_CONTEXT
                sv_setpvf_mg_nocontext(sv, "%s-%d", "bar", 44);
#else
                sv_setpvf_mg(sv, "%s-%d", "bar", 44);
#endif
#endif

=tests plan => 9

use Tie::Hash;
my %h;
tie %h, 'Tie::StdHash';
$h{foo} = 'foo-';
$h{bar} = '';

is(&Devel::PPPort::vnewSVpvf(), ivers($]) >= ivers("5.004") ? 'Perl-42' : '%s-%d');
is(&Devel::PPPort::sv_vcatpvf('1-2-3-'), ivers($]) >= ivers("5.004") ? '1-2-3-Perl-42' : '1-2-3-%s-%d');
is(&Devel::PPPort::sv_vsetpvf('1-2-3-'), ivers($]) >= ivers("5.004") ? 'Perl-42' : '%s-%d');

&Devel::PPPort::sv_catpvf_mg($h{foo});
is($h{foo}, ivers($]) >= ivers("5.004") ? 'foo-Perl-42' : 'foo-');

&Devel::PPPort::Perl_sv_catpvf_mg($h{foo});
is($h{foo}, ivers($]) >= ivers("5.004") ? 'foo-Perl-42-Perl-43' : 'foo-');

&Devel::PPPort::sv_catpvf_mg_nocontext($h{foo});
is($h{foo}, ivers($]) >= ivers("5.004") ? 'foo-Perl-42-Perl-43-Perl-44' : 'foo-');

&Devel::PPPort::sv_setpvf_mg($h{bar});
is($h{bar}, ivers($]) >= ivers("5.004") ? 'mhx-42' : '');

&Devel::PPPort::Perl_sv_setpvf_mg($h{bar});
is($h{bar}, ivers($]) >= ivers("5.004") ? 'foo-43' : '');

&Devel::PPPort::sv_setpvf_mg_nocontext($h{bar});
is($h{bar}, ivers($]) >= ivers("5.004") ? 'bar-44' : '');
Commit	Line	Data
96ad942f MHM	1	################################################################################
96ad942f MHM	2	##
b2049988	3	## Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
96ad942f MHM	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)
46677718	29	#if defined(PERL_USE_GCC_BRACE_GROUPS)
e2e74bab P	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)
96ad942f MHM	33	#endif
	34	#endif
	35
96ad942f MHM	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
96ad942f MHM	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
96ad942f MHM	44	#if { VERSION >= 5.004 } && !defined(sv_catpvf_mg)
	45	#if { NEED sv_catpvf_mg }
	46
	47	void
6b273def	48	sv_catpvf_mg(pTHX_ SV * const sv, const char * const pat, ...)
96ad942f MHM	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
96ad942f MHM	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
6b273def	65	sv_catpvf_mg_nocontext(SV * const sv, const char * const pat, ...)
96ad942f MHM	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
679ad62d	79	/* sv_catpvf_mg depends on sv_catpvf_mg_nocontext */
96ad942f MHM	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
96ad942f MHM	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
96ad942f MHM	96	#if { VERSION >= 5.004 } && !defined(sv_setpvf_mg)
	97	#if { NEED sv_setpvf_mg }
	98
	99	void
6b273def	100	sv_setpvf_mg(pTHX_ SV * const sv, const char * const pat, ...)
96ad942f MHM	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
96ad942f MHM	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
6b273def	117	sv_setpvf_mg_nocontext(SV * const sv, const char * const pat, ...)
96ad942f MHM	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
679ad62d	131	/* sv_setpvf_mg depends on sv_setpvf_mg_nocontext */
96ad942f MHM	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
96ad942f MHM	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
96ad942f MHM	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
aab9a3b6	165	sv = newSVpv((char *) pat, 0);
96ad942f MHM	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
aab9a3b6	178	sv_catpv(sv, (char *) pat);
96ad942f MHM	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
aab9a3b6	190	sv_setpv(sv, (char *) pat);
96ad942f MHM	191	#endif
	192	va_end(args);
	193	}
	194
	195	=xsubs
	196
	197	SV *
	198	vnewSVpvf()
b2049988 MHM	199	CODE:
	200	RETVAL = test_vnewSVpvf(aTHX_ "%s-%d", "Perl", 42);
	201	OUTPUT:
	202	RETVAL
96ad942f MHM	203
	204	SV *
	205	sv_vcatpvf(sv)
b2049988 MHM	206	SV *sv
	207	CODE:
	208	RETVAL = newSVsv(sv);
	209	test_sv_vcatpvf(aTHX_ RETVAL, "%s-%d", "Perl", 42);
	210	OUTPUT:
	211	RETVAL
96ad942f MHM	212
	213	SV *
	214	sv_vsetpvf(sv)
b2049988 MHM	215	SV *sv
	216	CODE:
	217	RETVAL = newSVsv(sv);
	218	test_sv_vsetpvf(aTHX_ RETVAL, "%s-%d", "Perl", 42);
	219	OUTPUT:
	220	RETVAL
96ad942f MHM	221
	222	void
	223	sv_catpvf_mg(sv)
b2049988 MHM	224	SV *sv
b2049988 MHM	225	CODE:
96ad942f	226	#if { VERSION >= 5.004 }
b2049988	227	sv_catpvf_mg(sv, "%s-%d", "Perl", 42);
96ad942f MHM	228	#endif
	229
	230	void
	231	Perl_sv_catpvf_mg(sv)
b2049988 MHM	232	SV *sv
b2049988 MHM	233	CODE:
96ad942f	234	#if { VERSION >= 5.004 }
b2049988	235	Perl_sv_catpvf_mg(aTHX_ sv, "%s-%d", "-Perl", 43);
96ad942f MHM	236	#endif
	237
	238	void
	239	sv_catpvf_mg_nocontext(sv)
b2049988 MHM	240	SV *sv
b2049988 MHM	241	CODE:
96ad942f MHM	242	#if { VERSION >= 5.004 }
96ad942f MHM	243	#ifdef PERL_IMPLICIT_CONTEXT
b2049988	244	sv_catpvf_mg_nocontext(sv, "%s-%d", "-Perl", 44);
96ad942f	245	#else
b2049988	246	sv_catpvf_mg(sv, "%s-%d", "-Perl", 44);
96ad942f MHM	247	#endif
	248	#endif
	249
	250	void
	251	sv_setpvf_mg(sv)
b2049988 MHM	252	SV *sv
b2049988 MHM	253	CODE:
96ad942f	254	#if { VERSION >= 5.004 }
b2049988	255	sv_setpvf_mg(sv, "%s-%d", "mhx", 42);
96ad942f MHM	256	#endif
	257
	258	void
	259	Perl_sv_setpvf_mg(sv)
b2049988 MHM	260	SV *sv
b2049988 MHM	261	CODE:
96ad942f	262	#if { VERSION >= 5.004 }
b2049988	263	Perl_sv_setpvf_mg(aTHX_ sv, "%s-%d", "foo", 43);
96ad942f MHM	264	#endif
	265
	266	void
	267	sv_setpvf_mg_nocontext(sv)
b2049988 MHM	268	SV *sv
b2049988 MHM	269	CODE:
96ad942f MHM	270	#if { VERSION >= 5.004 }
96ad942f MHM	271	#ifdef PERL_IMPLICIT_CONTEXT
b2049988	272	sv_setpvf_mg_nocontext(sv, "%s-%d", "bar", 44);
96ad942f	273	#else
b2049988	274	sv_setpvf_mg(sv, "%s-%d", "bar", 44);
96ad942f MHM	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
c8799aff N	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');
96ad942f MHM	289
96ad942f MHM	290	&Devel::PPPort::sv_catpvf_mg($h{foo});
c8799aff	291	is($h{foo}, ivers($]) >= ivers("5.004") ? 'foo-Perl-42' : 'foo-');
96ad942f MHM	292
96ad942f MHM	293	&Devel::PPPort::Perl_sv_catpvf_mg($h{foo});
c8799aff	294	is($h{foo}, ivers($]) >= ivers("5.004") ? 'foo-Perl-42-Perl-43' : 'foo-');
96ad942f MHM	295
96ad942f MHM	296	&Devel::PPPort::sv_catpvf_mg_nocontext($h{foo});
c8799aff	297	is($h{foo}, ivers($]) >= ivers("5.004") ? 'foo-Perl-42-Perl-43-Perl-44' : 'foo-');
96ad942f MHM	298
96ad942f MHM	299	&Devel::PPPort::sv_setpvf_mg($h{bar});
c8799aff	300	is($h{bar}, ivers($]) >= ivers("5.004") ? 'mhx-42' : '');
96ad942f MHM	301
96ad942f MHM	302	&Devel::PPPort::Perl_sv_setpvf_mg($h{bar});
c8799aff	303	is($h{bar}, ivers($]) >= ivers("5.004") ? 'foo-43' : '');
96ad942f MHM	304
96ad942f MHM	305	&Devel::PPPort::sv_setpvf_mg_nocontext($h{bar});
c8799aff	306	is($h{bar}, ivers($]) >= ivers("5.004") ? 'bar-44' : '');