File Coverage

blib/lib/Object/Lexical.pm

Criterion	Covered	Total	%
statement	94	107	87.8
branch	15	26	57.6
condition	12	21	57.1
subroutine	13	14	92.8
pod	0	2	0.0
total	134	170	78.8

package Object::Lexical;

use 5.008;
use strict;
use warnings;

our $VERSION = '0.02';

use PadWalker;

my $counter = 0;

my $opt_wrap = 1;
my $opt_export = 1;
my $opt_nonlex = 1;

my %methods = ();

sub instance {

  # create a new object instance with its own stash from an existing object

  my $type = shift() || DB::_ext_fetch_args() || caller();

  my $package = sprintf 'Object::Lexical::X%09d', $counter++;

  # move methods into the new package from the symbol table. this is a destructive copy -
  # methods will need to be created again. this way, each copy has its own
  # seperate lexical data.

  no strict 'refs';

  if($opt_nonlex) {
    foreach my $x (keys %{$type.'::'}) {
      # no warnings 'redefine';
      next if $x eq 'new' or $x eq 'DESTROY' or $x eq 'instance' or $x eq 'method';
      next unless defined &{$type.'::'.$x};
      my $source = $type.'::'.$x;
      my $target = $package.'::'.$x;
      my $code = \&{$source};
      my $thisglob = $package.'::this';
      if($opt_wrap) {
        *{$target} = sub { *{$thisglob} = shift; goto &$code; };
      } else {
        *{$target} = $code;
      }
      undef *{$source};
    }
  }

  # move lexically defined subs, too

  my $pad = PadWalker::peek_my(1);
  foreach my $x (keys %$pad) {
    my $code = ${$pad->{$x}};
    next unless ref($code) eq 'CODE';
    substr($x, 0, 1, ''); # remove sigil
    my $target = $package.'::'.$x;
    my $thisglob = $package.'::this';
    if($opt_wrap) {
      *{$target} = sub { *{$thisglob} = shift; goto &$code; };
    } else {
      *{$target} = $code;
    }
  }

  # and anything defined with method()

  foreach my $x (keys %methods) {
    my $code = $methods{$x};
    my $target = $package.'::'.$x;
    my $thisglob = $package.'::this';
    if($opt_wrap) {
      *{$target} = sub { *{$thisglob} = shift; goto &$code; };
    } else {
      *{$target} = $code;
    }
  }

  # inherit whomever our client is inheriting.
  # count references for destruction - barrowed from Class::Object

  push @{$package.'::ISA'}, $type;
  ${$package.'::_count'} = 1;

  *{$package.'::DESTROY'} = sub {
     my $obj_class = ref shift;
     ${$obj_class.'::_count'}--;
     if( ${$obj_class.'::_count'} == 0 ) {
        undef %{$obj_class.'::'};
     }
  };

  # bless \(my $foo), $package;
  bless \%{$package.'::'}, $package;

}

sub method (&*) {
  my $caller = caller;
  my $code = shift;
  my $name = shift;
  $methods{$name} = $code;
  # *{$caller.'::'.$name} = $code;
}

sub import {

  # cleaning up
  %methods = ();

  # default options
  $opt_wrap = 1;   # sub wrapper to read $this automatically
  $opt_export = 1; # export instance() and method()
  $opt_nonlex = 1; # move non-lexically defined methods too

  # options
  foreach(@_) {
    $opt_wrap = 0   if $_ eq 'no_wrap' or $_ eq 'nowrap';
    $opt_export = 0 if $_ eq 'no_export' or $_ eq 'noexport';
    $opt_nonlex = 0 if $_ eq 'no_nonlex' or $_ eq 'nononlex';
  }

  # export
  if($opt_export) {
    no strict 'refs';
    my $caller = caller;
    *{$caller.'::instance'} = *instance;
    *{$caller.'::method'} = *method;
  }

  1;

}

package DB;

sub _ext_fetch_args {
  our @args;
  (undef, undef) = caller(2);
  return undef unless @args;
  return $args[0];
}

1;

__END__