ext/Devel/PPPort/parts/inc/call

   1 ################################################################################
   2 ##
   3 ##  $Revision: 7 $
   4 ##  $Author: mhx $
   5 ##  $Date: 2004/08/13 12:45:53 +0200 $
   6 ##
   7 ################################################################################
   8 ##
   9 ##  Version 3.x, Copyright (C) 2004, 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
  27 =implementation
  28
  29 /* Replace: 1 */
  30 __UNDEFINED__  call_sv       perl_call_sv
  31 __UNDEFINED__  call_pv       perl_call_pv
  32 __UNDEFINED__  call_argv     perl_call_argv
  33 __UNDEFINED__  call_method   perl_call_method
  34
  35 __UNDEFINED__  eval_sv       perl_eval_sv
  36 /* Replace: 0 */
  37
  38 /* Replace perl_eval_pv with eval_pv */
  39 /* eval_pv depends on eval_sv */
  40
  41 #ifndef eval_pv
  42 #if { NEED eval_pv }
  43
  44 SV*
  45 eval_pv(char *p, I32 croak_on_error)
  46 {
  47     dSP;
  48     SV* sv = newSVpv(p, 0);
  49
  50     PUSHMARK(sp);
  51     eval_sv(sv, G_SCALAR);
  52     SvREFCNT_dec(sv);
  53
  54     SPAGAIN;
  55     sv = POPs;
  56     PUTBACK;
  57
  58     if (croak_on_error && SvTRUE(GvSV(errgv)))
  59         croak(SvPVx(GvSV(errgv), na));
  60
  61     return sv;
  62 }
  63
  64 #endif
  65 #endif
  66
  67 =xsinit
  68
  69 #define NEED_eval_pv
  70
  71 =xsubs
  72
  73 I32
  74 G_SCALAR()
  75         CODE:
  76                 RETVAL = G_SCALAR;
  77         OUTPUT:
  78                 RETVAL
  79
  80 I32
  81 G_ARRAY()
  82         CODE:
  83                 RETVAL = G_ARRAY;
  84         OUTPUT:
  85                 RETVAL
  86
  87 I32
  88 G_DISCARD()
  89         CODE:
  90                 RETVAL = G_DISCARD;
  91         OUTPUT:
  92                 RETVAL
  93
  94 void
  95 eval_sv(sv, flags)
  96         SV* sv
  97         I32 flags
  98         PREINIT:
  99                 I32 i;
 100         PPCODE:
 101                 PUTBACK;
 102                 i = eval_sv(sv, flags);
 103                 SPAGAIN;
 104                 EXTEND(SP, 1);
 105                 PUSHs(sv_2mortal(newSViv(i)));
 106
 107 void
 108 eval_pv(p, croak_on_error)
 109         char* p
 110         I32 croak_on_error
 111         PPCODE:
 112                 PUTBACK;
 113                 EXTEND(SP, 1);
 114                 PUSHs(eval_pv(p, croak_on_error));
 115
 116 void
 117 call_sv(sv, flags, ...)
 118         SV* sv
 119         I32 flags
 120         PREINIT:
 121                 I32 i;
 122         PPCODE:
 123                 for (i=0; i<items-2; i++)
 124                   ST(i) = ST(i+2); /* pop first two args */
 125                 PUSHMARK(SP);
 126                 SP += items - 2;
 127                 PUTBACK;
 128                 i = call_sv(sv, flags);
 129                 SPAGAIN;
 130                 EXTEND(SP, 1);
 131                 PUSHs(sv_2mortal(newSViv(i)));
 132
 133 void
 134 call_pv(subname, flags, ...)
 135         char* subname
 136         I32 flags
 137         PREINIT:
 138                 I32 i;
 139         PPCODE:
 140                 for (i=0; i<items-2; i++)
 141                   ST(i) = ST(i+2); /* pop first two args */
 142                 PUSHMARK(SP);
 143                 SP += items - 2;
 144                 PUTBACK;
 145                 i = call_pv(subname, flags);
 146                 SPAGAIN;
 147                 EXTEND(SP, 1);
 148                 PUSHs(sv_2mortal(newSViv(i)));
 149
 150 void
 151 call_argv(subname, flags, ...)
 152         char* subname
 153         I32 flags
 154         PREINIT:
 155                 I32 i;
 156                 char *args[8];
 157         PPCODE:
 158                 if (items > 8)  /* play safe */
 159                   XSRETURN_UNDEF;
 160                 for (i=2; i<items; i++)
 161                   args[i-2] = SvPV_nolen(ST(i));
 162                 args[items-2] = NULL;
 163                 PUTBACK;
 164                 i = call_argv(subname, flags, args);
 165                 SPAGAIN;
 166                 EXTEND(SP, 1);
 167                 PUSHs(sv_2mortal(newSViv(i)));
 168
 169 void
 170 call_method(methname, flags, ...)
 171         char* methname
 172         I32 flags
 173         PREINIT:
 174                 I32 i;
 175         PPCODE:
 176                 for (i=0; i<items-2; i++)
 177                   ST(i) = ST(i+2); /* pop first two args */
 178                 PUSHMARK(SP);
 179                 SP += items - 2;
 180                 PUTBACK;
 181                 i = call_method(methname, flags);
 182                 SPAGAIN;
 183                 EXTEND(SP, 1);
 184                 PUSHs(sv_2mortal(newSViv(i)));
 185
 186 =tests plan => 44
 187
 188 sub eq_array
 189 {
 190   my($a, $b) = @_;
 191   join(':', @$a) eq join(':', @$b);
 192 }
 193
 194 sub f
 195 {
 196   shift;
 197   unshift @_, 'b';
 198   pop @_;
 199   @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z';
 200 }
 201
 202 my $obj = bless [], 'Foo';
 203
 204 sub Foo::meth
 205 {
 206   return 'bad_self' unless @_ && ref $_[0] && ref($_[0]) eq 'Foo';
 207   shift;
 208   shift;
 209   unshift @_, 'b';
 210   pop @_;
 211   @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z';
 212 }
 213
 214 my $test;
 215
 216 for $test (
 217     # flags                      args           expected         description
 218     [ &Devel::PPPort::G_SCALAR,  [ ],           [ qw(y 1) ],     '0 args, G_SCALAR'  ],
 219     [ &Devel::PPPort::G_SCALAR,  [ qw(a p q) ], [ qw(y 1) ],     '3 args, G_SCALAR'  ],
 220     [ &Devel::PPPort::G_ARRAY,   [ ],           [ qw(x 1) ],     '0 args, G_ARRAY'   ],
 221     [ &Devel::PPPort::G_ARRAY,   [ qw(a p q) ], [ qw(b p x 3) ], '3 args, G_ARRAY'   ],
 222     [ &Devel::PPPort::G_DISCARD, [ ],           [ qw(0) ],       '0 args, G_DISCARD' ],
 223     [ &Devel::PPPort::G_DISCARD, [ qw(a p q) ], [ qw(0) ],       '3 args, G_DISCARD' ],
 224 )
 225 {
 226     my ($flags, $args, $expected, $description) = @$test;
 227     print "# --- $description ---\n";
 228     ok(eq_array( [ &Devel::PPPort::call_sv(\&f, $flags, @$args) ], $expected));
 229     ok(eq_array( [ &Devel::PPPort::call_sv(*f,  $flags, @$args) ], $expected));
 230     ok(eq_array( [ &Devel::PPPort::call_sv('f', $flags, @$args) ], $expected));
 231     ok(eq_array( [ &Devel::PPPort::call_pv('f', $flags, @$args) ], $expected));
 232     ok(eq_array( [ &Devel::PPPort::call_argv('f', $flags, @$args) ], $expected));
 233     ok(eq_array( [ &Devel::PPPort::eval_sv("f(qw(@$args))", $flags) ], $expected));
 234     ok(eq_array( [ &Devel::PPPort::call_method('meth', $flags, $obj, @$args) ], $expected));
 235 };
 236
 237 ok(&Devel::PPPort::eval_pv('f()', 0), 'y');
 238 ok(&Devel::PPPort::eval_pv('f(qw(a b c))', 0), 'y');
 239