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