ext/Devel/PPPort/parts/inc/call

   1 ################################################################################
   2 ##
   3 ##  $Revision: 19 $
   4 ##  $Author: mhx $
   5 ##  $Date: 2009/01/23 18:27:48 +0100 $
   6 ##
   7 ################################################################################
   8 ##
   9 ##  Version 3.x, Copyright (C) 2004-2009, Marcus Holland-Moritz.
  10 ##  Version 2.x, Copyright (C) 2001, Paul Marquess.
  11 ##  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
  12 ##
  13 ##  This program is free software; you can redistribute it and/or
  14 ##  modify it under the same terms as Perl itself.
  15 ##
  16 ################################################################################
  17
  18 =provides
  19
  20 eval_pv
  21 eval_sv
  22 call_sv
  23 call_pv
  24 call_argv
  25 call_method
  26 load_module
  27 vload_module
  28 G_METHOD
  29
  30 =implementation
  31
  32 /* Replace: 1 */
  33 __UNDEFINED__  call_sv       perl_call_sv
  34 __UNDEFINED__  call_pv       perl_call_pv
  35 __UNDEFINED__  call_argv     perl_call_argv
  36 __UNDEFINED__  call_method   perl_call_method
  37
  38 __UNDEFINED__  eval_sv       perl_eval_sv
  39 /* Replace: 0 */
  40
  41 __UNDEFINED__ PERL_LOADMOD_DENY         0x1
  42 __UNDEFINED__ PERL_LOADMOD_NOIMPORT     0x2
  43 __UNDEFINED__ PERL_LOADMOD_IMPORT_OPS   0x4
  44
  45 #ifndef G_METHOD
  46 # define G_METHOD               64
  47 # ifdef call_sv
  48 #  undef call_sv
  49 # endif
  50 # if { VERSION < 5.6.0 }
  51 #  define call_sv(sv, flags)  ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \
  52                                 (flags) & ~G_METHOD) : perl_call_sv(sv, flags))
  53 # else
  54 #  define call_sv(sv, flags)  ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \
  55                                 (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags))
  56 # endif
  57 #endif
  58
  59 /* Replace perl_eval_pv with eval_pv */
  60
  61 #ifndef eval_pv
  62 #if { NEED eval_pv }
  63
  64 SV*
  65 eval_pv(char *p, I32 croak_on_error)
  66 {
  67     dSP;
  68     SV* sv = newSVpv(p, 0);
  69
  70     PUSHMARK(sp);
  71     eval_sv(sv, G_SCALAR);
  72     SvREFCNT_dec(sv);
  73
  74     SPAGAIN;
  75     sv = POPs;
  76     PUTBACK;
  77
  78     if (croak_on_error && SvTRUE(GvSV(errgv)))
  79         croak(SvPVx(GvSV(errgv), na));
  80
  81     return sv;
  82 }
  83
  84 #endif
  85 #endif
  86
  87 #ifndef vload_module
  88 #if { NEED vload_module }
  89
  90 void
  91 vload_module(U32 flags, SV *name, SV *ver, va_list *args)
  92 {
  93     dTHR;
  94     dVAR;
  95     OP *veop, *imop;
  96
  97     OP * const modname = newSVOP(OP_CONST, 0, name);
  98     /* 5.005 has a somewhat hacky force_normal that doesn't croak on
  99        SvREADONLY() if PL_compling is true. Current perls take care in
 100        ck_require() to correctly turn off SvREADONLY before calling
 101        force_normal_flags(). This seems a better fix than fudging PL_compling
 102      */
 103     SvREADONLY_off(((SVOP*)modname)->op_sv);
 104     modname->op_private |= OPpCONST_BARE;
 105     if (ver) {
 106         veop = newSVOP(OP_CONST, 0, ver);
 107     }
 108     else
 109         veop = NULL;
 110     if (flags & PERL_LOADMOD_NOIMPORT) {
 111         imop = sawparens(newNULLLIST());
 112     }
 113     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
 114         imop = va_arg(*args, OP*);
 115     }
 116     else {
 117         SV *sv;
 118         imop = NULL;
 119         sv = va_arg(*args, SV*);
 120         while (sv) {
 121             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
 122             sv = va_arg(*args, SV*);
 123         }
 124     }
 125     {
 126         const line_t ocopline = PL_copline;
 127         COP * const ocurcop = PL_curcop;
 128         const int oexpect = PL_expect;
 129
 130 #if { VERSION >= 5.004 }
 131         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
 132                 veop, modname, imop);
 133 #else
 134         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(),
 135                 modname, imop);
 136 #endif
 137         PL_expect = oexpect;
 138         PL_copline = ocopline;
 139         PL_curcop = ocurcop;
 140     }
 141 }
 142
 143 #endif
 144 #endif
 145
 146 #ifndef load_module
 147 #if { NEED load_module }
 148
 149 void
 150 load_module(U32 flags, SV *name, SV *ver, ...)
 151 {
 152     va_list args;
 153     va_start(args, ver);
 154     vload_module(flags, name, ver, &args);
 155     va_end(args);
 156 }
 157
 158 #endif
 159 #endif
 160
 161 =xsinit
 162
 163 #define NEED_eval_pv
 164 #define NEED_load_module
 165 #define NEED_vload_module
 166
 167 =xsubs
 168
 169 I32
 170 G_SCALAR()
 171         CODE:
 172                 RETVAL = G_SCALAR;
 173         OUTPUT:
 174                 RETVAL
 175
 176 I32
 177 G_ARRAY()
 178         CODE:
 179                 RETVAL = G_ARRAY;
 180         OUTPUT:
 181                 RETVAL
 182
 183 I32
 184 G_DISCARD()
 185         CODE:
 186                 RETVAL = G_DISCARD;
 187         OUTPUT:
 188                 RETVAL
 189
 190 void
 191 eval_sv(sv, flags)
 192         SV* sv
 193         I32 flags
 194         PREINIT:
 195                 I32 i;
 196         PPCODE:
 197                 PUTBACK;
 198                 i = eval_sv(sv, flags);
 199                 SPAGAIN;
 200                 EXTEND(SP, 1);
 201                 mPUSHi(i);
 202
 203 void
 204 eval_pv(p, croak_on_error)
 205         char* p
 206         I32 croak_on_error
 207         PPCODE:
 208                 PUTBACK;
 209                 EXTEND(SP, 1);
 210                 PUSHs(eval_pv(p, croak_on_error));
 211
 212 void
 213 call_sv(sv, flags, ...)
 214         SV* sv
 215         I32 flags
 216         PREINIT:
 217                 I32 i;
 218         PPCODE:
 219                 for (i=0; i<items-2; i++)
 220                   ST(i) = ST(i+2); /* pop first two args */
 221                 PUSHMARK(SP);
 222                 SP += items - 2;
 223                 PUTBACK;
 224                 i = call_sv(sv, flags);
 225                 SPAGAIN;
 226                 EXTEND(SP, 1);
 227                 mPUSHi(i);
 228
 229 void
 230 call_pv(subname, flags, ...)
 231         char* subname
 232         I32 flags
 233         PREINIT:
 234                 I32 i;
 235         PPCODE:
 236                 for (i=0; i<items-2; i++)
 237                   ST(i) = ST(i+2); /* pop first two args */
 238                 PUSHMARK(SP);
 239                 SP += items - 2;
 240                 PUTBACK;
 241                 i = call_pv(subname, flags);
 242                 SPAGAIN;
 243                 EXTEND(SP, 1);
 244                 mPUSHi(i);
 245
 246 void
 247 call_argv(subname, flags, ...)
 248         char* subname
 249         I32 flags
 250         PREINIT:
 251                 I32 i;
 252                 char *args[8];
 253         PPCODE:
 254                 if (items > 8)  /* play safe */
 255                   XSRETURN_UNDEF;
 256                 for (i=2; i<items; i++)
 257                   args[i-2] = SvPV_nolen(ST(i));
 258                 args[items-2] = NULL;
 259                 PUTBACK;
 260                 i = call_argv(subname, flags, args);
 261                 SPAGAIN;
 262                 EXTEND(SP, 1);
 263                 mPUSHi(i);
 264
 265 void
 266 call_method(methname, flags, ...)
 267         char* methname
 268         I32 flags
 269         PREINIT:
 270                 I32 i;
 271         PPCODE:
 272                 for (i=0; i<items-2; i++)
 273                   ST(i) = ST(i+2); /* pop first two args */
 274                 PUSHMARK(SP);
 275                 SP += items - 2;
 276                 PUTBACK;
 277                 i = call_method(methname, flags);
 278                 SPAGAIN;
 279                 EXTEND(SP, 1);
 280                 mPUSHi(i);
 281
 282 void
 283 call_sv_G_METHOD(sv, flags, ...)
 284         SV* sv
 285         I32 flags
 286         PREINIT:
 287                 I32 i;
 288         PPCODE:
 289                 for (i=0; i<items-2; i++)
 290                   ST(i) = ST(i+2); /* pop first two args */
 291                 PUSHMARK(SP);
 292                 SP += items - 2;
 293                 PUTBACK;
 294                 i = call_sv(sv, flags | G_METHOD);
 295                 SPAGAIN;
 296                 EXTEND(SP, 1);
 297                 mPUSHi(i);
 298
 299 void
 300 load_module(flags, name, version, ...)
 301         U32 flags
 302         SV *name
 303         SV *version
 304         CODE:
 305                 /* Both SV parameters are donated to the ops built inside
 306                    load_module, so we need to bump the refcounts.  */
 307                 Perl_load_module(aTHX_ flags, SvREFCNT_inc_simple(name),
 308                                  SvREFCNT_inc_simple(version), NULL);
 309
 310 =tests plan => 52
 311
 312 sub eq_array
 313 {
 314   my($a, $b) = @_;
 315   join(':', @$a) eq join(':', @$b);
 316 }
 317
 318 sub f
 319 {
 320   shift;
 321   unshift @_, 'b';
 322   pop @_;
 323   @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z';
 324 }
 325
 326 my $obj = bless [], 'Foo';
 327
 328 sub Foo::meth
 329 {
 330   return 'bad_self' unless @_ && ref $_[0] && ref($_[0]) eq 'Foo';
 331   shift;
 332   shift;
 333   unshift @_, 'b';
 334   pop @_;
 335   @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z';
 336 }
 337
 338 my $test;
 339
 340 for $test (
 341     # flags                      args           expected         description
 342     [ &Devel::PPPort::G_SCALAR,  [ ],           [ qw(y 1) ],     '0 args, G_SCALAR'  ],
 343     [ &Devel::PPPort::G_SCALAR,  [ qw(a p q) ], [ qw(y 1) ],     '3 args, G_SCALAR'  ],
 344     [ &Devel::PPPort::G_ARRAY,   [ ],           [ qw(x 1) ],     '0 args, G_ARRAY'   ],
 345     [ &Devel::PPPort::G_ARRAY,   [ qw(a p q) ], [ qw(b p x 3) ], '3 args, G_ARRAY'   ],
 346     [ &Devel::PPPort::G_DISCARD, [ ],           [ qw(0) ],       '0 args, G_DISCARD' ],
 347     [ &Devel::PPPort::G_DISCARD, [ qw(a p q) ], [ qw(0) ],       '3 args, G_DISCARD' ],
 348 )
 349 {
 350     my ($flags, $args, $expected, $description) = @$test;
 351     print "# --- $description ---\n";
 352     ok(eq_array( [ &Devel::PPPort::call_sv(\&f, $flags, @$args) ], $expected));
 353     ok(eq_array( [ &Devel::PPPort::call_sv(*f,  $flags, @$args) ], $expected));
 354     ok(eq_array( [ &Devel::PPPort::call_sv('f', $flags, @$args) ], $expected));
 355     ok(eq_array( [ &Devel::PPPort::call_pv('f', $flags, @$args) ], $expected));
 356     ok(eq_array( [ &Devel::PPPort::call_argv('f', $flags, @$args) ], $expected));
 357     ok(eq_array( [ &Devel::PPPort::eval_sv("f(qw(@$args))", $flags) ], $expected));
 358     ok(eq_array( [ &Devel::PPPort::call_method('meth', $flags, $obj, @$args) ], $expected));
 359     ok(eq_array( [ &Devel::PPPort::call_sv_G_METHOD('meth', $flags, $obj, @$args) ], $expected));
 360 };
 361
 362 ok(&Devel::PPPort::eval_pv('f()', 0), 'y');
 363 ok(&Devel::PPPort::eval_pv('f(qw(a b c))', 0), 'y');
 364
 365 ok(!defined $::{'less::'}, 1, "Hadn't loaded less yet");
 366 Devel::PPPort::load_module(0, "less", undef);
 367 ok(defined $::{'less::'}, 1, "Have now loaded less");