eval_pv eval_sv call_sv call_pv call_argv call_method load_module vload_module G_METHOD G_RETHROW
/* 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__ 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 # define D_PPP_CROAK_IF_ERROR(cond) ((cond) && (SvROK(ERRSV) || SvTRUE(ERRSV)) && (croak_sv(ERRSV), 1)) #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_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; 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; } }
#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); }
#define NEED_eval_pv #define NEED_load_module #define NEED_vload_module
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);
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 } }
5 POD Errors
The following errors were encountered while parsing the POD:
Unknown directive: =provides
Unknown directive: =implementation
Unknown directive: =xsinit
Unknown directive: =xsubs
Unknown directive: =tests
To install , copy and paste the appropriate command in to your terminal.
cpanm
cpanm ATOOMIC/Devel-PPPort-3.60_01.tar.gz
CPAN shell
perl -MCPAN -e shell install ATOOMIC/Devel-PPPort-3.60_01.tar.gz
For more information on module installation, please visit the detailed CPAN module installation guide.