[p5sagit/p5-mst-13.2.git] / ext / Devel-PPPort / parts / inc / call

################################################################################
##
##  $Revision: 19 $
##  $Author: mhx $
##  $Date: 2009/01/23 18:27:48 +0100 $
##
################################################################################
##
##  Version 3.x, Copyright (C) 2004-2009, 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

eval_pv
eval_sv
call_sv
call_pv
call_argv
call_method
load_module
vload_module
G_METHOD

=implementation

/* Replace: 1 */
__UNDEFINED__  call_sv       perl_call_sv
__UNDEFINED__  call_pv       perl_call_pv
__UNDEFINED__  call_argv     perl_call_argv
__UNDEFINED__  call_method   perl_call_method

__UNDEFINED__  eval_sv       perl_eval_sv
/* Replace: 0 */

__UNDEFINED__ PERL_LOADMOD_DENY		0x1
__UNDEFINED__ PERL_LOADMOD_NOIMPORT	0x2
__UNDEFINED__ PERL_LOADMOD_IMPORT_OPS	0x4

#ifndef G_METHOD
# define G_METHOD		64
# ifdef call_sv
#  undef call_sv
# endif
# if { VERSION < 5.6.0 }
#  define call_sv(sv, flags)  ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \
				(flags) & ~G_METHOD) : perl_call_sv(sv, flags))
# else
#  define call_sv(sv, flags)  ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \
				(flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags))
# endif
#endif

/* Replace perl_eval_pv with eval_pv */

#ifndef eval_pv
#if { NEED eval_pv }

SV*
eval_pv(char *p, I32 croak_on_error)
{
    dSP;
    SV* sv = newSVpv(p, 0);

    PUSHMARK(sp);
    eval_sv(sv, G_SCALAR);
    SvREFCNT_dec(sv);

    SPAGAIN;
    sv = POPs;
    PUTBACK;

    if (croak_on_error && SvTRUE(GvSV(errgv)))
	croak(SvPVx(GvSV(errgv), na));

    return sv;
}

#endif
#endif

#ifndef vload_module
#if { NEED vload_module }

void
vload_module(U32 flags, SV *name, SV *ver, va_list *args)
{
    dTHR;
    dVAR;
    OP *veop, *imop;

    OP * const modname = newSVOP(OP_CONST, 0, name);
    /* 5.005 has a somewhat hacky force_normal that doesn't croak on
       SvREADONLY() if PL_compling is true. Current perls take care in
       ck_require() to correctly turn off SvREADONLY before calling
       force_normal_flags(). This seems a better fix than fudging PL_compling
     */
    SvREADONLY_off(((SVOP*)modname)->op_sv);
    modname->op_private |= OPpCONST_BARE;
    if (ver) {
	veop = newSVOP(OP_CONST, 0, ver);
    }
    else
	veop = NULL;
    if (flags & PERL_LOADMOD_NOIMPORT) {
	imop = sawparens(newNULLLIST());
    }
    else if (flags & PERL_LOADMOD_IMPORT_OPS) {
	imop = va_arg(*args, OP*);
    }
    else {
	SV *sv;
	imop = NULL;
	sv = va_arg(*args, SV*);
	while (sv) {
	    imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
	    sv = va_arg(*args, SV*);
	}
    }
    {
	const line_t ocopline = PL_copline;
	COP * const ocurcop = PL_curcop;
	const int oexpect = PL_expect;

#if { VERSION >= 5.004 }
	utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
		veop, modname, imop);
#else
	utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(),
		modname, imop);
#endif
	PL_expect = oexpect;
	PL_copline = ocopline;
	PL_curcop = ocurcop;
    }
}

#endif
#endif

#ifndef load_module
#if { NEED load_module }

void
load_module(U32 flags, SV *name, SV *ver, ...)
{
    va_list args;
    va_start(args, ver);
    vload_module(flags, name, ver, &args);
    va_end(args);
}

#endif
#endif

=xsinit

