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

################################################################################
##
##  $Revision: 12 $
##  $Author: mhx $
##  $Date: 2007/03/23 17:57:58 +0100 $
##
################################################################################
##
##  Version 3.x, Copyright (C) 2004-2007, 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

=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

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

/* Replace: 0 */

/* Replace perl_eval_pv with eval_pv */
/* eval_pv depends on eval_sv */

#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

/* load_module depends on vload_module */

#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);
		PUSHs(sv_2mortal(newSViv(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);
		PUSHs(sv_2mortal(newSViv(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);
		PUSHs(sv_2mortal(newSViv(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);
		PUSHs(sv_2mortal(newSViv(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);
		PUSHs(sv_2mortal(newSViv(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.  */
		SvREFCNT_inc(name);
		SvREFCNT_inc(version);
		Perl_load_module(aTHX_ flags, name, version, NULL);

=tests plan => 46

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