################################################################################

##

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

/* 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);

#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

                  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

                  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

                  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

                  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

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