view release on metacpan or  search on metacpan

lib/Dios.pm  view on Meta::CPAN

    # Unpack the parsed components of the field declaration...
    my ($sigil, $twigil, $name) = $var =~ m{\A ([\$\@%]) ([.!]?+) (\S*+) }xms;

    # Adapt type to sigil...
    my $container_type = ($sigil eq '@') ? "Array[".($type//'Any')."]"
                       : ($sigil eq '%') ?  "Hash[".($type//'Any')."]"
                       :                    $type;

    # Is it type-checked???
    my $TYPE_SETUP = q{};
    my $TYPE_VALIDATOR = q{};
    if ($type) {
        state $validator_num = 0; $validator_num++;
        $TYPE_VALIDATOR = qq[ { no warnings; \$Dios::_internal::attr_validator_$validator_num = Dios::Types::validator_for(q{$container_type}, 'Value (%s) for $sigil$name attribute', $constraint ); } ];
        $TYPE_SETUP = qq[ :Type( sub{ \$Dios::_internal::attr_validator_$validator_num->(shift) }) ];
    }

    # Define accessors...
    my $access = $twigil ne '.' ? q{} : $OIO_accessor_keyword{$accessor_type}{$rw}."(Name=>q{$name}) $TYPE_SETUP";

    # Is it a delegated handler???
    my $delegators = '';
    for my $delegation (split /(?&WS) handles (?&WS) (?(DEFINE) (?<WS> \s*+ (?: \# [^\n]*+ \n \s*+ )*+ ))/x, $handles) {
        next unless $delegation;
        if ($delegation =~ m{^:(.*)<(.*)>$}xms) {
            $delegators .= " :Handles($1-->$2)";
        }
        else {
            $delegators .= " :Handles($delegation)";
        }
    }

    # Is it initialized???
    my $init = qq{:Arg(Name=>q{$name} } . ($required ? q{, Mandatory=>1)} : q{)} );
    my $INIT_FUNC = q{};

    # Ensure array and hash attrs are initialized...
    if ($sigil =~ /[\@%]/ && (!$initializer || $initializer =~ m{\A \s*+ \z}xms)) {
        $initializer = '//=()';
    }

    # Install the initialization code...
    if ($initializer =~ m{\A \s*+ (?<DEFAULT_INIT> // \s*+ )? = (?<INIT_VAL> .*+ ) }xms) {
        my %init_field = %+;
        my $init_val = $init_field{INIT_VAL};

        # Adapt initializer value to sigil...
           if ($sigil eq '@') { $init_val = "[$init_val]"; }
        elsif ($sigil eq '%') { $init_val = "+{$init_val}";  }

        $init = qq{:DEFAULT(___i_n_i_t__${name}___(\$self)) } . ($init_field{DEFAULT_INIT} ? $init : q{});
        $INIT_FUNC = qq{sub ___i_n_i_t__${name}___ { my (\$self) = \@_; $init_val }};
    }
    else {
        $init .= $initializer;
    }

    # Update the attribute setting code...
    $^H{'Dios attrnames'} .= "$name,";
    if ($sigil eq '$') {
        $^H{'Dios attrs'} .= $] < 5.022 ? qq{alias my \$$name =    \$_Dios__attr_${name}[\${\$_[0]}];}
                                        : qq{   \\ my \$$name = \\ \$_Dios__attr_${name}[\${\$_[0]}];};
    }
    else {
        $^H{'Dios attrs'}
            .= $] < 5.022 ? qq{alias my $sigil$name = $sigil}.qq{{\$_Dios__attr_${name}[\${\$_[0]}]};}
                          : qq{   \\ my $sigil$name =             \$_Dios__attr_${name}[\${\$_[0]}]; };
    }
    # Add type-checking code to alias...
    if ($type) {
        $^H{'Dios attrs'} .= qq{ Dios::Types::_set_var_type(q{$type}, \\$sigil$name, 'Value (%s) for $sigil$name attribute', $constraint ); };
    }

    # Return the converted syntax...
    return qq{ $TYPE_VALIDATOR my \@_Dios__attr_$name : Field $access $delegators $init $TYPE_SETUP; $INIT_FUNC; };
}

# Convert a typed lexical variable...
sub _compose_lexical {
    my ($type, $variable, $constraint) = @_;

    # Normalize constraint...
    $constraint = $constraint ? 'sub ' . substr($constraint, 5) : q{};
    if ($constraint && !defined $type) {
        $type = 'Any';
    }

    # Is it type-checked???
    my $TYPE_SETUP = q{};
    if (defined $type) {
        $TYPE_SETUP  = qq[ Dios::Types::_set_var_type(q{$type}, \\$variable, 'Value (%s) assigned to $variable', $constraint ); ];
    }

    # Return the converted syntax...
    return qq{my $variable; $TYPE_SETUP; $variable = $variable};
}


# Convert a 'shared' to a class attribute...
sub _compose_shared {
    my ($type, $var, $traits, $initializer, $constraint) = @_;

    # Normalize constraint...
    $constraint = $constraint ? 'sub ' . substr($constraint, 5) : q{};
    if ($constraint && !defined $type) {
        $type = 'Any';
    }

    # Did the user specify a particular kind of accessor generation???
    my $accessor_type = $^H{'Dios accessor_type'};

    # Unpack the parsed components of the shared declaration...
    my ($sigil, $twigil, $name) = $var =~ m{\A ([\$\@%]) ([.!]?+) (\S*+) }xms;
    my $rw     = $traits =~ /\brw\b/ ? 'rw' : 'ro';

    # Generate accessor subs...
    my $accessors = $twigil ne '.' ? q{}
                  : $OIO_accessor_generate{$accessor_type}{$rw}->($name, $sigil);

    # Build type checking sub...
    my $type_func = q{};
    if ($type) {
        $type_func = qq[ sub ___t_y_p_e__${name}___ { state \$check = Dios::Types::validator_for(q{$type}, 'Value (%s) for \$$name attribute' ); \$check->($_[0]) } ___t_y_p_e__${name}___($sigil$name); ];
    }
    else {
        $type_func = q{};
    }
    # Is it type-checked???
    my $TYPE_SETUP = q{};
    if ($type) {
        $TYPE_SETUP  = qq[ Dios::Types::_set_var_type(q{$type}, \\$sigil$name, 'Value (%s) for shared $sigil$name attribute', '$sigil', $constraint ); ];