#define NEED_eval_pv
#define NEED_load_module
#define NEED_vload_module

=xsubs

I32
G_SCALAR()
	CODE:
		RETVAL = G_SCALAR;
	OUTPUT:
		RETVAL

I32
G_ARRAY()
	CODE:
		RETVAL = G_ARRAY;
	OUTPUT:
		RETVAL

I32
G_DISCARD()
	CODE:
		RETVAL = G_DISCARD;
	OUTPUT:
		RETVAL

void
eval_sv(sv, flags)
	SV* sv
	I32 flags
	PREINIT:
		I32 i;
	PPCODE:
		PUTBACK;
		i = eval_sv(sv, flags);
		SPAGAIN;
		EXTEND(SP, 1);
		mPUSHi(i);

void
eval_pv(p, croak_on_error)
	char* p
	I32 croak_on_error
	PPCODE:
		PUTBACK;
		EXTEND(SP, 1);
		PUSHs(eval_pv(p, croak_on_error));

void
call_sv(sv, flags, ...)
	SV* sv
	I32 flags
	PREINIT:
		I32 i;
	PPCODE:
		for (i=0; i<items-2; i++)
		  ST(i) = ST(i+2); /* pop first two args */
		PUSHMARK(SP);
		SP += items - 2;
		PUTBACK;
		i = call_sv(sv, flags);
		SPAGAIN;
		EXTEND(SP, 1);
		mPUSHi(i);

void
call_pv(subname, flags, ...)
	char* subname
	I32 flags
	PREINIT:
		I32 i;
	PPCODE:
		for (i=0; i<items-2; i++)
		  ST(i) = ST(i+2); /* pop first two args */
		PUSHMARK(SP);
		SP += items - 2;
		PUTBACK;
		i = call_pv(subname, flags);
		SPAGAIN;
		EXTEND(SP, 1);
		mPUSHi(i);

void
call_argv(subname, flags, ...)
	char* subname
	I32 flags
	PREINIT:
		I32 i;
		char *args[8];
	PPCODE:
		if (items > 8)  /* play safe */
		  XSRETURN_UNDEF;
		for (i=2; i<items; i++)
		  args[i-2] = SvPV_nolen(ST(i));
		args[items-2] = NULL;
		PUTBACK;
		i = call_argv(subname, flags, args);
		SPAGAIN;
		EXTEND(SP, 1);
		mPUSHi(i);

void
call_method(methname, flags, ...)
	char* methname
	I32 flags
	PREINIT:
		I32 i;
	PPCODE:
		for (i=0; i<items-2; i++)
		  ST(i) = ST(i+2); /* pop first two args */
		PUSHMARK(SP);
		SP += items - 2;
		PUTBACK;
		i = call_method(methname, flags);
		SPAGAIN;
		EXTEND(SP, 1);
		mPUSHi(i);

void
call_sv_G_METHOD(sv, flags, ...)
	SV* sv
	I32 flags
	PREINIT:
		I32 i;
	PPCODE:
		for (i=0; i<items-2; i++)
		  ST(i) = ST(i+2); /* pop first two args */
		PUSHMARK(SP);
		SP += items - 2;
		PUTBACK;
		i = call_sv(sv, flags | G_METHOD);
		SPAGAIN;
		EXTEND(SP, 1);
		mPUSHi(i);

void
load_module(flags, name, version, ...)
	U32 flags
	SV *name
	SV *version
	CODE:
		/* Both SV parameters are donated to the ops built inside
		   load_module, so we need to bump the refcounts.  */
		Perl_load_module(aTHX_ flags, SvREFCNT_inc_simple(name),
		                 SvREFCNT_inc_simple(version), NULL);

=tests plan => 52

sub eq_array
{
  my($a, $b) = @_;
  join(':', @$a) eq join(':', @$b);
}

sub f
{
  shift;
  unshift @_, 'b';
  pop @_;
  @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z';
}

my $obj = bless [], 'Foo';

