File Coverage

blib/lib/Class/Property.pm

Criterion	Covered	Total	%
statement	41	49	83.6
branch	2	2	100.0
condition			n/a
subroutine	17	21	80.9
pod	0	4	0.0
total	60	76	78.9

package Class::Property;
use strict; use warnings FATAL => 'all';
use parent 'Exporter';
use 5.016;
use Carp;

our $VERSION = '1.002'; # change in POD

our @EXPORT;

my $LAZY_INITS = {};

my $GEN = {
    'default' => sub
    {
        my( $prop_name ) = @_;

        return sub: lvalue
        {
            return shift->{$prop_name};
        };
    },
    'default_lazy' => sub
    {
        my( $prop_name, $lazy_init ) = @_;
        require Class::Property::RW::Lazy;
        my $dummy;
        my $inits = $LAZY_INITS->{$prop_name} //= {};
        my $wrapper = tie $dummy, 'Class::Property::RW::Lazy', $prop_name, $lazy_init, $inits;

        return sub: lvalue
        {
            my $self = shift;

            if( defined $inits->{$self} )
            {
                return $self->{$prop_name};
            }
            else
            {
                $wrapper->set_object($self);
                return $dummy;
            }
        };
    },
    'lazy_get_default_set' => sub
    {
        my( $prop_name, $lazy_init, $setter ) = @_;
        require Class::Property::RW::Lazy::CustomSet;
        my $dummy;
        my $inits = $LAZY_INITS->{$prop_name} //= {};
        my $wrapper = tie $dummy, 'Class::Property::RW::Lazy::CustomSet', $prop_name, $lazy_init, $setter, $inits;

        return sub: lvalue
        {
            $wrapper->set_object(shift);
            return $dummy;
        };
    },
    'custom' => sub
    {
        my( $getter, $setter ) = @_;
        require Class::Property::RW::Custom;
        my $dummy;
        my $wrapper = tie $dummy, 'Class::Property::RW::Custom', $getter, $setter;

        return sub: lvalue
        {
            $wrapper->set_object(shift);
            return $dummy;
        };
    },
    'default_get_custom_set' => sub
    {
        my( $prop_name, $setter ) = @_;
        require Class::Property::RW::CustomSet;
        my $dummy;
        my $wrapper = tie $dummy, 'Class::Property::RW::CustomSet', $prop_name, $setter;

        return sub: lvalue
        {
            $wrapper->set_object(shift);
            return $dummy;
        };
    },
    'custom_get_default_set' => sub
    {
        my( $prop_name, $getter ) = @_;
        require Class::Property::RW::CustomGet;
        my $dummy;
        my $wrapper = tie $dummy, 'Class::Property::RW::CustomGet', $prop_name, $getter;

        return sub: lvalue
        {
            $wrapper->set_object(shift);
            return $dummy;
        };
    },
    'default_ro' => sub
    {
        my( $prop_name ) = @_;
        require Class::Property::RO;
        my $dummy;
        my $wrapper = tie $dummy, 'Class::Property::RO', $prop_name;

        return sub: lvalue
        {
            $wrapper->set_object(shift);
            return $dummy;
        };
    },
    'custom_ro' => sub
    {
        my( $prop_name, $getter ) = @_;
        require Class::Property::RO::CustomGet;
        my $dummy;
        my $wrapper = tie $dummy, 'Class::Property::RO::CustomGet', $prop_name, $getter;

        return sub: lvalue
        {
            $wrapper->set_object(shift);
            return $dummy;
        };
    },
    'lazy_ro' => sub
    {
        my( $prop_name, $lazy_init ) = @_;
        require Class::Property::RO::Lazy;
        my $dummy;
        my $inits = $LAZY_INITS->{$prop_name} //= {};
        my $wrapper = tie $dummy, 'Class::Property::RO::Lazy', $prop_name, $lazy_init, $inits;

        return sub: lvalue
        {
            $wrapper->set_object(shift);
            return $dummy;
        };
    },
    'default_wo' => sub: lvalue
    {
        my( $prop_name ) = @_;
        require Class::Property::WO;
        my $dummy;
        my $wrapper = tie $dummy, 'Class::Property::WO', $prop_name;

        return sub: lvalue
        {
            $wrapper->set_object(shift);
            return $dummy;
        };
    },
    'custom_wo' => sub: lvalue
    {
        my( $prop_name, $setter ) = @_;
        require Class::Property::WO::CustomSet;
        my $dummy;
        my $wrapper = tie $dummy, 'Class::Property::WO::CustomSet', $prop_name, $setter;

        return sub: lvalue
        {
            $wrapper->set_object(shift);
            return $dummy;
        };
    },
};

