dist/Devel-PPPort/parts/inc/call

   1 ################################################################################
   2 ##
   3 ##  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
   4 ##  Version 2.x, Copyright (C) 2001, Paul Marquess.
   5 ##  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
   6 ##
   7 ##  This program is free software; you can redistribute it and/or
   8 ##  modify it under the same terms as Perl itself.
   9 ##
  10 ################################################################################
  11
  12 =provides
  13
  14 eval_pv
  15 eval_sv
  16 call_sv
  17 call_pv
  18 call_argv
  19 call_method
  20 load_module
  21 vload_module
  22 G_METHOD
  23 G_RETHROW
  24
  25 =implementation
  26
  27 /* Replace: 1 */
  28 __UNDEFINED__  call_sv       perl_call_sv
  29 __UNDEFINED__  call_pv       perl_call_pv
  30 __UNDEFINED__  call_argv     perl_call_argv
  31 __UNDEFINED__  call_method   perl_call_method
  32 __UNDEFINED__  eval_sv       perl_eval_sv
  33 #if { VERSION >= 5.3.98 } && { VERSION < 5.6.0 }
  34 __UNDEFINED__  eval_pv       perl_eval_pv
  35 #endif
  36 /* Replace: 0 */
  37
  38 #if { VERSION < 5.6.0 }
  39 __UNDEFINED__ Perl_eval_sv   perl_eval_sv
  40 #if { VERSION >= 5.3.98 }
  41 __UNDEFINED__ Perl_eval_pv   perl_eval_pv
  42 #endif
  43 #endif
  44
  45 __UNDEFINED__ PERL_LOADMOD_DENY         0x1
  46 __UNDEFINED__ PERL_LOADMOD_NOIMPORT     0x2
  47 __UNDEFINED__ PERL_LOADMOD_IMPORT_OPS   0x4
  48
  49 #if defined(PERL_USE_GCC_BRACE_GROUPS)
  50 # define D_PPP_CROAK_IF_ERROR(cond) ({ SV *_errsv; ((cond) && (_errsv = ERRSV) && (SvROK(_errsv) || SvTRUE(_errsv)) && (croak_sv(_errsv), 1)); })
  51 #else
  52 # define D_PPP_CROAK_IF_ERROR(cond) ((cond) && (SvROK(ERRSV) || SvTRUE(ERRSV)) && (croak_sv(ERRSV), 1))
  53 #endif
  54
  55 #ifndef G_METHOD
  56 # define G_METHOD               64
  57 # ifdef call_sv
  58 #  undef call_sv
  59 # endif
  60 # if { VERSION < 5.6.0 }
  61 #  define call_sv(sv, flags)  ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \
  62                                 (flags) & ~G_METHOD) : perl_call_sv(sv, flags))
  63 # else
  64 #  define call_sv(sv, flags)  ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \
  65                                 (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags))
  66 # endif
  67 #endif
  68
  69 #ifndef G_RETHROW
  70 # define G_RETHROW 8192
  71 # ifdef eval_sv
  72 #  undef eval_sv
  73 # endif
  74 # if defined(PERL_USE_GCC_BRACE_GROUPS)
  75 #  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; })
  76 # else
  77 #  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)
  78 # endif
  79 #endif
  80
  81 /* Older Perl versions have broken croak_on_error=1 */
  82 #if { VERSION < 5.31.2 }
  83 # ifdef eval_pv
  84 #  undef eval_pv
  85 #  if defined(PERL_USE_GCC_BRACE_GROUPS)
  86 #   define eval_pv(p, croak_on_error) ({ SV *_sv = Perl_eval_pv(aTHX_ p, 0); D_PPP_CROAK_IF_ERROR(croak_on_error); _sv; })
  87 #  else
  88 #   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)
  89 #  endif
  90 # endif
  91 #endif
  92
  93 /* This is backport for Perl 5.3.97d and older which do not provide perl_eval_pv */
  94 #ifndef eval_pv
  95 #if { NEED eval_pv }
  96
  97 SV*
  98 eval_pv(const char *p, I32 croak_on_error)
  99 {
 100     dSP;
 101     SV* sv = newSVpv(p, 0);
 102
 103     PUSHMARK(sp);
 104     eval_sv(sv, G_SCALAR);
 105     SvREFCNT_dec(sv);
 106
 107     SPAGAIN;
 108     sv = POPs;
 109     PUTBACK;
 110
 111     D_PPP_CROAK_IF_ERROR(croak_on_error);
 112
 113     return sv;
 114 }
 115
 116 #endif
 117 #endif
 118
 119 #if ! defined(vload_module) && defined(start_subparse)
 120 #if { NEED vload_module }
 121
 122 void
 123 vload_module(U32 flags, SV *name, SV *ver, va_list *args)
 124 {
 125     dTHR;
 126     dVAR;
 127     OP *veop, *imop;
 128
 129     OP * const modname = newSVOP(OP_CONST, 0, name);
 130     /* 5.005 has a somewhat hacky force_normal that doesn't croak on
 131        SvREADONLY() if PL_compling is true. Current perls take care in
 132        ck_require() to correctly turn off SvREADONLY before calling
 133        force_normal_flags(). This seems a better fix than fudging PL_compling
 134      */
 135     SvREADONLY_off(((SVOP*)modname)->op_sv);
 136     modname->op_private |= OPpCONST_BARE;
 137     if (ver) {
 138         veop = newSVOP(OP_CONST, 0, ver);
 139     }
 140     else
 141         veop = NULL;
 142     if (flags & PERL_LOADMOD_NOIMPORT) {
 143         imop = sawparens(newNULLLIST());
 144     }
 145     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
 146         imop = va_arg(*args, OP*);
 147     }
 148     else {
 149         SV *sv;
 150         imop = NULL;
 151         sv = va_arg(*args, SV*);
 152         while (sv) {
 153             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
 154             sv = va_arg(*args, SV*);
 155         }
 156     }
 157     {
 158         const line_t ocopline = PL_copline;
 159         COP * const ocurcop = PL_curcop;
 160         const int oexpect = PL_expect;
 161
 162         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
 163 #if { VERSION > 5.003 }
 164                 veop,
 165 #endif
 166                 modname, imop);
 167         PL_expect = oexpect;
 168         PL_copline = ocopline;
 169         PL_curcop = ocurcop;
 170     }
 171 }
 172
 173 #endif
 174 #endif
 175
 176 #ifndef load_module
 177 #if { NEED load_module }
 178
 179 void
 180 load_module(U32 flags, SV *name, SV *ver, ...)
 181 {
 182     va_list args;
 183     va_start(args, ver);
 184     vload_module(flags, name, ver, &args);
 185     va_end(args);
 186 }
 187
 188 #endif
 189 #endif
 190
 191 =xsinit
 192
 193 #define NEED_eval_pv
 194 #define NEED_load_module
 195 #define NEED_vload_module
 196
 197 =xsubs
 198
 199 I32
 200 G_SCALAR()
 201         CODE:
 202                 RETVAL = G_SCALAR;
 203         OUTPUT:
 204                 RETVAL
 205
 206 I32
 207 G_ARRAY()
 208         CODE:
 209                 RETVAL = G_ARRAY;
 210         OUTPUT:
 211                 RETVAL
 212
 213 I32
 214 G_DISCARD()
 215         CODE:
 216                 RETVAL = G_DISCARD;
 217         OUTPUT:
 218                 RETVAL
 219
 220 I32
 221 G_RETHROW()
 222         CODE:
 223                 RETVAL = G_RETHROW;
 224         OUTPUT:
 225                 RETVAL
 226
 227 void
 228 eval_sv(sv, flags)
 229         SV* sv
 230         I32 flags
 231         PREINIT:
 232                 I32 i;
 233         PPCODE:
 234                 PUTBACK;
 235                 i = eval_sv(sv, flags);
 236                 SPAGAIN;
 237                 EXTEND(SP, 1);
 238                 mPUSHi(i);
 239
 240 void
 241 eval_pv(p, croak_on_error)
 242         char* p
 243         I32 croak_on_error
 244         PPCODE:
 245                 PUTBACK;
 246                 EXTEND(SP, 1);
 247                 PUSHs(eval_pv(p, croak_on_error));
 248
 249 void
 250 call_sv(sv, flags, ...)
 251         SV* sv
 252         I32 flags
 253         PREINIT:
 254                 I32 i;
 255         PPCODE:
 256                 for (i=0; i<items-2; i++)
 257                   ST(i) = ST(i+2); /* pop first two args */
 258                 PUSHMARK(SP);
 259                 SP += items - 2;
 260                 PUTBACK;
 261                 i = call_sv(sv, flags);
 262                 SPAGAIN;
 263                 EXTEND(SP, 1);
 264                 mPUSHi(i);
 265
 266 void
 267 call_pv(subname, flags, ...)
 268         char* subname
 269         I32 flags
 270         PREINIT:
 271                 I32 i;
 272         PPCODE:
 273                 for (i=0; i<items-2; i++)
 274                   ST(i) = ST(i+2); /* pop first two args */
 275                 PUSHMARK(SP);
 276                 SP += items - 2;
 277                 PUTBACK;
 278                 i = call_pv(subname, flags);
 279                 SPAGAIN;
 280                 EXTEND(SP, 1);
 281                 mPUSHi(i);
 282
 283 void
 284 call_argv(subname, flags, ...)
 285         char* subname
 286         I32 flags
 287         PREINIT:
 288                 I32 i;
 289                 char *args[8];
 290         PPCODE:
 291                 if (items > 8)  /* play safe */
 292                   XSRETURN_UNDEF;
 293                 for (i=2; i<items; i++)
 294                   args[i-2] = SvPV_nolen(ST(i));
 295                 args[items-2] = NULL;
 296                 PUTBACK;
 297                 i = call_argv(subname, flags, args);
 298                 SPAGAIN;
 299                 EXTEND(SP, 1);
 300                 mPUSHi(i);
 301
 302 void
 303 call_method(methname, flags, ...)
 304         char* methname
 305         I32 flags
 306         PREINIT:
 307                 I32 i;
 308         PPCODE:
 309                 for (i=0; i<items-2; i++)
 310                   ST(i) = ST(i+2); /* pop first two args */
 311                 PUSHMARK(SP);
 312                 SP += items - 2;
 313                 PUTBACK;
 314                 i = call_method(methname, flags);
 315                 SPAGAIN;
 316                 EXTEND(SP, 1);
 317                 mPUSHi(i);
 318
 319 void
 320 call_sv_G_METHOD(sv, flags, ...)
 321         SV* sv
 322         I32 flags
 323         PREINIT:
 324                 I32 i;
 325         PPCODE:
 326                 for (i=0; i<items-2; i++)
 327                   ST(i) = ST(i+2); /* pop first two args */
 328                 PUSHMARK(SP);
 329                 SP += items - 2;
 330                 PUTBACK;
 331                 i = call_sv(sv, flags | G_METHOD);
 332                 SPAGAIN;
 333                 EXTEND(SP, 1);
 334                 mPUSHi(i);
 335
 336 void
 337 load_module(flags, name, version, ...)
 338         U32 flags
 339         SV *name
 340         SV *version
 341         CODE:
 342                 /* Both SV parameters are donated to the ops built inside
 343                    load_module, so we need to bump the refcounts.  */
 344                 Perl_load_module(aTHX_ flags, SvREFCNT_inc_simple(name),
 345                                  SvREFCNT_inc_simple(version), NULL);
 346
 347 =tests plan => 88
 348
 349 sub f
 350 {
 351   shift;
 352   unshift @_, 'b';
 353   pop @_;
 354   @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z';
 355 }
 356
 357 my $obj = bless [], 'Foo';
 358
 359 sub Foo::meth
 360 {
 361   return 'bad_self' unless @_ && ref $_[0] && ref($_[0]) eq 'Foo';
 362   shift;
 363   shift;
 364   unshift @_, 'b';
 365   pop @_;
 366   @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z';
 367 }
 368
 369 my $test;
 370
 371 for $test (
 372     # flags                      args           expected         description
 373     [ &Devel::PPPort::G_SCALAR,  [ ],           [ qw(y 1) ],     '0 args, G_SCALAR'  ],
 374     [ &Devel::PPPort::G_SCALAR,  [ qw(a p q) ], [ qw(y 1) ],     '3 args, G_SCALAR'  ],
 375     [ &Devel::PPPort::G_ARRAY,   [ ],           [ qw(x 1) ],     '0 args, G_ARRAY'   ],
 376     [ &Devel::PPPort::G_ARRAY,   [ qw(a p q) ], [ qw(b p x 3) ], '3 args, G_ARRAY'   ],
 377     [ &Devel::PPPort::G_DISCARD, [ ],           [ qw(0) ],       '0 args, G_DISCARD' ],
 378     [ &Devel::PPPort::G_DISCARD, [ qw(a p q) ], [ qw(0) ],       '3 args, G_DISCARD' ],
 379 )
 380 {
 381     my ($flags, $args, $expected, $description) = @$test;
 382     print "# --- $description ---\n";
 383     ok(eq_array( [ &Devel::PPPort::call_sv(\&f, $flags, @$args) ], $expected));
 384     ok(eq_array( [ &Devel::PPPort::call_sv(*f,  $flags, @$args) ], $expected));
 385     ok(eq_array( [ &Devel::PPPort::call_sv('f', $flags, @$args) ], $expected));
 386     ok(eq_array( [ &Devel::PPPort::call_pv('f', $flags, @$args) ], $expected));
 387     ok(eq_array( [ &Devel::PPPort::call_argv('f', $flags, @$args) ], $expected));
 388     ok(eq_array( [ &Devel::PPPort::eval_sv("f(qw(@$args))", $flags) ], $expected));
 389     ok(eq_array( [ &Devel::PPPort::call_method('meth', $flags, $obj, @$args) ], $expected));
 390     ok(eq_array( [ &Devel::PPPort::call_sv_G_METHOD('meth', $flags, $obj, @$args) ], $expected));
 391 };
 392
 393 is(&Devel::PPPort::eval_pv('f()', 0), 'y');
 394 is(&Devel::PPPort::eval_pv('f(qw(a b c))', 0), 'y');
 395
 396 is(!defined $::{'less::'}, 1, "Hadn't loaded less yet");
 397 Devel::PPPort::load_module(0, "less", undef);
 398 is(defined $::{'less::'}, 1, "Have now loaded less");
 399
 400 ok(eval { Devel::PPPort::eval_pv('die', 0); 1 });
 401 ok(!eval { Devel::PPPort::eval_pv('die', 1); 1 });
 402 ok($@ =~ /^Died at \(eval [0-9]+\) line 1\.\n$/);
 403 ok(eval { $@ = 'string1'; Devel::PPPort::eval_pv('', 0); 1 });
 404 ok(eval { $@ = 'string1'; Devel::PPPort::eval_pv('', 1); 1 });
 405 ok(eval { $@ = 'string1'; Devel::PPPort::eval_pv('$@ = "string2"', 0); 1 });
 406 ok(eval { $@ = 'string1'; Devel::PPPort::eval_pv('$@ = "string2"', 1); 1 });
 407 ok(eval { $@ = 'string1'; Devel::PPPort::eval_pv('$@ = "string2"; die "string3"', 0); 1 });
 408 ok(!eval { $@ = 'string1'; Devel::PPPort::eval_pv('$@ = "string2"; die "string3"', 1); 1 });
 409 ok($@ =~ /^string3 at \(eval [0-9]+\) line 1\.\n$/);
 410 ok(!eval { Devel::PPPort::eval_pv('die False->new', 1); 1 }, 'check false value is rethrown');
 411
 412 if (ivers($]) >= ivers('5.007003') or (ivers($]) >= ivers('5.006001') and ivers($]) < ivers('5.007'))) {
 413     my $hashref = { key => 'value' };
 414     is(eval { Devel::PPPort::eval_pv('die $hashref', 1); 1 }, undef, 'check plain hashref is rethrown');
 415     is(ref($@), 'HASH', 'check $@ is hashref') and
 416         is($@->{key}, 'value', 'check $@ hashref has correct value');
 417
 418     my $false = False->new;
 419     ok(!$false);
 420     is(eval { Devel::PPPort::eval_pv('die $false', 1); 1 }, undef, 'check false objects are rethrown');
 421     is(ref($@), 'False', 'check that $@ contains False object');
 422     is("$@", "$false", 'check we got the expected object');
 423 } else {
 424     skip 'skip: no support for references in $@', 7;
 425 }
 426
 427 ok(eval { Devel::PPPort::eval_sv('die', 0); 1 });
 428 ok(!eval { Devel::PPPort::eval_sv('die', &Devel::PPPort::G_RETHROW); 1 });
 429 ok($@ =~ /^Died at \(eval [0-9]+\) line 1\.\n$/);
 430 ok(eval { $@ = 'string1'; Devel::PPPort::eval_sv('', 0); 1 });
 431 ok(eval { $@ = 'string1'; Devel::PPPort::eval_sv('', &Devel::PPPort::G_RETHROW); 1 });
 432 ok(eval { $@ = 'string1'; Devel::PPPort::eval_sv('$@ = "string2"', 0); 1 });
 433 ok(eval { $@ = 'string1'; Devel::PPPort::eval_sv('$@ = "string2"', &Devel::PPPort::G_RETHROW); 1 });
 434 ok(eval { $@ = 'string1'; Devel::PPPort::eval_sv('$@ = "string2"; die "string3"', 0); 1 });
 435 ok(!eval { $@ = 'string1'; Devel::PPPort::eval_sv('$@ = "string2"; die "string3"', &Devel::PPPort::G_RETHROW); 1 });
 436 ok($@ =~ /^string3 at \(eval [0-9]+\) line 1\.\n$/);
 437 ok(!eval { Devel::PPPort::eval_sv('die False->new', &Devel::PPPort::G_RETHROW); 1 }, 'check false value is rethrown');
 438
 439 if (ivers($]) >= ivers('5.007003') or (ivers($]) >= ivers('5.006001') and ivers($]) < ivers('5.007'))) {
 440     my $hashref = { key => 'value' };
 441     is(eval { Devel::PPPort::eval_sv('die $hashref', &Devel::PPPort::G_RETHROW); 1 }, undef, 'check plain hashref is rethrown');
 442     is(ref($@), 'HASH', 'check $@ is hashref') and
 443         is($@->{key}, 'value', 'check $@ hashref has correct value');
 444
 445     my $false = False->new;
 446     ok(!$false);
 447     is(eval { Devel::PPPort::eval_sv('die $false', &Devel::PPPort::G_RETHROW); 1 }, undef, 'check false objects are rethrown');
 448     is(ref($@), 'False', 'check that $@ contains False object');
 449     is("$@", "$false", 'check we got the expected object');
 450 } else {
 451     skip 'skip: no support for references in $@', 7;
 452 }
 453
 454 {
 455     package False;
 456     use overload bool => sub { 0 }, '""' => sub { 'Foo' };
 457     sub new { bless {}, shift }
 458 }