File Coverage

blib/lib/Object/LocalVars.pm

Criterion	Covered	Total	%
statement	301	319	94.3
branch	80	98	81.6
condition	7	14	50.0
subroutine	44	45	97.7
pod	5	5	100.0
total	437	481	90.8

use 5.008;
use strict;
use warnings;

package Object::LocalVars;
# ABSTRACT: Outside-in objects with local aliasing of $self and object variables
our $VERSION = '0.21'; # VERSION

#--------------------------------------------------------------------------#
# Required modules
#--------------------------------------------------------------------------#

use Config;
use Carp;
use Scalar::Util 1.09 qw( weaken refaddr );

#--------------------------------------------------------------------------#
# Exporting -- wrap import so we can check for necessary warnings
#--------------------------------------------------------------------------#

use Exporter ();

our @EXPORT = qw(
    caller give_methods new BUILDALL CLONE DESTROY
    MODIFY_SCALAR_ATTRIBUTES MODIFY_CODE_ATTRIBUTES
);

sub import {

    # check if threads are available
    if( $Config{useithreads} ) {
        my $caller = caller(0);

        # Warn about sharing, but not for Test:: modules which always
        # share if any threads are enabled
        if ( $INC{'threads/shared.pm'} && ! $INC{'Test/Builder.pm'} ) {
            carp   "Warning: threads::shared is enabled, but $caller uses"
                 . " Object::LocalVars (which does not allow shared objects)";
        }
    }

    # Hand off the rest of the import
    goto &Exporter::import;
}

#--------------------------------------------------------------------------#
# Declarations
#--------------------------------------------------------------------------#

my (%public_methods, %protected_methods, %private_methods);

my %base_class_of;

my %prefixes_for;

#--------------------------------------------------------------------------#
# accessor_style
#--------------------------------------------------------------------------#

sub accessor_style {
    my (undef, $prefix) = @_;
    croak "Method accessor_style() requires a hash reference"
        if not ref $prefix eq 'HASH';
    my $class = caller(0);
    $prefixes_for{ $class } = $prefix;
}

#--------------------------------------------------------------------------#
# base_object
#--------------------------------------------------------------------------#

sub base_object {
    no strict 'refs';
    my (undef, $base) = @_;
    my $class = caller(0);
    $base_class_of{ $class } = $base;

    # import it if not already in @ISA
    if ( ! grep { $_ eq $base } @{$class."::ISA"} ) {
        push @{$class."::ISA"}, $base;
        $base =~ s{::}{/}g;
        $base .= ".pm";
        eval { require $base };
        croak $@ if $@ ne '';
    }

    # change to other form of new
    {
        no warnings 'redefine';
        *{$class."::new"} = \&_new_with_base;
    }

}

#--------------------------------------------------------------------------#
# caller
#--------------------------------------------------------------------------#

# custom caller routine ignores this module and keeps looking upwards.
# can't use Sub::Uplevel due to an off-by-one issue in the current version

use subs 'caller';
sub caller {
    my ($uplevel) = @_;
    $uplevel ||= 0;
    $uplevel++ while ( (CORE::caller($uplevel+1))[0] eq __PACKAGE__ );
    my @caller = CORE::caller($uplevel+1);
    return wantarray ? ( @_ ? @caller : @caller[0 .. 2] ) : $caller[0];
}

#--------------------------------------------------------------------------#
# give_methods
#--------------------------------------------------------------------------#

sub give_methods {
    my $package = caller;
    for ( @{$public_methods{$package}} ) {
        _install_wrapper($package, $_, "public");
    };
    for ( @{$protected_methods{$package}} ) {
        _install_wrapper($package, $_, "protected");
    };
    for ( @{$private_methods{$package}} ) {
        _install_wrapper($package, $_, "private");
    };
    return 1;
}

#--------------------------------------------------------------------------#
# new()
#--------------------------------------------------------------------------#

sub new {
    no strict 'refs';
    my ($class, @args) = @_;
    die "new can't be called on an object" if ref($class);

    # create blessed object
    my $self = \do{ my $scalar };
    bless $self, $class;

    # call initializer
    return BUILDALL( $class, $self, @args );
}

