initial import, very rough

[p5sagit/Devel-BeginLift.git] / lib / Devel / BeginLift.pm

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;