sub Foo::meth
{
  return 'bad_self' unless @_ && ref $_[0] && ref($_[0]) eq 'Foo';
  shift;
  shift;
  unshift @_, 'b';
  pop @_;
  @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z';
}

my $test;

for $test (
    # flags                      args           expected         description
    [ &Devel::PPPort::G_SCALAR,  [ ],           [ qw(y 1) ],     '0 args, G_SCALAR'  ],
    [ &Devel::PPPort::G_SCALAR,  [ qw(a p q) ], [ qw(y 1) ],     '3 args, G_SCALAR'  ],
    [ &Devel::PPPort::G_ARRAY,   [ ],           [ qw(x 1) ],     '0 args, G_ARRAY'   ],
    [ &Devel::PPPort::G_ARRAY,   [ qw(a p q) ], [ qw(b p x 3) ], '3 args, G_ARRAY'   ],
    [ &Devel::PPPort::G_DISCARD, [ ],           [ qw(0) ],       '0 args, G_DISCARD' ],
    [ &Devel::PPPort::G_DISCARD, [ qw(a p q) ], [ qw(0) ],       '3 args, G_DISCARD' ],
)
{
    my ($flags, $args, $expected, $description) = @$test;
    print "# --- $description ---\n";
    ok(eq_array( [ &Devel::PPPort::call_sv(\&f, $flags, @$args) ], $expected));
    ok(eq_array( [ &Devel::PPPort::call_sv(*f,  $flags, @$args) ], $expected));
    ok(eq_array( [ &Devel::PPPort::call_sv('f', $flags, @$args) ], $expected));
    ok(eq_array( [ &Devel::PPPort::call_pv('f', $flags, @$args) ], $expected));
    ok(eq_array( [ &Devel::PPPort::call_argv('f', $flags, @$args) ], $expected));
    ok(eq_array( [ &Devel::PPPort::eval_sv("f(qw(@$args))", $flags) ], $expected));
    ok(eq_array( [ &Devel::PPPort::call_method('meth', $flags, $obj, @$args) ], $expected));
    ok(eq_array( [ &Devel::PPPort::call_sv_G_METHOD('meth', $flags, $obj, @$args) ], $expected));
};

ok(&Devel::PPPort::eval_pv('f()', 0), 'y');
ok(&Devel::PPPort::eval_pv('f(qw(a b c))', 0), 'y');

ok(!defined $::{'less::'}, 1, "Hadn't loaded less yet");
Devel::PPPort::load_module(0, "less", undef);
ok(defined $::{'less::'}, 1, "Have now loaded less");
Commit	Line	Data
adfe19db	1	################################################################################
adfe19db	2	##
ac2e3cea	3	## $Revision: 19 $
adfe19db	4	## $Author: mhx $
ac2e3cea	5	## $Date: 2009/01/23 18:27:48 +0100 $
adfe19db	6	##
	7	################################################################################
	8	##
51d6c659	9	## Version 3.x, Copyright (C) 2004-2009, Marcus Holland-Moritz.
adfe19db	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	eval_pv
	21	eval_sv
	22	call_sv
	23	call_pv
	24	call_argv
	25	call_method
a89b7ab8	26	load_module
a89b7ab8	27	vload_module
ac2e3cea	28	G_METHOD
adfe19db	29
	30	=implementation
	31
	32	/* Replace: 1 */
	33	__UNDEFINED__ call_sv perl_call_sv
	34	__UNDEFINED__ call_pv perl_call_pv
	35	__UNDEFINED__ call_argv perl_call_argv
	36	__UNDEFINED__ call_method perl_call_method
	37
	38	__UNDEFINED__ eval_sv perl_eval_sv
ac2e3cea	39	/* Replace: 0 */
a89b7ab8	40
	41	__UNDEFINED__ PERL_LOADMOD_DENY 0x1
	42	__UNDEFINED__ PERL_LOADMOD_NOIMPORT 0x2
	43	__UNDEFINED__ PERL_LOADMOD_IMPORT_OPS 0x4
	44
