File Coverage

blib/lib/ImplicitThis.pm

Criterion	Covered	Total	%
statement	21	55	38.1
branch	0	10	0.0
condition	0	2	0.0
subroutine	7	10	70.0
pod	0	1	0.0
total	28	78	35.9

package ImplicitThis;

use 5.6.0;
use strict;

our $VERSION = '0.01_001';
$VERSION = eval $VERSION;  # see L

# ImplicitThis -
# Modify a package to implicitly take "this" as a first argument, and to access
# object fields by default.

# to use, in your code, do:

# use ImplicitThis; ImplicitThis::imply();

# does anyone know how to hand the CPU back after we finish loading, but take it
# again when whomever used us finishes loading?

sub import {
  my $callerpackage = caller;
  no strict 'refs';

  *{$callerpackage.'::caller'} = sub {
    my $lev = shift() || 0;
    # account for the ::imply() generated wrapper, and account for this function here
    $lev += 2;
    return CORE::caller($lev);
  };

}

sub imply {

  my $callerpackage = caller;

  no strict 'refs';
  no strict 'vars';
  no strict 'subs';

  # loop over symbols in their name table, finding things that are functions

  for $i (grep { defined &{$callerpackage.'::'.$_} } keys %{$callerpackage.'::'}) {

    next if $i eq 'new';
    next if $i eq 'caller';

    my $funname = $i;
    my $funfun = \&{$callerpackage.'::'.$i}; # reference to pre-modified code

    # make a new code reference. give it the same name. lexically bind it to the old reference.

    *{$callerpackage.'::'.$funname} = sub {
      my $this = shift;
      my $newcp = caller;

      if(substr($funname, 0, 1) eq '_') {
        # we're supposed to be private. see to the fact.
        caller(0) eq $callerpackage or
          die sprintf "Cannot invoke private method %s from outside %s",
            $funname, __PACKAGE__;
      }

      @ISA = @{$newcp.'::ISA'}; # become one of whatever called us

      # create a $this local that contains the pointer to the object the method
      # was called in. this lets people say things like: $this->get_foo();
      # XXX to emulate "normal" instance variable access, we could AUTOLOAD and
      # XXX treat $this->var as a method call, translating it to $this->{'var'}

      local *{$callerpackage.'::this'};
      *{$callerpackage.'::this'} = \$this;

      # give the same treatment to each instance variable: localize it for safety,
      # then make it an alias to the hash entry that contains the instance variable.

      my @fields = keys %$this;
      my $field;

      FIELDS:

        $field = shift @fields;

        local *{$callerpackage.'::'.$field};
        *{$callerpackage.'::'.$field} = \$this->{$field};

      goto FIELDS if(@fields);

      # goto &$funfun; # this wont work because it immediately restores all variables we localized
      # we just have to deal with a bogus stack frame lingering

      # invoke the code reference that we've secret replaced ourselves with.

      $funfun->(@_);

      # *now* local variables get restored

    }
  }
}

1;

1;
__END__