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

################################################################################
##
##  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

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

/* Older Perl versions have broken croak_on_error=1 */
#if { VERSION < 5.31.2 }
# ifdef eval_pv
#  undef eval_pv
#  if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
#   define eval_pv(p, croak_on_error) ({ SV *_sv = Perl_eval_pv(aTHX_ p, 0); SV *_errsv = ERRSV; (croak_on_error && (SvROK(_errsv) || SvTRUE(_errsv)) && (croak_sv(_errsv), 1)); _sv; })
#  else
#   define eval_pv(p, croak_on_error) ((PL_Sv = Perl_eval_pv(aTHX_ p, 0)), (croak_on_error && (SvROK(ERRSV) || SvTRUE(ERRSV)) && (croak_sv(ERRSV), 1)), PL_Sv)
#  endif
# 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* errsv;
    SV* sv = newSVpv(p, 0);

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

    SPAGAIN;
    sv = POPs;
    PUTBACK;

    if (croak_on_error) {
        errsv = ERRSV;
        if (SvROK(errsv) || SvTRUE(errsv))
            croak_sv(errsv);
    }

    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);
#elif { VERSION > 5.003 }
        utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(),
                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 => 69

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");

ok(eval { Devel::PPPort::eval_pv('die', 0); 1 });
ok(!eval { Devel::PPPort::eval_pv('die', 1); 1 });
ok($@ =~ /^Died at \(eval [0-9]+\) line 1\.\n$/);
ok(eval { $@ = 'string1'; Devel::PPPort::eval_pv('', 0); 1 });
ok(eval { $@ = 'string1'; Devel::PPPort::eval_pv('', 1); 1 });
ok(eval { $@ = 'string1'; Devel::PPPort::eval_pv('$@ = "string2"', 0); 1 });
ok(eval { $@ = 'string1'; Devel::PPPort::eval_pv('$@ = "string2"', 1); 1 });
ok(eval { $@ = 'string1'; Devel::PPPort::eval_pv('$@ = "string2"; die "string3"', 0); 1 });
ok(!eval { $@ = 'string1'; Devel::PPPort::eval_pv('$@ = "string2"; die "string3"', 1); 1 });
ok($@ =~ /^string3 at \(eval [0-9]+\) line 1\.\n$/);

if ($] ge '5.007003' or ($] ge '5.006001' and $] lt '5.007')) {
    my $hashref = { key => 'value' };
    ok(eval { Devel::PPPort::eval_pv('die $hashref', 1); 1 }, undef, 'check plain hashref is rethrown');
    ok(ref($@), 'HASH', 'check $@ is hashref') and
        ok($@->{key}, 'value', 'check $@ hashref has correct value');

    my $false = False->new;
    ok(!$false);
    ok(eval { Devel::PPPort::eval_pv('die $false', 1); 1 }, undef, 'check false objects are rethrown');
    ok(ref($@), 'False', 'check that $@ contains False object');
    ok("$@", "$false", 'check we got the expected object');
} else {
    skip 'skip: no support for references in $@', 0 for 1..7;
}

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