sub _new_with_base {
    no strict 'refs';
    my ($class, @args) = @_;
    die "new can't be called on an object" if ref($class);

    # create blessed object
    my $base_class = $base_class_of{ $class };
    my $prebuild = *{$class."::PREBUILD"}{CODE};
    my @filtered_args
        = defined $prebuild ? $prebuild->($base_class, @args) : @args;
    my $self = $base_class->new( @filtered_args );
    bless $self, $class;
    my $addr = refaddr $self;
    ${$class . "::TRACKER"}{$addr} = $self;
    weaken ${$class . "::TRACKER"}{$addr}; # don't let this stop destruction

    # call initializer -- but skip base_class
    {
        local @{$class."::ISA"}
            = grep { $_ ne $base_class } @{$class."::ISA"};
        return BUILDALL( $class, $self, @_ );
    }
}

#--------------------------------------------------------------------------#
# BUILDALL
#--------------------------------------------------------------------------#

sub BUILDALL {
    no strict 'refs';
    my ($class, $self, @args) = @_;

    # return if we've already initialized this class
    my $addr = refaddr $self;
    return $self if ( exists ${$class . "::TRACKER"}{$addr} );

    # otherwise register $self in the tracker and continue
    ${$class . "::TRACKER"}{$addr} = $self;
    weaken ${$class . "::TRACKER"}{$addr}; # don't let this stop destruction

    # initialize superclasses if they can
    for my $superclass (@{"${class}::ISA"}) {
        if ( my $super_buildall = $superclass->can( 'BUILDALL' ) ) {
            my $prebuild = *{$class."::PREBUILD"}{CODE};
            my @filtered_args =
                defined $prebuild ? $prebuild->($superclass, @args) : @args;
            $super_buildall->($superclass, $self, @filtered_args);
        }
    }

    # initialize self if we have an initializer
    *{$class."::BUILD"}{CODE}->($self, @args)
        if defined *{$class."::BUILD"}{CODE};
    return $self;
}

#--------------------------------------------------------------------------#
# CLONE
#--------------------------------------------------------------------------#

sub CLONE {
    no strict 'refs';
    my $class = shift;
    for my $old_obj_id ( keys %{$class . "::TRACKER"} ) {
        my $new_obj_id = refaddr(
            ${$class . "::TRACKER"}{$old_obj_id}
        );
        for my $prop ( keys %{"${class}::DATA::"} ) {
            my $qualified_name = $class . "::DATA::$prop";
            $$qualified_name{ $new_obj_id } = $$qualified_name{ $old_obj_id };
            delete $$qualified_name{ $old_obj_id };
        }
        ${$class . "::TRACKER"}{$new_obj_id} = $new_obj_id;
        delete ${$class . "::TRACKER"}{$old_obj_id};
    }
    return 1;
}

#--------------------------------------------------------------------------#
# DESTROY
#--------------------------------------------------------------------------#

sub DESTROY {
    no strict 'refs';
    my ($self, $class) = @_;
    $class ||= ref $self;

    # return if we've already destructed this class
    my $addr = refaddr $self;
    return if ( ! exists ${$class . "::TRACKER"}{$addr} );

    # otherwise mark that we're destroying this class and continue
    delete ${$class . "::TRACKER"}{$addr};

    # demolish and free data for this class
    *{$class."::DEMOLISH"}{CODE}->($self)
        if defined *{$class."::DEMOLISH"}{CODE};
    for ( keys %{"${class}::DATA::"} ) {
        delete (${"${class}::DATA::$_"}{$addr});
    }

    # destroy all superclasses
    for my $superclass ( @{"${class}::ISA"} ) {
        if ( my $super_destroyer = $superclass->can("DESTROY") ) {
            $super_destroyer->($self, $superclass);
        }
    }

}

#--------------------------------------------------------------------------#
# MODIFY_CODE_ATTRIBUTES
#--------------------------------------------------------------------------#

sub MODIFY_CODE_ATTRIBUTES {
    my ($package, $referent, @attrs) = @_;
    for my $attr (@attrs) {
        no strict 'refs';
        if ( $attr =~ /^(?:Method|Pub)$/ ) {
            push @{$public_methods{$package}}, $referent;
            undef $attr;
        }
        elsif ($attr eq "Prot") {
            push @{$protected_methods{$package}}, $referent;
            undef $attr;
        }
        elsif ($attr eq "Priv") {
            push @{$private_methods{$package}}, $referent;
            undef $attr;
        }
    }
    return grep {defined} @attrs;
}

#--------------------------------------------------------------------------#
# MODIFY_SCALAR_ATTRIBUTES
#--------------------------------------------------------------------------#

