[Bast-commits] r3522 - in trunk: . Devel-BeginLift Devel-BeginLift/lib Devel-BeginLift/lib/Devel

[matthewt at dev.catalyst.perl.org]

Author: matthewt
Date: 2007-06-24 12:13:13 +0100 (Sun, 24 Jun 2007)
New Revision: 3522

Added:
   trunk/Devel-BeginLift/
   trunk/Devel-BeginLift/lib/
   trunk/Devel-BeginLift/lib/Devel/
   trunk/Devel-BeginLift/lib/Devel/BeginLift.pm
   trunk/Devel-BeginLift/test.pl
Log:
initial import, very rough

Added: trunk/Devel-BeginLift/lib/Devel/BeginLift.pm
===================================================================
--- trunk/Devel-BeginLift/lib/Devel/BeginLift.pm	                        (rev 0)
+++ trunk/Devel-BeginLift/lib/Devel/BeginLift.pm	2007-06-24 11:13:13 UTC (rev 3522)
@@ -0,0 +1,149 @@
+package Devel::BeginLift;
+
+use strict;
+use warnings;
+
+use vars qw(%lift);
+
+use Inline C => <<'EOC';
+#include <stdio.h>
+#include <string.h>
+#include "proto.h"
+
+/* lifted from op.c (w/linklist -> Perl_linklist) */
+
+#define LINKLIST(o) ((o)->op_next ? (o)->op_next : Perl_linklist((OP*)o))
+
+/* pointer to old PL_check entersub entry to be populated in init */
+
+STATIC OP *(*dbl_old_ck_entersub)(pTHX_ OP *op);
+
+/* replacement PL_check entersub entry */
+
+STATIC OP *dbl_ck_entersub(pTHX_ OP *o) {
+  OP *kid;
+  OP *last;
+  OP *curop;
+  HV *stash;
+  I32 type = o->op_type;
+  SV *sv;
+  char* stack_save;
+  HV* to_lift;
+  SV** to_lift_pack_ref;
+  HV* to_lift_pack_hash;
+  SV** to_lift_flag_ref;
+
+  o = dbl_old_ck_entersub(aTHX_ o); /* let the original do its job */
+
+  kid = cUNOPo->op_first;
+
+  if (kid->op_type != OP_NULL) /* pushmark for method call ... */
+    return o;
+
+  last = kLISTOP->op_last;
+
+  if (last->op_type != OP_NULL) /* not what we expected */
+    return o;
+
+  kid = cUNOPx(last)->op_first;
+
+  if (kid->op_type != OP_GV) /* not a GV so ignore */
+    return o;
+
+  stash = GvSTASH(kGVOP_gv);
+
+  /* printf("Calling GV %s -> %s\n",
+    HvNAME(stash), GvNAME(kGVOP_gv)); */
+
+  to_lift = get_hv("Devel::BeginLift::lift", FALSE);
+
+  if (!to_lift)
+    return o;
+
+  to_lift_pack_ref = hv_fetch(to_lift, HvNAME(stash), strlen(HvNAME(stash)),
+                               FALSE);
+
+  if (!to_lift_pack_ref || !SvROK(*to_lift_pack_ref))
+    return o; /* not a hashref */
+
+  to_lift_pack_hash = (HV*) SvRV(*to_lift_pack_ref);
+
+  to_lift_flag_ref = hv_fetch(to_lift_pack_hash, GvNAME(kGVOP_gv),
+                                strlen(GvNAME(kGVOP_gv)), FALSE);
+
+  if (!to_lift_flag_ref || !SvTRUE(*to_lift_flag_ref))
+    return o;
+
+  /* shamelessly lifted from fold_constants in op.c */
+
+  stack_save = PL_stack_sp;
+  curop = LINKLIST(o);
+  o->op_next = 0;
+  PL_op = curop;
+  CALLRUNOPS(aTHX);
+
+  if (PL_stack_sp > stack_save) { /* sub returned something */
+    sv = *(PL_stack_sp--);
+    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 (type == OP_RV2GV)
+      return newGVOP(OP_GV, 0, (GV*)sv);
+    return newSVOP(OP_CONST, 0, sv);
+  } else {
+    /* this bit not lifted, handles the 'sub doesn't return stuff' case
+       which fold_constants can ignore */
+    op_free(o);
+    return newSVOP(OP_CONST, 0, &PL_sv_undef);
+  }
+}
+
+static int initialized = 0;
+
+void setup() {
+  if (!initialized++) {
+    dbl_old_ck_entersub = PL_check[OP_ENTERSUB];
+    PL_check[OP_ENTERSUB] = dbl_ck_entersub;
+  }
+}
+
+void teardown() {
+  /* ensure we only uninit when number of teardown calls matches 
+     number of setup calls */
+  if (initialized && !--initialized) {
+    PL_check[OP_ENTERSUB] = dbl_old_ck_entersub;
+  }
+}
+EOC
+
+# C code done, now for the perl.
+
+sub import {
+  my ($class, @args) = @_;
+  my $target = caller;
+  $class->setup_for($target => \@args);
+}
+
+sub unimport {
+  my ($class) = @_;
+  my $target = caller;
+  $class->teardown_for($target);
+}
+
+sub setup_for {
+  my ($class, $target, $args) = @_;
+  setup();
+  $lift{$target}{$_} = 1 for @$args;
+}
+
+sub teardown_for {
+  my ($class, $target) = @_;
+  delete $lift{$target};
+  teardown();
+}
+
+1;

Added: trunk/Devel-BeginLift/test.pl
===================================================================
--- trunk/Devel-BeginLift/test.pl	                        (rev 0)
+++ trunk/Devel-BeginLift/test.pl	2007-06-24 11:13:13 UTC (rev 3522)
@@ -0,0 +1,21 @@
+use Devel::BeginLift 'foo';
+
+use vars qw($int);
+
+BEGIN { $int = 1 }
+
+sub foo { warn "foo: $_[0]\n"; $int++; 4; }
+
+sub bar { warn "bar: $_[0]\n"; }
+
+warn "yep\n";
+
+warn foo("foo");
+
+warn bar("bar");
+
+warn "yep2: $int\n";
+
+no Devel::BeginLift;
+
+foo();