ac2e3cea	45	#ifndef G_METHOD
	46	# define G_METHOD 64
	47	# ifdef call_sv
	48	# undef call_sv
	49	# endif
	50	# if { VERSION < 5.6.0 }
	51	# define call_sv(sv, flags) ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \
	52	(flags) & ~G_METHOD) : perl_call_sv(sv, flags))
	53	# else
	54	# define call_sv(sv, flags) ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \
	55	(flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags))
	56	# endif
	57	#endif
adfe19db	58
adfe19db	59	/* Replace perl_eval_pv with eval_pv */
adfe19db	60
	61	#ifndef eval_pv
	62	#if { NEED eval_pv }
	63
	64	SV*
	65	eval_pv(char *p, I32 croak_on_error)
	66	{
	67	dSP;
	68	SV* sv = newSVpv(p, 0);
	69
	70	PUSHMARK(sp);
	71	eval_sv(sv, G_SCALAR);
	72	SvREFCNT_dec(sv);
	73
	74	SPAGAIN;
	75	sv = POPs;
	76	PUTBACK;
	77
	78	if (croak_on_error && SvTRUE(GvSV(errgv)))
	79	croak(SvPVx(GvSV(errgv), na));
	80
	81	return sv;
	82	}
	83
	84	#endif
	85	#endif
	86
a89b7ab8	87	#ifndef vload_module
	88	#if { NEED vload_module }
	89
	90	void
	91	vload_module(U32 flags, SV name, SV ver, va_list *args)
	92	{
	93	dTHR;
	94	dVAR;
	95	OP veop, imop;
	96
	97	OP * const modname = newSVOP(OP_CONST, 0, name);
	98	/* 5.005 has a somewhat hacky force_normal that doesn't croak on
	99	SvREADONLY() if PL_compling is true. Current perls take care in
	100	ck_require() to correctly turn off SvREADONLY before calling
	101	force_normal_flags(). This seems a better fix than fudging PL_compling
	102	*/
	103	SvREADONLY_off(((SVOP*)modname)->op_sv);
	104	modname->op_private \|= OPpCONST_BARE;
	105	if (ver) {
	106	veop = newSVOP(OP_CONST, 0, ver);
	107	}
	108	else
	109	veop = NULL;
	110	if (flags & PERL_LOADMOD_NOIMPORT) {
	111	imop = sawparens(newNULLLIST());
	112	}
	113	else if (flags & PERL_LOADMOD_IMPORT_OPS) {
	114	imop = va_arg(args, OP);
	115	}
	116	else {
	117	SV *sv;
	118	imop = NULL;
	119	sv = va_arg(args, SV);
	120	while (sv) {
	121	imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
	122	sv = va_arg(args, SV);
	123	}
	124	}
	125	{
	126	const line_t ocopline = PL_copline;
	127	COP * const ocurcop = PL_curcop;
	128	const int oexpect = PL_expect;
	129
	130	#if { VERSION >= 5.004 }
	131	utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
	132	veop, modname, imop);
	133	#else
	134	utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(),
	135	modname, imop);
	136	#endif
	137	PL_expect = oexpect;
	138	PL_copline = ocopline;
	139	PL_curcop = ocurcop;
	140	}
	141	}
	142
	143	#endif
	144	#endif
	145
a89b7ab8	146	#ifndef load_module
	147	#if { NEED load_module }
	148
	149	void
	150	load_module(U32 flags, SV name, SV ver, ...)
	151	{
	152	va_list args;
	153	va_start(args, ver);
	154	vload_module(flags, name, ver, &args);
	155	va_end(args);
	156	}
	157
	158	#endif
	159	#endif
	160
adfe19db	161	=xsinit
	162
	163	#define NEED_eval_pv
