view release on metacpan or  search on metacpan

parts/inc/call  view on Meta::CPAN

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