BAD sample code snippet to explain circular dependeded attributes (without clearer)

00_language.t

#!perl

use lib 't/lib';

use strict;
use warnings;

use Test::Text::UTX::Component::Locale::Language;

Test::Text::UTX::Component::Locale::Language->runtests;

README

This is a BAD sample.
Use clearer method instead of rebuild mechanism!
See http://blog.eorzea.asia/2009/10/post_72.html for more details.

Base.pm

package Test::Text::UTX::Component::Locale::Base;


# ****************************************************************
# pragmas
# ****************************************************************

use strict;
use warnings;


# ****************************************************************
# superclasses
# ****************************************************************

use base qw(
    Test::Class
    Test::Text::UTX::Moose
);


# ****************************************************************
# methods
# ****************************************************************

sub get_exception_message_of_argument_undefined {
    my ($self, $component) = @_;

    return $self->get_exception_message_of_set(
        $component,
        'argument is not defined',
    );
}

sub get_exception_message_of_argument_is_not_string {
    my ($self, $component) = @_;

    return $self->get_exception_message_of_set(
        $component,
        'argument is not string',
    );
}

sub get_exception_message_of_set {
    my ($self, $component, $reason) = @_;

    my $message = "Cannot set ($component) because: $reason";

    return $self->to_regexp($message);
}

sub to_regexp {
    my ($self, $message) = @_;

    $message =~ s{(?=[()])}{\\}g;
    $message =~ s{ }{[ ]}g;

    return qr{
        \A
        $message
    }xms;
}

sub get_exception_message {
    my ($self, $attribute, $value, $reason) = @_;

    my $message = "Attribute ($attribute) "
                . "does not pass the type constraint because: "
                . "Validation failed for ($attribute) "
                . "failed with value ($value) because: "
                . $reason;

    return $self->to_regexp($message);
}


# ****************************************************************
# return true
# ****************************************************************

1;
__END__

Labeled.pm

package Text::UTX::Meta::Attribute::Trait::Labeled;


# ****************************************************************
# MOP dependencies
# ****************************************************************

use Moose::Role;


# ****************************************************************
# namespace clearer
# ****************************************************************

use namespace::clean -except => 'meta';


# ****************************************************************
# attributes
# ****************************************************************

has 'label' => (
    is          => 'rw',
    isa         => 'Str',
    predicate   => 'has_label',
);


# ****************************************************************
# register
# ****************************************************************

package Moose::Meta::Attribute::Custom::Trait::Labeled;

sub register_implementation {
    'Text::UTX::Meta::Attribute::Trait::Labeled';
}


# ****************************************************************
# return true
# ****************************************************************

1;
__END__

Language.pm

package Text::UTX::Component::Locale::Language;


# ****************************************************************
# MOP dependencies
# ****************************************************************

use Moose;
use MooseX::ClassAttribute;


# ****************************************************************
# general dependencies
# ****************************************************************

use Data::Util qw(:check);
use Locale::Language;


# ****************************************************************
# internal dependencies
# ****************************************************************

use Text::UTX::Meta::Attribute::Trait::Labeled;
use Text::UTX::Type::Component::Locale::Language;


# ****************************************************************
# namespace clearer
# ****************************************************************

use namespace::clean -except => 'meta';


# ****************************************************************
# class attributes
# ****************************************************************

has 'Count_Of_Chained_Attributes' => (
    is          => 'ro',
    isa         => 'Int',
    default     => 2,
);


# ****************************************************************
# attributes
# ****************************************************************

has 'code' => (
    traits      => [qw(
        Labeled
    )],
    is          => 'ro',
    isa         => 'Text::UTX::Type::Component::Locale::Language::Code',
    coerce      => 1,
    init_arg    => '_code',
    writer      => '_set_code',
    trigger     => \&_build_by_code,
    label       => 'code for identifying languages as defined in ISO 639-1',
);

has 'name' => (
    traits      => [qw(
        Labeled
    )],
    is          => 'ro',
    isa         => 'Text::UTX::Type::Component::Locale::Language::Name',
    coerce      => 1,
    init_arg    => '_name',
    writer      => '_set_name',
    trigger     => \&_build_by_name,
    label       => 'language name as defined in ISO 639-1',
);


# ****************************************************************
# roles
# ****************************************************************

with qw(
    Text::UTX::Role::LocaleLike
);


# ****************************************************************
# constructor hooks
# ****************************************************************

# ================================================================
# Purpose    : ???
# Usage      : ???
# Parameters : ???
# Returns    : ???
# Throws     : ??? / no exceptions
# Comments   : none
# See Also   : n/a
# ----------------------------------------------------------------
sub BUILDARGS {
    my $class = shift;

    if (@_ == 1 && ! ref $_[0]) {
        return {
            (     length $_[0] == 2 ? '_code'
                :                     '_name' ) => $_[0]
        };
    }
    else {
        return $class->SUPER::BUILDARGS(@_);
    }
}


