view release on metacpan or  search on metacpan

lib/MooseX/Extended/Core.pm  view on Meta::CPAN

            class_name     => $meta->name,
            messsage       => "Illegal attribute name, '$name'",
        );
    }

    state $shortcut_for = {
        predicate => sub ($value) {"has_$value"},
        clearer   => sub ($value) {"clear_$value"},
        builder   => sub ($value) {"_build_$value"},
        writer    => sub ($value) {"set_$value"},
        reader    => sub ($value) {"get_$value"},
    };

    if ( is_coderef( $opt_for{builder} ) ) {
        my $builder_code = $opt_for{builder};
        my $builder_name = $shortcut_for->{builder}->($name);
        if ( _is_valid_method_name($builder_name) ) {
            $meta->add_method( $builder_name => $builder_code );
            $opt_for{builder} = $builder_name;
        }
    }

    OPTION: foreach my $option ( keys $shortcut_for->%* ) {
        next unless exists $opt_for{$option};
        no warnings 'numeric';    ## no critic (TestingAndDebugging::ProhibitNoWarning)
        if ( 1 == length( $opt_for{$option} ) && 1 == $opt_for{$option} ) {
            my $option_name = $shortcut_for->{$option}->($name);
            $opt_for{$option} = $option_name;
        }
        unless ( _is_valid_method_name( $opt_for{$option} ) ) {
            throw_exception(
                'InvalidAttributeDefinition',
                attribute_name => $orig_name,
                class_name     => $meta->name,
                messsage       => "Attribute '$orig_name' has an invalid option name, $option => '$opt_for{$option}'",
            );
        }
    }

    if ( 'rwp' eq $opt_for{is} ) {
        $opt_for{writer} = "_set_$name";
    }

    if ( exists $opt_for{writer} && defined $opt_for{writer} ) {
        $opt_for{is} = 'rw';
    }

    %opt_for = _maybe_add_cloning_method( $meta, $name, %opt_for );

    if (    not exists $opt_for{accessor}
        and not exists $opt_for{writer}
        and not exists $opt_for{default}
        and not exists $opt_for{builder}
        and not defined $opt_for{init_arg}
        and $opt_for{is} eq 'ro' )
    {

        my $call_level = 1 + $opt_for{_call_level};
        my ( undef, $filename, $line ) = caller($call_level);
        Carp::carp("$attr_type '$name' is read-only and has no init_arg or default, defined at $filename line $line\n")
          if $] ge '5.028'
          and warnings::enabled_at_level( 'MooseX::Extended::naked_fields', $call_level );
    }

    delete $opt_for{_call_level};
    _debug( "Setting $attr_type, '$orig_name'", \%opt_for );
    $meta->add_attribute( $orig_name, %opt_for );
}

sub _is_valid_method_name ($name) {
    return if ref $name;
    return $name =~ qr/\A[a-z_]\w*\z/ai;
}

sub _maybe_add_cloning_method ( $meta, $name, %opt_for ) {
    return %opt_for unless my $clone = delete $opt_for{clone};

    no warnings 'numeric';    ## no critic (TestingAndDebugging::ProhibitNoWarning)

    my ( $use_dclone, $use_coderef, $use_method );
    if ( 1 == length($clone) && 1 == $clone ) {
        $use_dclone = 1;
    }
    elsif ( _is_valid_method_name($clone) ) {
        $use_method = 1;
    }
    elsif ( is_coderef($clone) ) {
        $use_coderef = 1;
    }
    else {
        throw_exception(
            'InvalidAttributeDefinition',
            attribute_name => $name,
            class_name     => $meta->name,
            messsage       => "Attribute '$name' has an invalid option value, clone => '$clone'",
        );
    }

    # here be dragons ...
    _debug("Adding cloning for $name");
    my $reader = delete( $opt_for{reader} ) // $name;
    my $writer = delete( $opt_for{writer} ) // $reader;
    my $is     = $opt_for{is};
    $opt_for{is} = 'bare';

    my $reader_method = sub ($self) {
        _debug("Calling reader method for $name");
        my $attr  = $meta->get_attribute($name);
        my $value = $attr->get_value($self);
        return $value unless ref $value;
        return
            $use_dclone                 ? dclone($value)
          : $use_method || $use_coderef ? $self->$clone( $name, $value )
          :                               croak("PANIC: this should never happen. Do not know how to clone '$name'");
    };

    my $writer_method = sub ( $self, $new_value ) {
        _debug("Calling writer method for $name");
        my $attr = $meta->get_attribute($name);
        $new_value
          = !ref $new_value             ? $new_value