[Bast-commits] r4380 - in trunk/Devel-BeginLift: . t

[nothingmuch at dev.catalyst.perl.org]

Author: nothingmuch
Date: 2008-05-12 10:16:29 +0100 (Mon, 12 May 2008)
New Revision: 4380

Modified:
   trunk/Devel-BeginLift/BeginLift.xs
   trunk/Devel-BeginLift/t/generate.t
Log:
disabled code for B::OP arguments, not finished (no api yet)

Modified: trunk/Devel-BeginLift/BeginLift.xs
===================================================================
--- trunk/Devel-BeginLift/BeginLift.xs	2008-05-11 19:03:27 UTC (rev 4379)
+++ trunk/Devel-BeginLift/BeginLift.xs	2008-05-12 09:16:29 UTC (rev 4380)
@@ -17,9 +17,11 @@
 /* replacement PL_check entersub entry */
 
 STATIC OP *dbl_ck_entersub(pTHX_ OP *o) {
+  dSP;
   OP *kid;
   OP *last;
   OP *curop;
+  OP *saved_next;
   HV *stash;
   I32 type = o->op_type;
   SV *sv;
@@ -72,28 +74,69 @@
 
   /* shamelessly lifted from fold_constants in op.c */
 
-  stack_save = PL_stack_sp;
+  stack_save = SP;
+
   curop = LINKLIST(o);
-  o->op_next = 0;
-  PL_op = curop;
+
+  if (0) { /* call as macro */
+    OP *arg;
+    OP *gv;
+    /* this means the argument pushing ops are not executed, only the GV to
+     * resolve the call is, and B::OP objects will be made of all the opcodes
+     * */
+    PUSHMARK(SP); /* push a mark for the arguments */
+
+    /* push an arg for every sibling op */
+    for ( arg = curop->op_sibling; arg->op_sibling; arg = arg->op_sibling ) {
+      XPUSHs(sv_bless(newRV_inc(newSViv(PTR2IV(arg))), gv_stashpv("B::LISTOP", 0)));
+    }
+
+    /* find the last non null before the lifted entersub */
+    for ( kid = curop; kid->op_next != o; kid = kid->op_next ) {
+      if ( kid->op_type == OP_GV )
+          gv = kid;
+    }
+
+    PL_op = gv; /* make the call to our sub without evaluating the arg ops */
+  } else {
+    PL_op = curop;
+  }
+
+  /* stop right after the call */
+  saved_next = o->op_next;
+  o->op_next = NULL;
+
+  PUTBACK;
+  SAVETMPS;
   CALLRUNOPS(aTHX);
+  SPAGAIN;
 
-  if (PL_stack_sp > stack_save) { /* sub returned something */
-    sv = *(PL_stack_sp--);
+  if (SP > stack_save) { /* sub returned something */
+    sv = POPs;
     if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
       pad_swipe(o->op_targ,  FALSE);
     else if (SvTEMP(sv)) {      /* grab mortal temp? */
       (void)SvREFCNT_inc(sv);
       SvTEMP_off(sv);
     }
-    op_free(o);
+
+    if (SvROK(sv) && sv_derived_from(sv, "B::OP")) {
+      OP *new = INT2PTR(OP *,SvIV((SV *)SvRV(sv)));
+      new->op_sibling = NULL;
+
+      /* FIXME this is bullshit */
+      if ( (PL_opargs[new->op_type] & OA_CLASS_MASK) != OA_SVOP ) {
+        new->op_next = saved_next;
+      } else {
+        new->op_next = new;
+      }
+
+      return new;
+    }
+
     if (type == OP_RV2GV)
       return newGVOP(OP_GV, 0, (GV*)sv);
 
-    if (SvROK(sv) && sv_derived_from(sv, "B::OP"))
-        /* taken from B's typemap file, T_OP_OBJ */
-        return INT2PTR(OP *,SvIV((SV *)SvRV(sv)));
-
     return newSVOP(OP_CONST, 0, sv);
   } else {
     /* this bit not lifted, handles the 'sub doesn't return stuff' case

Modified: trunk/Devel-BeginLift/t/generate.t
===================================================================
--- trunk/Devel-BeginLift/t/generate.t	2008-05-11 19:03:27 UTC (rev 4379)
+++ trunk/Devel-BeginLift/t/generate.t	2008-05-12 09:16:29 UTC (rev 4380)
@@ -2,18 +2,43 @@
 use warnings;
 use Test::More;
 
+use B::Utils;
+
 BEGIN {
     plan skip_all => "B::Generate required" unless eval { require B::Generate };
     plan 'no_plan';
 }
 
-sub foo { 
+sub foo {
     B::SVOP->new("const", 0, 42);
 }
 
-use Devel::BeginLift qw(foo);
+sub gorch ($) {
+    my $meth = ( $_[0]->kids )[-1]->sv->object_2svref;
+    $$meth = "other";
+    $_[0];
+}
 
+use Devel::BeginLift qw(foo gorch);
+
 sub bar { 7 + foo() }
-
 is( bar(), 49, "optree injected" );
 
+sub blah { foo(31) }
+is(blah(), 42, "optree injected" );;
+
+sub meth { 3 }
+
+sub other { 42 }
+
+__END__
+
+my $obj = bless {};
+sub oink { gorch $obj->meth; }
+
+is( oink(), 42, "modify method call");
+
+my @args = ( 1 .. 3 );
+sub ploink { gorch $obj->meth(1, @args); }
+is( ploink(), 42, "modify method call with args");
+