# creating new property by names
# input is a hash of
# property_name => hashref
# and hashref is:
#
#   get => CODEREF | anything   # creates getter custom or default
#   get_lazy => CODEREF         # creates default getter with lazy init method from CODEREF
#   set => CODREF | anything    # creates custom or default setter
#
my $make_property = sub
{
    my( $package, %kwargs ) = @_;

    #use Data::Dumper;    warn "Invoked $package with ".Dumper(\%kwargs);

    foreach my $prop_name (keys(%kwargs))
    {
        my $prop_settings = $kwargs{$prop_name};
        my $prop_methodname = "${package}::$prop_name";
        my $prop_method;

        if( # regular property
            exists $prop_settings->{'get'}
            and exists $prop_settings->{'set'}
        )
        {
            my( $get_type, $set_type ) = ( ref $prop_settings->{'get'}, ref $prop_settings->{'set'} );

            if( $get_type eq 'CODE' and $set_type eq 'CODE' ) # custom setter and gettter
            {
                $prop_method = $GEN->{'custom'}->(@{$prop_settings}{'get', 'set'});
            }
            elsif( $get_type eq 'CODE' )    # custom getter and default setter
            {
                $prop_method = $GEN->{'custom_get_default_set'}->($prop_name, @{$prop_settings}{'get'});
            }
            elsif( $set_type eq 'CODE' )    # default getter and custom setter
            {
                $prop_method = $GEN->{'default_get_custom_set'}->($prop_name, @{$prop_settings}{'set'});
            }
            else    # default getter and setter
            {
                $prop_method = $GEN->{'default'}->($prop_name);
            }
        }
        elsif( # regular property with lazy init
            exists $prop_settings->{'get_lazy'}
            and exists $prop_settings->{'set'}
        )
        {
            croak 'get_lazy parameter should be a coderef' if ref $prop_settings->{'get_lazy'} ne 'CODE';
            my $set_type = ref $prop_settings->{'set'};
            if( $set_type eq 'CODE' )
            {
                $prop_method = $GEN->{'lazy_get_default_set'}->($prop_name, $prop_settings->{'get_lazy'}, $prop_settings->{'set'});
            }
            else
            {
                $prop_method = $GEN->{'default_lazy'}->($prop_name, $prop_settings->{'get_lazy'});
            }
        }
        elsif( exists $prop_settings->{'get'} ) # ro property
        {
            if( ref $prop_settings->{'get'} eq 'CODE' ) # RO custom getter
            {
                $prop_method = $GEN->{'custom_ro'}->($prop_name, $prop_settings->{'get'});
            }
            else
            {
                $prop_method = $GEN->{'default_ro'}->($prop_name);
            }
        }
        elsif( exists $prop_settings->{'get_lazy'} ) # ro property with lazy init
        {
            croak 'get_lazy parameter should be a coderef' if ref $prop_settings->{'get_lazy'} ne 'CODE';
            $prop_method = $GEN->{'lazy_ro'}->($prop_name, $prop_settings->{'get_lazy'});
        }
        elsif( exists $prop_settings->{'set'} ) # wo property
        {
            if( ref $prop_settings->{'set'} eq 'CODE' ) # WO custom setter
            {
                $prop_method = $GEN->{'custom_wo'}->($prop_name, $prop_settings->{'set'});
            }
            else
            {
                $prop_method = $GEN->{'default_wo'}->($prop_name);
            }
        }

        if(defined $prop_method)
        {
            no strict 'refs';
            *{$prop_methodname} = $prop_method;
        }
    }

    return $package;
};

push @EXPORT, 'property';
sub property{ return $make_property->( (caller)[0], @_);}
push @EXPORT, 'rw_property';
sub rw_property{ return $make_property->( (caller)[0], map{$_ => {'set' => undef, 'get' => undef }} @_);}
push @EXPORT, 'ro_property';
sub ro_property{ return $make_property->( (caller)[0], map{$_ => {'get' => undef }} @_);}
push @EXPORT, 'wo_property';
sub wo_property{ return $make_property->( (caller)[0], map{$_ => {'set' => undef }} @_);}

__END__