File Coverage

blib/lib/Class/Variable.pm

Criterion	Covered	Total	%
statement	61	65	93.8
branch	8	10	80.0
condition	4	9	44.4
subroutine	18	18	100.0
pod	0	6	0.0
total	91	108	84.2

package Class::Variable;
use strict; use warnings FATAL => 'all';
use parent 'Exporter';
use 5.008;
use Carp;
use Scalar::Util 'weaken';

our $VERSION = '1.001'; # <== update version in pod

our @EXPORT;

my $NS = {};

push @EXPORT, 'public';
sub public
{
    my @names = @_;
    my $package = (caller)[0];
    foreach my $name (@names)
    {
        no strict 'refs';
        *{$package.'::'.$name } = get_public_variable($package, $name);
    }
}

push @EXPORT, 'protected';
sub protected
{
    my @names = @_;
    my $package = (caller)[0];
    foreach my $name (@names)
    {
        no strict 'refs';
        *{$package.'::'.$name } = get_protected_variable($package, $name);
    }
}

push @EXPORT, 'private';
sub private
{
    my @names = @_;
    my $package = (caller)[0];
    foreach my $name (@names)
    {
        no strict 'refs';
        *{$package.'::'.$name } = get_private_variable($package, $name);
    }
}

sub get_public_variable($$)
{
    my( $package, $name ) = @_;

    return sub: lvalue
    {
        my $self = shift;
        if(
            not exists $NS->{$self}
            or not defined $NS->{$self}->{' self'}
        )
        {
            $NS->{$self} = {
                ' self' => $self
            };
            weaken $NS->{$self}->{' self'};
        }

        $NS->{$self}->{$name};
    };
}

sub get_protected_variable($$)
{
    my( $package, $name ) = @_;

    return sub: lvalue
    {
        my $self = shift;
        if(
            not exists $NS->{$self}
            or not defined $NS->{$self}->{' self'}
        )
        {
            $NS->{$self} = {
                ' self' => $self
            };
            weaken $NS->{$self}->{' self'};
        }

        croak sprintf(
            "Access violation: protected variable %s of %s available only to class or subclasses, but not %s."
            , $name
            , $package
            , caller ) if not caller->isa($package);

        $NS->{$self}->{$name};
    };
}

sub get_private_variable($$)
{
    my( $package, $name ) = @_;

    return sub: lvalue
    {
        my $self = shift;
        if(
            not exists $NS->{$self}
            or not defined $NS->{$self}->{' self'}
        )
        {
            $NS->{$self} = {
                ' self' => $self
            };
            weaken $NS->{$self}->{' self'};
        }

        croak sprintf(
            "Access violation: private variable %s of %s available only to class itself, not %s."
            , $name
            , $package
            , caller ) if caller ne $package;

        $NS->{$self}->{$name};
    };
}

1;
__END__