File Coverage

blib/lib/Class/Variable.pm

Criterion	Covered	Total	%
statement	61	65	93.8
branch	8	10	80.0
condition	10	21	47.6
subroutine	18	18	100.0
pod	0	6	0.0
total	97	120	80.8

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

our $VERSION = '1.002'; # <== 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 || 'undefined'
            , $package || 'undefined'
            , caller()  || 'undefined' ) 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 || 'undefined'
            , $package || 'undefined'
            , caller()  || 'undefined' ) if caller() ne $package;

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


1;
__END__