a89b7ab8	164	#define NEED_load_module
a89b7ab8	165	#define NEED_vload_module
adfe19db	166
	167	=xsubs
	168
	169	I32
	170	G_SCALAR()
	171	CODE:
	172	RETVAL = G_SCALAR;
	173	OUTPUT:
	174	RETVAL
	175
	176	I32
	177	G_ARRAY()
	178	CODE:
	179	RETVAL = G_ARRAY;
	180	OUTPUT:
	181	RETVAL
	182
	183	I32
	184	G_DISCARD()
	185	CODE:
	186	RETVAL = G_DISCARD;
	187	OUTPUT:
	188	RETVAL
	189
	190	void
	191	eval_sv(sv, flags)
	192	SV* sv
	193	I32 flags
	194	PREINIT:
	195	I32 i;
	196	PPCODE:
	197	PUTBACK;
	198	i = eval_sv(sv, flags);
	199	SPAGAIN;
	200	EXTEND(SP, 1);
c1a049cb	201	mPUSHi(i);
adfe19db	202
	203	void
	204	eval_pv(p, croak_on_error)
	205	char* p
	206	I32 croak_on_error
	207	PPCODE:
	208	PUTBACK;
	209	EXTEND(SP, 1);
	210	PUSHs(eval_pv(p, croak_on_error));
	211
	212	void
	213	call_sv(sv, flags, ...)
	214	SV* sv
	215	I32 flags
	216	PREINIT:
	217	I32 i;
	218	PPCODE:
	219	for (i=0; i<items-2; i++)
	220	ST(i) = ST(i+2); /* pop first two args */
	221	PUSHMARK(SP);
	222	SP += items - 2;
	223	PUTBACK;
	224	i = call_sv(sv, flags);
	225	SPAGAIN;
	226	EXTEND(SP, 1);
c1a049cb	227	mPUSHi(i);
adfe19db	228
	229	void
	230	call_pv(subname, flags, ...)
	231	char* subname
	232	I32 flags
	233	PREINIT:
	234	I32 i;
	235	PPCODE:
	236	for (i=0; i<items-2; i++)
	237	ST(i) = ST(i+2); /* pop first two args */
	238	PUSHMARK(SP);
	239	SP += items - 2;
	240	PUTBACK;
	241	i = call_pv(subname, flags);
	242	SPAGAIN;
	243	EXTEND(SP, 1);
c1a049cb	244	mPUSHi(i);
adfe19db	245
	246	void
	247	call_argv(subname, flags, ...)
	248	char* subname
	249	I32 flags
	250	PREINIT:
	251	I32 i;
	252	char *args[8];
	253	PPCODE:
	254	if (items > 8) /* play safe */
	255	XSRETURN_UNDEF;
	256	for (i=2; i<items; i++)
	257	args[i-2] = SvPV_nolen(ST(i));
	258	args[items-2] = NULL;
	259	PUTBACK;
	260	i = call_argv(subname, flags, args);
	261	SPAGAIN;
	262	EXTEND(SP, 1);
c1a049cb	263	mPUSHi(i);
adfe19db	264
	265	void
	266	call_method(methname, flags, ...)
	267	char* methname
	268	I32 flags
	269	PREINIT:
	270	I32 i;
	271	PPCODE:
	272	for (i=0; i<items-2; i++)
	273	ST(i) = ST(i+2); /* pop first two args */
	274	PUSHMARK(SP);
	275	SP += items - 2;
	276	PUTBACK;
	277	i = call_method(methname, flags);
	278	SPAGAIN;
	279	EXTEND(SP, 1);
c1a049cb	280	mPUSHi(i);
adfe19db	281
a89b7ab8	282	void
ac2e3cea	283	call_sv_G_METHOD(sv, flags, ...)
	284	SV* sv
	285	I32 flags
	286	PREINIT:
	287	I32 i;
	288	PPCODE:
	289	for (i=0; i<items-2; i++)
	290	ST(i) = ST(i+2); /* pop first two args */
	291	PUSHMARK(SP);
	292	SP += items - 2;
	293	PUTBACK;
	294	i = call_sv(sv, flags \| G_METHOD);
	295	SPAGAIN;
	296	EXTEND(SP, 1);
	297	mPUSHi(i);
	298
	299	void
