File Coverage

blib/lib/Variable/Declaration.pm

Criterion	Covered	Total	%
statement	122	122	100.0
branch	40	42	95.2
condition	14	14	100.0
subroutine	29	29	100.0
pod	0	8	0.0
total	205	215	95.3

package Variable::Declaration;
use v5.12.0;
use strict;
use warnings;

our $VERSION = "0.06";

use Keyword::Simple;
use PPR;
use Carp ();
use Import::Into;
use Data::Lock ();
use Type::Tie ();

our $LEVEL;
our $DEFAULT_LEVEL = 2;

sub import {
    shift;
    my %args = @_;
    my $caller = caller;

    $LEVEL = exists $args{level} ? $args{level}
           : exists $ENV{'Variable::Declaration::LEVEL'} ? $ENV{'Variable::Declaration::LEVEL'}
           : $DEFAULT_LEVEL;

    feature->import::into($caller, 'state');

    Keyword::Simple::define 'let'    => \&define_let;
    Keyword::Simple::define 'static' => \&define_static;
    Keyword::Simple::define 'const'  => \&define_const;
}

sub unimport {
    Keyword::Simple::undefine 'let';
    Keyword::Simple::undefine 'static';
    Keyword::Simple::undefine 'const';
}

sub define_let    { define_declaration(let => 'my', @_) }
sub define_static { define_declaration(static => 'state', @_) }
sub define_const  { define_declaration(const => 'my', @_) }

sub define_declaration {
    my ($declaration, $perl_declaration, $ref) = @_;

    my $match = _valid($declaration => _parse($$ref));
    my $tv    = _parse_type_varlist($match->{type_varlist});
    my $args  = +{ declaration => $declaration, perl_declaration => $perl_declaration, %$match, %$tv, level => $LEVEL };

    substr($$ref, 0, length $match->{statement}) = _render_declaration($args);
}

sub croak { Carp::croak @_ }

sub data_lock { Data::Lock::dlock @_ }

sub type_tie(\[$@%]@);
{
    *type_tie = \&Type::Tie::ttie;
}

our %metadata;
sub info {
    my $variable_ref = shift;
    die 'argument must be reference' unless ref $variable_ref;
    my $info = $metadata{$variable_ref} or return undef;
    require Variable::Declaration::Info;
    Variable::Declaration::Info->new(
        declaration      => $info->{declaration},
        type             => $info->{type},
        attributes       => $info->{attributes},
    )
}

sub register_info {
    my ($variable_ref, $info) = @_;
    $metadata{$variable_ref} = {
        declaration      => $info->{declaration},
        type             => $info->{type},
        attributes       => $info->{attributes},
    };
}

sub _valid {
    my ($declaration, $match) = @_;

    croak "variable declaration is required"
        unless $match->{type_varlist};

    my ($eq, $assign) = ($match->{eq}, $match->{assign});
    if ($declaration eq 'const') {
        croak "'const' declaration must be assigned"
            unless defined $eq && defined $assign;
    }
    else {
        croak "illegal expression"
            unless (defined $eq && defined $assign) or (!defined $eq && !defined $assign);
    }

    return $match;
}

sub _render_declaration {
    my $args = shift;
    my @lines;
    push @lines => _lines_declaration($args);
    push @lines => _lines_register_info($args);
    push @lines => _lines_type_check($args) if $args->{level} >= 1;
    push @lines => _lines_type_tie($args)   if $args->{level} == 2;
    push @lines => _lines_data_lock($args)  if $args->{declaration} eq 'const';
    return join ";", @lines;
}

sub _lines_declaration {
    my $args = shift;
    my $s = $args->{perl_declaration};
    $s .= do {
        my $s = join ', ', map { $_->{var} } @{$args->{type_vars}};
        $args->{is_list_context} ? " ($s)" : " $s";
    };
    $s .= $args->{attributes} if $args->{attributes};
    $s .= " = @{[$args->{assign}]}" if defined $args->{assign};
    return ($s);
}

sub _lines_type_tie {
    my $args = shift;
    my @lines;
    for (@{$args->{type_vars}}) {
        my ($type, $var) = ($_->{type}, $_->{var});
        next unless $type;
        push @lines => sprintf('Variable::Declaration::type_tie(%s, %s, %s)', $var, $type, $var);
    }
    return @lines;
}

sub _lines_type_check {
    my $args = shift;
    my @lines;
    for (@{$args->{type_vars}}) {
        my ($type, $var) = ($_->{type}, $_->{var});
        next unless $type;
        push @lines => sprintf('Variable::Declaration::croak(%s->get_message(%s)) unless %s->check(%s)', $type, $var, $type, $var)
    }
    return @lines;
}

sub _lines_data_lock {
    my $args = shift;
    my @lines;
    for my $type_var (@{$args->{type_vars}}) {
        push @lines => "Variable::Declaration::data_lock($type_var->{var})";
    }
    return @lines;
}

sub _lines_register_info {
    my $args = shift;
    my @lines;
    for my $type_var (@{$args->{type_vars}}) {
        push @lines => sprintf("Variable::Declaration::register_info(\\%s, { declaration => '%s', attributes => %s, type => %s })",
            $type_var->{var},
            $args->{declaration},
            ($args->{attributes} ? "'$args->{attributes}'" : 'undef'),
            ($type_var->{type} or 'undef'),
        );
    }
    return @lines;
}

sub _parse {
    my $src = shift;

    return unless $src =~ m{
        \A
        (?
            (?&PerlOWS)
            (?
                (?
                    (?&PerlIdentifier)? (?&PerlOWS)
                    (?&PerlVariable)
                |   (?&PerlParenthesesList)
                ) (?&PerlOWS)
                (?(?&PerlAttributes))? (?&PerlOWS)
            )
            (?=)? (?&PerlOWS)
            (?(?&PerlConditionalExpression))?
        ) $PPR::GRAMMAR }x;

    return +{
        statement       => $+{statement},
        type_varlist    => $+{type_varlist},
        assign_to       => $+{assign_to},
        eq              => $+{eq},
        assign          => $+{assign},
        attributes      => $+{attributes},
    }
}

sub _parse_type_varlist {
    my $expression = shift;

    if ($expression =~ m{ (?(?&PerlParenthesesList)) $PPR::GRAMMAR }x) {
        my ($type_vars) = $+{list} =~ m/\A\((.+)\)\Z/;
        my @list = split ',', $type_vars;
        return +{
            is_list_context => 1,
            type_vars       => [ map { _parse_type_var($_) } @list ],
        }
    }
    elsif (my $type_var = _parse_type_var($expression)) {
        return +{
            is_list_context => 0,
            type_vars       => [ $type_var ],
        }
    }
    else {
        return;
    }
}

sub _parse_type_var {
    my $expression = shift;

    return unless $expression =~ m{
        \A
        (?&PerlOWS)
        (?(?&PerlIdentifier) | (?&PerlCall) )? (?&PerlOWS)
        (?(?:(?&PerlVariable)))
        (?&PerlOWS)
        \Z
        $PPR::GRAMMAR
    }x;

    return +{
        type => $+{type},
        var  => $+{var},
    }
}

1;
__END__