# ****************************************************************
# public methods
# ****************************************************************

# ================================================================
# Purpose    : ???
# Usage      : ???
# Parameters : ???
# Returns    : ???
# Throws     : ??? / no exceptions
# Comments   : none
# See Also   : n/a
# ----------------------------------------------------------------
sub set {
    my ($self, $argument) = @_;

    $self->_validate_argument_of('language', $argument);

      length $argument == 2 ? $self->_set_code($argument)
    :                         $self->_set_name($argument);

    return $self;
}


# ****************************************************************
# protected/private mehtods
# ****************************************************************

# ================================================================
# Purpose    : ???
# Usage      : ???
# Parameters : ???
# Returns    : ???
# Throws     : ??? / no exceptions
# Comments   : none
# See Also   : n/a
# ----------------------------------------------------------------
sub _build_by_code {
    my $self = shift;

    return
        if $self->_get_caller_accessor eq __PACKAGE__ . '::_set_name';
        # if $self->_returned_to_start_of_chain(__PACKAGE__ . '::_set_name');

    $self->_set_name( code2language( $self->code ) );

    return;
}

# ================================================================
# Purpose    : ???
# Usage      : ???
# Parameters : ???
# Returns    : ???
# Throws     : ??? / no exceptions
# Comments   : none
# See Also   : n/a
# ----------------------------------------------------------------
sub _build_by_name {
    my $self = shift;

    return
        if $self->_get_caller_accessor eq __PACKAGE__ . '::_set_code';
        # if $self->_returned_to_start_of_chain(__PACKAGE__ . '::_set_code');

    $self->_set_code( language2code( $self->name ) );

    return;
}


# ****************************************************************
# return true
# ****************************************************************

__PACKAGE__->meta->make_immutable;
__END__

Language.pm

package Test::Text::UTX::Component::Locale::Language;


# ****************************************************************
# pragmas
# ****************************************************************

use strict;
use warnings;


# ****************************************************************
# superclasses
# ****************************************************************

use base qw(
    Test::Text::UTX::Component::Locale::Base
);


# ****************************************************************
# general dependencies
# ****************************************************************

use Test::Exception;
use Test::More;


# ****************************************************************
# internal dependencies
# ****************************************************************

use Test::Text::UTX::Mode;
use Text::UTX::Component::Locale::Language;


# ****************************************************************
# methods
# ****************************************************************

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

    return $self->get_exception_message(
        'code',
        $value,
        'Specified language code does not exist in ISO 639-1'
    );
}

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

    return $self->get_exception_message(
        'name',
        $value,
        'Specified language name does not exist in ISO 639-1'
    );
}


# ****************************************************************
# tests
# ****************************************************************

sub test_api : Tests(4) {
    my $self = shift;

    my $class = 'Text::UTX::Component::Locale::Language';

    $self->has_attributes($class, [qw(
        code
        name
    )]);
    $self->has_methods($class, [qw(
        set
    )]);
    $self->does_roles($class, [qw(
        Text::UTX::Role::LocaleLike
    )]);

    return;
}

sub test_new_without_attribute : Tests(4) {
    my $self = shift;

    my $language;
    lives_ok {
        $language = Text::UTX::Component::Locale::Language->new;
    } 'create without attribute (code/name)';
    isa_ok $language, 'Text::UTX::Component::Locale::Language';
    ok ! defined $language->code,
        'create without attribute (does not have code)';
    ok ! defined $language->name,
        'create without attribute (does not have name)';
    $self->diag_explain($language);

    return;
}

sub test_new_with_code : Tests(4) {
    my $self = shift;

    {
        my $language = Text::UTX::Component::Locale::Language->new('ja');
        is $language->code, 'ja',
            'create with code (small letter) - code';
        is $language->name, 'Japanese',
            'create with code (small letter) - name : chained';
    }
    {
        my $language = Text::UTX::Component::Locale::Language->new('JA');
        is $language->code, 'ja',
            'create with code (capital letter) - code';
        is $language->name, 'Japanese',
            'create with code (capital letter) - name : chained';
    }

    return;
}

sub test_new_with_name : Tests(4) {
    my $self = shift;

    {
        my $language = Text::UTX::Component::Locale::Language->new('japanese');
        is $language->code, 'ja',
            'create with name (small letter) - code : chained';
        is $language->name, 'Japanese',
            'create with name (small letter) - name';
    }
    {
        my $language = Text::UTX::Component::Locale::Language->new('JAPANESE');
        is $language->code, 'ja',
            'create with name (capital letter) - name : chained';
        is $language->name, 'Japanese',
            'create with name (capital letter) - name';
    }

    return;
}

