File Coverage

blib/lib/exact/class.pm

Criterion	Covered	Total	%
statement	143	147	97.2
branch	54	60	90.0
condition	9	18	50.0
subroutine	24	25	96.0
pod	7	7	100.0
total	237	257	92.2

package exact::class;
# ABSTRACT: Simple class interface extension for exact

use 5.014;
use exact;
use Import::Into;
use feature                  ();
use Class::Method::Modifiers ();
use Role::Tiny               ();
use Scalar::Util             ();

our $VERSION = '1.21'; # VERSION

my $store;
my ($perl_version) = $^V =~ /^v5\.(\d+)/;

sub import {
    my ( $self, $params, $caller ) = @_;

    if ($caller) {
        exact->late_parent;
    }
    else {
        $caller //= caller();
        exact->add_isa( $self, $caller ) if ( $self eq 'exact::class' );
    }

    $store->{struc}{$caller} = {};

    Class::Method::Modifiers->import::into($caller);
    feature->unimport('class') if ( $perl_version > 36 );

    exact->monkey_patch( $caller, $_, \&$_ ) for ( qw( has class_has with ) );
}

sub DESTROY {}

sub ____parents {
    my ($namespace) = @_;
    no strict 'refs';
    my @parents = @{ $namespace . '::ISA' };
    return @parents, map { ____parents($_) } @parents;
}

sub ____install {
    my ( $self, $namespace, $input ) = @_;

    if ( ref $store->{struc}{$namespace} eq 'HASH' ) {
        my @has_names = keys %{ $store->{struc}{$namespace}->{has} };

        for my $class_has_name (
            grep {
                my $name = $_;
                not grep { $_ eq $name } @has_names;
            } keys %{ $store->{struc}{$namespace}->{name} }
        ) {
            $self->$class_has_name( $input->{$class_has_name} ) if ( exists $input->{$class_has_name} );
        }

        for my $has_name (@has_names) {
            if ( exists $input->{$has_name} ) {
                $self->attr( $has_name, $input->{$has_name} );
            }
            elsif ( exists $store->{struc}{$namespace}->{value}{$has_name} ) {
                $self->attr( $has_name, $store->{struc}{$namespace}->{value}{$has_name} );
            }
            else {
                $self->attr($has_name);
            }
        }
    }
}

sub new {
    my $class = shift;
    my $input = @_ ? @_ > 1 ? {@_} : { %{ $_[0] } } : {};
    my $self  = bless( { %$input }, ref $class || $class );

    for my $namespace ( reverse ( ref $self, ____parents( ref $self ) ) ) {
        if ( ref $store->{roles}{$namespace} eq 'ARRAY' ) {
            for my $role ( @{ $store->{roles}->{$namespace} } ) {
                ____install( $self, $role, $input );
            }
        }

        ____install( $self, $namespace, $input );
    }

    return $self;
}

sub tap {
    my ( $self, $cb ) = ( shift, shift );
    $_->$cb(@_) for $self;
    return $self;
}

sub attr {
    my ( $self, $attrs, $value ) = @_;

    my $set = {
        attrs        => $attrs,
        caller       => ref($self) || $self,
        set_has      => 1,
        self         => $self,
        obj_accessor => 1,
    };

    $set->{value} = $value if ( @_ > 2 );
    return ____attrs($set);
}

sub class_has {
    my ( $attrs, $value ) = @_;

    my $set = {
        attrs  => $attrs,
        caller => scalar( caller() ),
    };

    $set->{value} = $value if ( @_ > 1 );
    ____attrs($set);
    return;
}

sub has {
    my ( $attrs, $value ) = @_;

    my $set = {
        attrs   => $attrs,
        caller  => scalar( caller() ),
        set_has => 1,
    };

    $set->{value} = $value if ( @_ > 1 );
    ____attrs($set);
    return;
}

sub ____attrs {
    for my $set (@_) {
        for my $name ( ( ref $set->{attrs} ) ? @{ $set->{attrs} } : $set->{attrs} ) {
            my $accessor = ( $set->{obj_accessor} )
                ? sub {
                    my ( $self, $value ) = @_;

                    if ( @_ > 1 ) {
                        $self->{$name} = $value;
                        return $self;
                    }
                    else {
                        return ${ $self->{$name} } if (
                            ref $self->{$name} eq 'REF' and
                            ref ${ $self->{$name} } eq 'CODE'
                        );

                        $self->{$name} = $self->{$name}->($self) if ( ref $self->{$name} eq 'CODE' );
                        return $self->{$name};
                    }
                }
                : sub {
                    my ( $self, $value ) = @_;

                    if ( @_ > 1 ) {
                        $store->{struc}{ $set->{caller} }->{value}{$name} = $value;
                        return $self;
                    }
                    else {
                        return ${ $store->{struc}{ $set->{caller} }->{value}{$name} } if (
                            ref $store->{struc}{ $set->{caller} }->{value}{$name} eq 'REF' and
                            ref ${ $store->{struc}{ $set->{caller} }->{value}{$name} } eq 'CODE'
                        );

                        $store->{struc}{ $set->{caller} }->{value}{$name} =
                            $store->{struc}{ $set->{caller} }->{value}{$name}->($self)
                            if ( ref $store->{struc}{ $set->{caller} }->{value}{$name} eq 'CODE' );
                        return $store->{struc}{ $set->{caller} }->{value}{$name};
                    }
                };

            {
                no strict 'refs';
                no warnings 'redefine';
                *{ $set->{caller} . '::' . $name } = $accessor;
            }

            if ( ref $set->{self} ) {
                $set->{self}->$name( $set->{value} ) if ( exists $set->{value} );
            }
            else {
                $store->{struc}{ $set->{caller} }->{has}{$name}   = 1 if ( $set->{set_has} );
                $store->{struc}{ $set->{caller} }->{name}{$name}  = 1;
                $store->{struc}{ $set->{caller} }->{value}{$name} = $set->{value} if ( exists $set->{value} );
            }
        }
    }

    return;
}

sub ____role_attrs {
    my ( $caller, $roles, $object ) = @_;

    for my $role (@$roles) {
        for my $name (
            keys %{ $store->{struc}{$role}{name} }
        ) {
            my $set = {
                attrs  => $name,
                caller => $caller,
            };

            if ( $store->{struc}{$role}{has}{$name} ) {
                $set->{self}         = $object;
                $set->{obj_accessor} = 1;
                $set->{set_has}      = 1;
            }

            $set->{value} = $store->{struc}{$role}{value}{$name}
                if ( exists $store->{struc}{$role}{value}{$name} );

            ____attrs($set);
        }
    }

    return;
}

sub with {
    my $caller = scalar(caller);
    push( @{ $store->{roles}->{$caller} }, @_ );

    try {
        Role::Tiny->apply_roles_to_package( $caller, $_ ) for @_;
    }
    catch ($e) {
        $e =~ s/\s+at\s.+\sline\s\d+\.\s*$//g;
        croak $e;
    }

    ____role_attrs( $caller, [@_] );
    return;
}

sub with_roles {
    my ( $self, @roles ) = @_;
    my $object;

    unless ( my $class = Scalar::Util::blessed($self) ) {
        $object = Role::Tiny->create_class_with_roles(
            $self,
            map { /^\+(.+)$/ ? "${self}::Role::$1" : $_ } @roles
        );
    }
    else {
        $object = Role::Tiny->apply_roles_to_object(
            $self,
            map { /^\+(.+)$/ ? "${class}::Role::$1" : $_ } @roles
        );
    }

    ____role_attrs( Scalar::Util::blessed($object) || $object, [@_], $object );
    return $object;
}

1;

__END__