ext/Devel/PPPort/parts/inc/call

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