sub test_exception_from_new : Tests(2) {
    my $self = shift;

    throws_ok {
        Text::UTX::Component::Locale::Language->new('__');
    } $self->get_exception_message_of_code('__'),
        'exception: create with invalid code';

    throws_ok {
        Text::UTX::Component::Locale::Language->new('________');
    } $self->get_exception_message_of_name('________'),
        'exception: create with invalid name';

    return;
}

sub test_set_name : Tests(4) {
    {
        my $language = Text::UTX::Component::Locale::Language->new;
        $language->set('japanese');
        is $language->code, 'ja',
            'set name (small letter) - code : chained';
        is $language->name, 'Japanese',
            'set name (small letter) - name';
    }
    {
        my $language = Text::UTX::Component::Locale::Language->new;
        $language->set('JAPANESE');
        is $language->code, 'ja',
            'set name (capital letter) - code : chained';
        is $language->name, 'Japanese',
            'set name (capital letter) - name';
    }

    return;
}

sub test_set_code : Tests(4) {
    my $self = shift;

    {
        my $language = Text::UTX::Component::Locale::Language->new;
        $language->set('ja');
        is $language->code, 'ja',
            'set code (small letter) - code';
        is $language->name, 'Japanese',
            'set code (small letter) - name : chained';
    }
    {
        my $language = Text::UTX::Component::Locale::Language->new;
        $language->set('JA');
        is $language->code, 'ja',
            'set code (capital letter) - code';
        is $language->name, 'Japanese',
            'set code (capital letter) - name : chained';
    }

    return;
}

sub test_exception_from_set : Tests(4) {
    my $self = shift;

    my $language = Text::UTX::Component::Locale::Language->new;

    throws_ok {
        $language->set();
    } $self->get_exception_message_of_argument_undefined('language'),
        'exception: set with undef';

    throws_ok {
        $language->set([]);
    } $self->get_exception_message_of_argument_is_not_string('language'),
        'exception: set without string';

    throws_ok {
        $language->set('__');
    } $self->get_exception_message_of_code('__'),
        'exception: set with invalid code';

    throws_ok {
        $language->set('________');
    } $self->get_exception_message_of_name('________'),
        'exception: set with invalid name';

    return;
}


# ****************************************************************
# return true
# ****************************************************************

1;
__END__

LocaleLike.pm

package Text::UTX::Role::LocaleLike;


# ****************************************************************
# MOP dependencies
# ****************************************************************

use Moose::Role;
use Data::Util qw(:check);


# ****************************************************************
# internal dependencies
# ****************************************************************

use Text::UTX::Meta::Attribute::Trait::Labeled;


# ****************************************************************
# namespace clearer
# ****************************************************************

use namespace::clean -except => 'meta';


# ****************************************************************
# interfaces
# ****************************************************************

requires qw(
    Count_Of_Chained_Attributes
);


# ****************************************************************
# protected/private mehtods
# ****************************************************************

# ================================================================
# Purpose    : ???
# Usage      : ???
# Parameters : ???
# Returns    : ???
# Throws     : ??? / no exceptions
# Comments   : none
# See Also   : n/a
# ----------------------------------------------------------------
sub _validate_argument_of {
    my ($self, $component, $argument) = @_;

    confess "Cannot set ($component) because: argument is not defined"
        unless defined $argument;
    confess "Cannot set ($component) because: argument is not string"
        unless is_string($argument);

    return;
}

# ================================================================
# Purpose    : ???
# Usage      : ???
# Parameters : ???
# Returns    : ???
# Throws     : ??? / no exceptions
# Comments   : 1) _set_name -> _build_by_name -> _set_code -> _build_by_code ->
#            :    _set_name ...
# See Also   : n/a
# ----------------------------------------------------------------
sub _get_caller_accessor {
    return ( caller($_[0]->Count_Of_Chained_Attributes * 2) )[3];
    # return ( caller($_[0]->Count_Of_Chained_Attributes * 2 + 1) )[3];
}

# # ================================================================
# # Purpose    : ???
# # Usage      : ???
# # Parameters : 1) Str : fully qualified method name of next setter
# # Returns    : ???
# # Throws     : ??? / no exceptions
# # Comments   : none
# # See Also   : n/a
# # ----------------------------------------------------------------
# sub _returned_to_start_of_chain {
#     return
#         if $_[0]->_get_caller_accessor eq $_[1];
# }



# ****************************************************************
# return true
# ****************************************************************

1;
__END__