sub MODIFY_SCALAR_ATTRIBUTES {
    my ($OL_PACKAGE, $referent, @attrs) = @_;
    for my $attr (@attrs) {
        no strict 'refs';
        if ($attr eq "Pub") {
            _install_accessors( $OL_PACKAGE, $referent, "public", 0 );
            undef $attr;
        }
        elsif ($attr eq "Prot") {
            _install_accessors( $OL_PACKAGE, $referent, "protected", 0 );
            undef $attr;
        }
        elsif ( $attr =~ /^(?:Prop|Priv)$/ ) {
            _install_accessors( $OL_PACKAGE, $referent, "private", 0 );
            undef $attr;
        }
        elsif ( $attr =~ /^(?:ReadOnly)$/ ) {
            _install_accessors( $OL_PACKAGE, $referent, "readonly", 0 );
            undef $attr;
        }
        elsif ($attr =~ /^(?:Class|ClassPriv)$/ ) {
            _install_accessors( $OL_PACKAGE, $referent, "private", 1 );
            undef $attr;
        }
        elsif ($attr =~ /^(?:ClassProt)$/ ) {
            _install_accessors( $OL_PACKAGE, $referent, "protected", 1 );
            undef $attr;
        }
        elsif ($attr =~ /^(?:ClassPub)$/ ) {
            _install_accessors( $OL_PACKAGE, $referent, "public", 1 );
            undef $attr;
        }
        elsif ($attr =~ /^(?:ClassReadOnly)$/ ) {
            _install_accessors( $OL_PACKAGE, $referent, "readonly", 1 );
            undef $attr;
        }
        else {
            # we don't really care
        }
    }
    return grep {defined} @attrs;
}

#--------------------------------------------------------------------------#
# _findsym
#--------------------------------------------------------------------------#

my %symcache;
sub _findsym {
    no strict 'refs';
    my ($pkg, $ref, $type) = @_;
    return $symcache{$pkg,$ref} if $symcache{$pkg,$ref};
    $type ||= ref($ref);
    my $found;
    foreach my $sym ( values %{$pkg."::"} ) {
        return $symcache{$pkg,$ref} = \$sym
            if *{$sym}{$type} && *{$sym}{$type} == $ref;
    }
}

#--------------------------------------------------------------------------#
# _gen_accessor
#--------------------------------------------------------------------------#

sub _gen_accessor {
    my ($package, $name, $classwide) = @_;
    return $classwide
        ? "return \$${package}::CLASSDATA{${name}}"
        : "return \$${package}::DATA::${name}" .
          "{refaddr( \$_[0] )}" ;
}

#--------------------------------------------------------------------------#
# _gen_class_locals
#--------------------------------------------------------------------------#

sub _gen_class_locals {
    no strict 'refs';
    my $package = shift;
    my $evaltext = "";
    my @props = keys %{$package."::CLASSDATA"};
    return "" unless @props;
    my @globs = map { "*${package}::$_" } @props;
    my @refs = map { "\\\$${package}::CLASSDATA{$_}" } @props;
    $evaltext .= "  local ( " .  join(", ", @globs) .  " ) = ( " .
                   join(", ", @refs) . " );\n";
    return $evaltext;
}

#--------------------------------------------------------------------------#
# _gen_acc_mut
#--------------------------------------------------------------------------#

sub _gen_acc_mut {
    my ($package, $name, $classwide) = @_;
    return $classwide
        ? "return (\@_ > 1) ? " .
          "\$${package}::CLASSDATA{${name}} = \$_[1] : " .
          "\$${package}::CLASSDATA{${name}} ; " .
          "\n"
        : "return (\@_ > 1) ? " .
          "\$${package}::DATA::${name}" . "{refaddr( \$_[0] )} = \$_[1] : " .
          "\$${package}::DATA::${name}" . "{refaddr( \$_[0] )} " .
          "\n";
}

#--------------------------------------------------------------------------#
# _gen_mutator
#--------------------------------------------------------------------------#

sub _gen_mutator {
    my ($package, $name, $classwide) = @_;
    return $classwide
        ? "\$${package}::CLASSDATA{${name}} = \$_[1];\n" .
          "return \$_[0] "
        : "\$${package}::DATA::${name}" .
          "{refaddr( \$_[0] )} = \$_[1];\n" .
          "return \$_[0]";
}