a89b7ab8	300	load_module(flags, name, version, ...)
	301	U32 flags
	302	SV *name
	303	SV *version
	304	CODE:
	305	/* Both SV parameters are donated to the ops built inside
	306	load_module, so we need to bump the refcounts. */
679ad62d	307	Perl_load_module(aTHX_ flags, SvREFCNT_inc_simple(name),
679ad62d	308	SvREFCNT_inc_simple(version), NULL);
a89b7ab8	309
ac2e3cea	310	=tests plan => 52
adfe19db	311
	312	sub eq_array
	313	{
	314	my($a, $b) = @_;
	315	join(':', @$a) eq join(':', @$b);
	316	}
	317
	318	sub f
	319	{
	320	shift;
	321	unshift @_, 'b';
	322	pop @_;
	323	@_, defined wantarray ? wantarray ? 'x' : 'y' : 'z';
	324	}
	325
	326	my $obj = bless [], 'Foo';
	327
	328	sub Foo::meth
	329	{
	330	return 'bad_self' unless @_ && ref $_[0] && ref($_[0]) eq 'Foo';
	331	shift;
	332	shift;
	333	unshift @_, 'b';
	334	pop @_;
	335	@_, defined wantarray ? wantarray ? 'x' : 'y' : 'z';
	336	}
	337
	338	my $test;
	339
	340	for $test (
	341	# flags args expected description
	342	[ &Devel::PPPort::G_SCALAR, [ ], [ qw(y 1) ], '0 args, G_SCALAR' ],
	343	[ &Devel::PPPort::G_SCALAR, [ qw(a p q) ], [ qw(y 1) ], '3 args, G_SCALAR' ],
	344	[ &Devel::PPPort::G_ARRAY, [ ], [ qw(x 1) ], '0 args, G_ARRAY' ],
	345	[ &Devel::PPPort::G_ARRAY, [ qw(a p q) ], [ qw(b p x 3) ], '3 args, G_ARRAY' ],
	346	[ &Devel::PPPort::G_DISCARD, [ ], [ qw(0) ], '0 args, G_DISCARD' ],
	347	[ &Devel::PPPort::G_DISCARD, [ qw(a p q) ], [ qw(0) ], '3 args, G_DISCARD' ],
	348	)
	349	{
	350	my ($flags, $args, $expected, $description) = @$test;
	351	print "# --- $description ---\n";
	352	ok(eq_array( [ &Devel::PPPort::call_sv(\&f, $flags, @$args) ], $expected));
	353	ok(eq_array( [ &Devel::PPPort::call_sv(*f, $flags, @$args) ], $expected));
	354	ok(eq_array( [ &Devel::PPPort::call_sv('f', $flags, @$args) ], $expected));
	355	ok(eq_array( [ &Devel::PPPort::call_pv('f', $flags, @$args) ], $expected));
	356	ok(eq_array( [ &Devel::PPPort::call_argv('f', $flags, @$args) ], $expected));
	357	ok(eq_array( [ &Devel::PPPort::eval_sv("f(qw(@$args))", $flags) ], $expected));
	358	ok(eq_array( [ &Devel::PPPort::call_method('meth', $flags, $obj, @$args) ], $expected));
ac2e3cea	359	ok(eq_array( [ &Devel::PPPort::call_sv_G_METHOD('meth', $flags, $obj, @$args) ], $expected));
adfe19db	360	};
	361
	362	ok(&Devel::PPPort::eval_pv('f()', 0), 'y');
	363	ok(&Devel::PPPort::eval_pv('f(qw(a b c))', 0), 'y');
	364
a89b7ab8	365	ok(!defined $::{'less::'}, 1, "Hadn't loaded less yet");
c83e6f19	366	Devel::PPPort::load_module(0, "less", undef);
a89b7ab8	367	ok(defined $::{'less::'}, 1, "Have now loaded less");