################################################################################
##
## $Revision: 9 $
## $Author: mhx $
## $Date: 2006/01/14 18:07:59 +0100 $
##
################################################################################
##
## Version 3.x, Copyright (C) 2004-2006, 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
=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 */
/* Replace perl_eval_pv with eval_pv */
/* eval_pv depends on eval_sv */
#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
=xsinit
#define NEED_eval_pv
=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);
PUSHs(sv_2mortal(newSViv(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);
PUSHs(sv_2mortal(newSViv(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);
PUSHs(sv_2mortal(newSViv(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);
PUSHs(sv_2mortal(newSViv(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);
PUSHs(sv_2mortal(newSViv(i)));
=tests plan => 44
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(&Devel::PPPort::eval_pv('f()', 0), 'y');
ok(&Devel::PPPort::eval_pv('f(qw(a b c))', 0), 'y');