#--------------------------------------------------------------------------#
# _gen_object_locals
#--------------------------------------------------------------------------#

sub _gen_object_locals {
    no strict 'refs';
    my $package = shift;
    my @props = keys %{$package."::DATA::"};
    return "" unless @props;
    my $evaltext = "  my \$id;\n"; # need to define it
    $evaltext .= "  \$id = refaddr(\$obj) if ref(\$obj);\n";
    my @globs = map { "*${package}::$_" } @props;
    my @refs = map { "\\\$${package}::DATA::$_ {\$id}" } @props;
    $evaltext .= "  local ( " .  join(", ", @globs) .  " ) = ( " .
                   join(", ", @refs) . " ) if \$id;\n";
    return $evaltext;
}

#--------------------------------------------------------------------------#
# _gen_privacy
#--------------------------------------------------------------------------#

sub _gen_privacy {
    my ($package, $name, $privacy) = @_;
    SWITCH: for ($privacy) {
        /public/    && do { return "" };

        /protected/ && do { return
            "  my (\$caller) = caller();\n" .
            "  croak q/$name is a protected method and can't be called from ${package}/\n".
            "    unless \$caller->isa( '$package' );\n"
        };

        /private/ && do { return
            "  my (\$caller) = caller();\n" .
            "  croak q/$name is a private method and can't be called from ${package}/\n".
            "    unless \$caller eq '$package';\n"
        };
    }
}

#--------------------------------------------------------------------------#
# _install_accessors
#--------------------------------------------------------------------------#

sub _install_accessors {
    my ($package,$scalarref,$privacy,$classwide) = @_;
    no strict 'refs';

    # find name from reference
    my $symbol = _findsym($package, $scalarref) or die;
    my $name = *{$symbol}{NAME};

    # make the property exist to be found by give_methods()
    if ($classwide) {
        ${$package."::CLASSDATA"}{$name} = undef;
    }
    else {
        %{$package."::DATA::".$name} = ();
    }

    # determine names for accessor/mutator
    my $get = $prefixes_for{ $package }{get};
    my $set = $prefixes_for{ $package }{set};
    my $acc = ( defined $get ? $get : q{}     ) . $name;
    my $mut = ( defined $set ? $set : q{set_} ) . $name;

    # install accessors
    return if $privacy eq "private"; # unless private
    my $accessor_privacy = $privacy eq 'readonly' ? 'public'    : $privacy;
    my $mutator_privacy  = $privacy eq 'readonly' ? 'protected' : $privacy;
    my $evaltext;
    if ( $acc ne $mut ) {
        $evaltext =
                "*${package}::${acc} = sub { \n" .
                    _gen_privacy( $package, $name, $accessor_privacy ) .
                    _gen_accessor( $package, $name, $classwide ) .
                "\n}; \n\n" .
                "*${package}::${mut} = sub { \n" .
                    _gen_privacy( $package, "set_$name", $mutator_privacy ) .
                    _gen_mutator( $package, $name, $classwide ) .
                "\n}; "
        ; # $evaltext
    }
    else {
        $evaltext =
                "*${package}::${mut} = sub { \n" .
                    _gen_privacy( $package, "set_$name", $mutator_privacy ) .
                    _gen_acc_mut( $package, $name, $classwide ) .
                "\n}; "
        ; # $evaltext
    }

    eval $evaltext; ## no critic
    die $@ if $@;
    return;
}

#--------------------------------------------------------------------------#
# _install_wrapper
#--------------------------------------------------------------------------#

sub _install_wrapper {
    my ($package,$coderef,$privacy) = @_;
    no strict 'refs';
    no warnings 'redefine';
    my $symbol = _findsym($package, $coderef) or die;
    my $name = *{$symbol}{NAME};
    *{$package."::METHODS::$name"} = $coderef;
    my $evaltext = "*${package}::${name} = sub {\n".
            _gen_privacy( $package, $name, $privacy ) .
            "  my \$obj = shift;\n" .
            "  local \$${package}::self = \$obj;\n" .
            _gen_class_locals($package) .
            _gen_object_locals($package) .
            "  local \$Carp::CarpLevel = \$Carp::CarpLevel + 2;\n".
            "  ${package}::METHODS::${name}(\@_);\n".
        "}\n"
    ; # my
    # XXX print "\n\n$evaltext\n\n";
    eval $evaltext; ## no critic
    die $@ if $@;
    return;
}

1;

__END__