[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
G_RETHROW

=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
#if { VERSION >= 5.3.98 } && { VERSION < 5.6.0 }
__UNDEFINED__  eval_pv       perl_eval_pv
#endif
/* Replace: 0 */

#if { VERSION < 5.6.0 }
__UNDEFINED__ Perl_eval_sv   perl_eval_sv
#if { VERSION >= 5.3.98 }
__UNDEFINED__ Perl_eval_pv   perl_eval_pv
#endif
#endif

__UNDEFINED__ G_LIST         G_ARRAY    /* Replace */

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

#if defined(PERL_USE_GCC_BRACE_GROUPS)
# define D_PPP_CROAK_IF_ERROR(cond) ({              \
    SV *_errsv;                                     \
    (   (cond)                                      \
     && (_errsv = ERRSV)                            \
     && (SvROK(_errsv) || SvTRUE(_errsv))           \
     && (croak_sv(_errsv), 1));                     \
  })
#else
  PERL_STATIC_INLINE void D_PPP_CROAK_IF_ERROR(int cond) {
    dTHX;
    SV *errsv;
    if (!cond) return;
    errsv = ERRSV;
    if (SvROK(errsv) || SvTRUE(errsv)) croak_sv(errsv);
  }
# define D_PPP_CROAK_IF_ERROR(cond) D_PPP_CROAK_IF_ERROR(cond)
#endif

#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

#ifndef G_RETHROW
# define G_RETHROW 8192
# ifdef eval_sv
#  undef eval_sv
# endif
# if defined(PERL_USE_GCC_BRACE_GROUPS)
#  define eval_sv(sv, flags) ({ I32 _flags = (flags); I32 _ret = Perl_eval_sv(aTHX_ sv, (_flags & ~G_RETHROW)); D_PPP_CROAK_IF_ERROR(_flags & G_RETHROW); _ret; })
# else
#  define eval_sv(sv, flags) ((PL_na = Perl_eval_sv(aTHX_ sv, ((flags) & ~G_RETHROW))), D_PPP_CROAK_IF_ERROR((flags) & G_RETHROW), (I32)PL_na)
# endif
#endif

/* Older Perl versions have broken croak_on_error=1 */
#if { VERSION < 5.31.2 }
# ifdef eval_pv
#  undef eval_pv
#  if defined(PERL_USE_GCC_BRACE_GROUPS)
#   define eval_pv(p, croak_on_error) ({ SV *_sv = Perl_eval_pv(aTHX_ p, 0); D_PPP_CROAK_IF_ERROR(croak_on_error); _sv; })
#  else
#   define eval_pv(p, croak_on_error) ((PL_Sv = Perl_eval_pv(aTHX_ p, 0)), D_PPP_CROAK_IF_ERROR(croak_on_error), PL_Sv)
#  endif
# endif
#endif

/* This is backport for Perl 5.3.97d and older which do not provide perl_eval_pv */
#ifndef eval_pv
#if { NEED eval_pv }

SV*
eval_pv(const 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;

    D_PPP_CROAK_IF_ERROR(croak_on_error);

    return sv;
}

#endif
#endif

#if ! defined(vload_module) && defined(start_subparse)
#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_compiling 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_compiling
     */
    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;

        utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
#if { VERSION > 5.003 }
                veop,
#endif
                modname, imop);
        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

I32
G_RETHROW()
        CODE:
                RETVAL = G_RETHROW;
        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 => 88

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

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

is(!defined $::{'less::'}, 1, "Hadn't loaded less yet");
Devel::PPPort::load_module(0, "less", undef);
is(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$/);
ok(!eval { Devel::PPPort::eval_pv('die False->new', 1); 1 }, 'check false value is rethrown');

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

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

ok(eval { Devel::PPPort::eval_sv('die', 0); 1 });
ok(!eval { Devel::PPPort::eval_sv('die', &Devel::PPPort::G_RETHROW); 1 });
ok($@ =~ /^Died at \(eval [0-9]+\) line 1\.\n$/);
ok(eval { $@ = 'string1'; Devel::PPPort::eval_sv('', 0); 1 });
ok(eval { $@ = 'string1'; Devel::PPPort::eval_sv('', &Devel::PPPort::G_RETHROW); 1 });
ok(eval { $@ = 'string1'; Devel::PPPort::eval_sv('$@ = "string2"', 0); 1 });
ok(eval { $@ = 'string1'; Devel::PPPort::eval_sv('$@ = "string2"', &Devel::PPPort::G_RETHROW); 1 });
ok(eval { $@ = 'string1'; Devel::PPPort::eval_sv('$@ = "string2"; die "string3"', 0); 1 });
ok(!eval { $@ = 'string1'; Devel::PPPort::eval_sv('$@ = "string2"; die "string3"', &Devel::PPPort::G_RETHROW); 1 });
ok($@ =~ /^string3 at \(eval [0-9]+\) line 1\.\n$/);
ok(!eval { Devel::PPPort::eval_sv('die False->new', &Devel::PPPort::G_RETHROW); 1 }, 'check false value is rethrown');

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

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