Skip to content

Instantly share code, notes, and snippets.

@gardejo

gardejo/.gitignore

Created November 11, 2009 15:27
Show Gist options
  • Save gardejo/232025 to your computer and use it in GitHub Desktop.
Save gardejo/232025 to your computer and use it in GitHub Desktop.
Download ZIP
Basic infrastructure of Value Objects to Moose class
Raw
.gitignore
.*
!.gitignore
Makefile*
!Makefile.PL
META.yml
blib
build
inc
pm_to_blib
MANIFEST*
!MANIFEST.SKIP
Amikeco-Value-ValueLike-*
*.bs
cover_db
Raw
00_race.t
#!perl
use strict;
use warnings;
use lib 't/lib';
use Test::Amikeco::Value::Race;
Test::Amikeco::Value::Race->runtests;
__END__
Raw
10_member_rank.t
#!perl
use strict;
use warnings;
use lib 't/lib';
use Test::Amikeco::Value::Member::Rank;
Test::Amikeco::Value::Member::Rank->runtests;
__END__
Raw
README
NAME
----
Amikeco-Value-ValueLike
INSTALLATION
------------
To install this distribution,
first, to make Makefile, build this distribution and run tests
by the following command:
cpan -t .
next, to deploy this distribution
by the following command:
cpan -i .
DEPENDENCIES
------------
See C<Makefile.PL>.
DESCRIPTION
-----------
This Moose::Role modules provide basic infrastructure of
Value Objects to Moose class that consumes this role.
See further document of this distribution by the following commands:
perldoc Amikeco::Value::ValueLike
AUTHOR
------
MORIYA Masaki (a.k.a. "Gardejo")
<moriya@cpan.org>, http://ttt.ermitejo.com/
COPYRIGHT AND LICENSE
---------------------
Copyright (c) 2009 by MORIYA Masaki (a.k.a. "Gardejo"),
L<http://ttt.ermitejo.com>.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See perlgpl and perlartistic.
Raw
coverage.bat
REM for MS Windows
@echo off
setlocal
set HARNESS_PERL_SWITCHES=-MDevel::Cover=+ignore,inc,perl/site/lib,perl/lib,t/,xt/
rd /s /q cover_db 2>nul
dmake realclean
perl Makefile.PL
dmake manifest
prove -l && cover && start cover_db/coverage.html
Raw
coverage.sh
# for Unix, Linux, etc.
set HARNESS_PERL_SWITCHES=-MDevel::Cover=+ignore,inc,perl/site/lib,perl/lib,t/,xt/
rm -rf cover_db
make realclean
perl Makefile.PL
make manifest
prove -l
cover
open cover_db/coverage.html
Raw
LevelLike.pm
package Amikeco::Value::LevelLike;
# ****************************************************************
# MOP dependency(-ies)
# ****************************************************************
use Moose::Role;
# ****************************************************************
# general dependency(-ies)
# ****************************************************************
use List::MoreUtils qw(firstidx);
use Memoize qw(memoize);
use Sub::Name qw(subname);
# ****************************************************************
# namespace clearer
# ****************************************************************
use namespace::clean -except => [qw(meta)];
# ****************************************************************
# attribute(s)
# ****************************************************************
has '_index' => (
traits => [qw(
Counter
)],
is => 'ro',
# writer => '_set__index',
isa => 'Int',
init_arg => undef,
# Moose::Meta::Attribute::Native::Trait::Counter implicitly brings
# 'default' option to attribute, therefore 'lazy_build' is not capable.
lazy => 1,
predicate => 'has__index',
clearer => 'clear__index',
default => \&_build__index,
trigger => sub {
$_[0]->clear_number;
$_[0]->clear_name;
},
handles => {
promote => 'inc',
demote => 'dec',
},
);
# ****************************************************************
# consuming role(s) : must write after overriden methods
# ****************************************************************
with qw(
Amikeco::Value::WithValueObjectUtility
);
# ****************************************************************
# builder(s)
# ****************************************************************
sub _build_number {
$_[0]->has_name ? $_[0]->to_number( $_[0]->name )
: $_[0]->has__index ? ${ $_[0]->_numbers }[ $_[0]->_index ]
: $_[0]->to_number( $_[0]->default );
}
sub _build_name {
$_[0]->has_number ? $_[0]->to_name( $_[0]->number )
: $_[0]->has__index ? ${ $_[0]->_names }[ $_[0]->_index ]
: $_[0]->default;
}
sub _build__index {
my ($self) = @_;
$self->has_number ? firstidx { $_ == $self->number } @{ $self->_numbers }
: $self->has_name ? firstidx { $_ eq $self->name } @{ $self->_names }
: firstidx { $_ eq $self->default } @{ $self->_names };
}
# ****************************************************************
# trigger(s)
# ****************************************************************
sub _trigger_name {
$_[0]->clear_number;
$_[0]->clear__index;
}
sub _trigger_number {
$_[0]->clear_name;
$_[0]->clear__index;
}
# ****************************************************************
# limitter(s)
# ****************************************************************
around promote => sub {
my ($next, $self) = @_;
return if $self->is_maximum;
return $self->$next;
};
around demote => sub {
my ($next, $self) = @_;
return if $self->is_minimum;
return $self->$next;
};
# ****************************************************************
# estimator(s)
# ****************************************************************
sub is_maximum {
$_[0]->has_number ? $_[0]->number == $_[0]->maximum_number
: $_[0]->has_name ? $_[0]->name eq $_[0]->maximum_name
: $_[0]->_index == $#{ $_[0]->_numbers };
}
sub is_minimum {
$_[0]->has_number ? $_[0]->number == $_[0]->minimum_number
: $_[0]->has_name ? $_[0]->name eq $_[0]->minimum_name
: $_[0]->_index == 0;
}
# ****************************************************************
# convenience mutator(s)
# ****************************************************************
sub maximize {
# $_[0]->has_number ? $_[0]->number($_[0]->maximum_number)
# : $_[0]->has_name ? $_[0]->name($_[0]->maximum_name)
# : $_[0]->_set__index(-1);
$_[0]->number($_[0]->maximum_number);
}
sub minimize {
# $_[0]->has_number ? $_[0]->number($_[0]->minimum_number)
# : $_[0]->has_name ? $_[0]->name($_[0]->minimum_name)
# : $_[0]->_set__index(0);
$_[0]->number($_[0]->minimum_number);
}
# ****************************************************************
# method(s) as class constant(s)
# ****************************************************************
sub minimum_number {
${ $_[0]->_numbers }[0];
}
sub maximum_number {
${ $_[0]->_numbers }[-1];
}
sub minimum_name {
${ $_[0]->_names }[0];
}
sub maximum_name {
${ $_[0]->_names }[-1];
}
# ****************************************************************
# definer(s) of type constraint(s)
# ****************************************************************
sub _type_constraints {
my $role = shift;
return {
name => {
name => $role . '::LevelName',
enum => $role->_names,
},
number => {
name => $role . '::LevelNumber',
enum => $role->_numbers,
},
};
}
# ****************************************************************
# memoization
# ****************************************************************
# it is not capable that Amikeco::Value::WithValueObjectUtility::_memoize
# memoizes $consumed_role->_memoizing_methods
sub _memoize {
no strict 'refs'; ## no critic
foreach my $method qw(
_numbers _names
_names_to_numbers _numbers_to_names
to_number to_name
maximum_number maximum_name
minimum_number minimum_name
) {
*{ $method } = subname $_[0] . '::' . $method => memoize($method);
}
};
# ****************************************************************
# compile-time process(es)
# ****************************************************************
__PACKAGE__->_memoize;
# ****************************************************************
# return true
# ****************************************************************
1;
__END__
# ****************************************************************
# POD
# ****************************************************************
=pod
=head1 NAME
Amikeco::Value::LevelLike - Role of level-like Value Objects for Moose
=head1 SYNOPSIS
{
package Amikeco::Value::Member::Rank;
use Moose;
with qw(Amikeco::Value::LevelLike);
sub alignment {
{
guest => 0,
applicant => 1,
mate => 4,
officer => 6,
vice_leader => 8,
leader => 9,
};
}
sub default {
'guest';
}
__PACKAGE__->_modify_type_constraints; # CAVEAT: REMEMBER IT!
__PACKAGE__->meta->make_immutable;
}
{
package main;
my $from_database = 0; # 0
my $rank = Amikeco::Value::Member::Rank->inflate($from_database);
$rank->promote; # 0(guest) to 1(applicant)
$rank->demote; # 1(applicant) to 0(guest)
$rank->number(8); # 0(guest) to 8(vice_leader)
$rank->maximize; # 8(vice_leader) to 9(leader)
$rank->name('officer'); # 9(leader) to 6(officer)
my $to_database = $rank->deflate; # 6
}
=head1 DESCRIPTION
This Moose::Role module provides basic infrastructure of level-based
Value Objects to Moose class that consumes this role.
=head1 ATTRIBUTES
See L<the same section on document of Amikeco::Value::WithValueObjectUtility
|Amikeco::Value::WithValueObjectUtility/ATTRIBUTES>.
=head1 INTERFACES
See L<the same section on document of Amikeco::Value::WithValueObjectUtility
|Amikeco::Value::WithValueObjectUtility/INTERFACES>.
=head1 METHODS
=head2 Estimators
=head3 C<< $level->is_maximum() >>
Returns true if C<$level> is maximum, otherwise false.
=head3 C<< $level->is_minimum() >>
Returns true if C<$level> is minimum, otherwise false.
=head2 Convenience mutators
=head3 C<< $level->maximize() >>
It is the sugar method of C<< $level->number($level->maximum) >>.
=head3 C<< $level->minimize() >>
It is the sugar method of C<< $level->number($level->minimum) >>.
=head2 Methods as class constants
=head3 C<< LevelClass->maximum_number() >>
Returns an integer of the maximum level number.
=head3 C<< LevelClass->minimum_number() >>
Returns an integer of the minimum level number.
=head3 C<< LevelClass->maximum_name() >>
Returns a string of the maximum level name.
=head3 C<< LevelClass->minimum_name() >>
Returns a string of the minimum level name.
=head2 Other methods
Other several methods are provided by L<Amikeco::Value::WithValueObjectUtility>.
See L<the same section on document of Amikeco::Value::WithValueObjectUtility
|Amikeco::Value::WithValueObjectUtility/METHODS>.
=head1 NOTE
=head2 Mousification
To run this role with L<Mouse>, change
use Moose::Role;
# ...
has '_index' => (
traits => [qw(
Counter
)],
is => 'ro',
# writer => '_set__index',
# ...
handles => {
promote => 'inc',
demote => 'dec',
},
);
# ...
around promote => sub {
my ($next, $self) = @_;
return if $self->is_maximum;
return $self->$next;
};
around demote => sub {
my ($next, $self) = @_;
return if $self->is_minimum;
return $self->$next;
};
into
use Any::Moose '::Role';
use Module::Loaded;
if (is_loaded('Mouse::Role')) {
require MouseX::AttributeHelpers;
MouseX::AttributeHelpers->import;
}
# ...
has '_index' => (
(
is_loaded('Mouse::Role') ? (
metaclass => 'Counter',
is => 'rw',
writer => '_set__index',
provides => {
inc => 'promote',
dec => 'demote',
},
) : (
traits => [qw(
Counter
)],
is => 'ro',
handles => {
promote => 'inc',
demote => 'dec',
},
)
),
# ...
);
# ...
around promote => sub {
my ($next, $self) = @_;
return if $self->is_maximum;
$self->_set__index($self->_build__index)
if is_loaded('Mouse::Role');
return $self->$next;
};
around demote => sub {
my ($next, $self) = @_;
return if $self->is_minimum;
$self->_set__index($self->_build__index)
if is_loaded('Mouse::Role');
return $self->$next;
};
carefully. It is a hard work.
If I were a Perl hacker, I would port L<Moose::Meta::Attribute::Native>
to C<Mouse::Meta::Attribute::Native>...
=head3 Effects of Mousification
See L<the same section on document of Amikeco::Value::ValueLike
|Amikeco::Value::ValueLike/Effects_of_Mousification>
=head1 SEE ALSO
=over 4
=item L<Amikeco::Value::WithValueObjectUtility>
This role provides several methods below:
C<< $level->reset() >>,
C<< LevelClass->inflate($number) >>, C<< $level->deflate() >>,
C<< LevelClass->to_number($name) >>, C<< LevelClass->to_name($number) >>.
=item L<Amikeco::Value::ValueLike>
This role is variant of L<Amikeco::Value::LevelLike>.
Below is non-existence methods:
C<< $value->is_maximum() >>, C<< $value->is_minimum() >>,
C<< $value->maximize() >>, C<< $value->minimize() >>,
C<< ValueClass->maximum_number() >>, C<< ValueClass->minimum_number() >>,
C<< ValueClass->maximum_name() >>, C<< ValueClass->minimum_name() >>.
=item Memoizing role methods
L<http://thread.gmane.org/gmane.comp.lang.perl.moose/793/focus=797>
=item Value Objects
Martin Fowler,
I<Patterns of Enterprise Application Architecture>,
Toronto: Addison-Wesley Professional,
2002,
560p.,
ISBN 0321127420 / 978-0321127426
=item dualvar
This module does not use L<Scalar::Util::dualvar()|Scalar::Util>
for number/name alignment
because non-acrobatic values favorable for return value.
=back
=head1 INCOMPATIBILITIES
See L<the same section on document of Amikeco|Amikeco/INCOMPATIBILITIES>
=head1 BUGS AND LIMITATIONS
See L<the same section on document of Amikeco|Amikeco/BUGS_AND_LIMITATIONS>
=head1 SUPPORT
See L<the same section on document of Amikeco|Amikeco/SUPPORT>
=head1 VERSION CONTROL
This module is maintained using git.
You can get the latest version from
L<git://github.com/gardejo/p5-amikeco.git>.
=head1 AUTHOR
=over 4
=item MORIYA Masaki (a.k.a. "Gardejo")
C<< <moriya@cpan.org> >>,
L<http://ttt.ermitejo.com/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2009 by MORIYA Masaki (a.k.a. "Gardejo"),
L<http://ttt.ermitejo.com>.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl> and L<perlartistic>.
=cut
Raw
LevelLike.pm
package Test::Amikeco::Value::LevelLike;
# ****************************************************************
# pragma(s)
# ****************************************************************
use strict;
use warnings;
# ****************************************************************
# superclass(es)
# ****************************************************************
use base qw(
Test::Amikeco::Value::ValueLike
);
# ****************************************************************
# namespace clearer
# ****************************************************************
use namespace::clean;
# ****************************************************************
# general dependency(-ies)
# ****************************************************************
use Test::Exception;
use Test::More;
# use Test::Most;
# ****************************************************************
# test(s)
# ****************************************************************
sub test_promote : Tests(no_plan) {
my $self = shift;
my @value_numbers = $self->_value_numbers;
$self->{instance} = $self->{class}->new(
number => $value_numbers[0],
);
my $value_index = 0;
while ($value_index < $#value_numbers) {
$self->{instance}->promote;
is $self->{instance}->number, $value_numbers[$value_index + 1]
=> sprintf(
'promote (%d to %d) ok',
$value_numbers[$value_index],
$value_numbers[$value_index + 1],
);
$value_index++;
}
$self->{instance}->promote;
is $self->{instance}->number, $value_numbers[$value_index]
=> sprintf(
'does not promote (%d) ok',
$value_numbers[$value_index],
);
return;
}
sub test_demote : Tests(no_plan) {
my $self = shift;
my @value_numbers = $self->_value_numbers;
$self->{instance} = $self->{class}->new(
number => $value_numbers[-1],
);
my $value_index = $#value_numbers;
while ($value_index > 0) {
$self->{instance}->demote;
is $self->{instance}->number, $value_numbers[$value_index - 1]
=> sprintf(
'demote (%d to %d) ok',
$value_numbers[$value_index],
$value_numbers[$value_index - 1],
);
$value_index--;
}
$self->{instance}->demote;
is $self->{instance}->number, $value_numbers[$value_index]
=> sprintf(
'does not demote (%d) ok',
$value_numbers[$value_index],
);
return;
}
sub test_maximum : Tests(4) {
my $self = shift;
is $self->{instance}->maximize, ($self->_value_numbers)[-1]
=> 'maximize ok';
ok $self->{instance}->is_maximum
=> 'maximum ok';
is $self->{instance}->number, $self->{class}->maximum_number
=> 'maximum_number ok';
is $self->{instance}->name, $self->{class}->maximum_name
=> 'maximum_name ok';
return;
}
sub test_minimum : Tests(4) {
my $self = shift;
is $self->{instance}->minimize, ($self->_value_numbers)[0]
=> 'minimize ok';
ok $self->{instance}->is_minimum
=> 'is_minimum ok';
is $self->{instance}->number, $self->{class}->minimum_number
=> 'minimum_number ok';
is $self->{instance}->name, $self->{class}->minimum_name
=> 'minimum_name ok';
return;
}
# ****************************************************************
# return true
# ****************************************************************
1;
__END__
# ****************************************************************
# POD
# ****************************************************************
=pod
=head1 NAME
Test::Amikeco::Value::LevelLike - Testing baseclass for classes that consumes Amikeco::Value::LevelLike
=head1 SYNOPSIS
package Test::Amikeco::Value::Member::Rank;
use base qw(
Test::Amikeco::Value::LevelLike
);
# ...
=head1 DESCRIPTION
This module tests classes that consumes L<Amikeco::Value::LevelLike>.
=head1 AUTHOR
=over 4
=item MORIYA Masaki (a.k.a. "Gardejo")
C<< <moriya@cpan.org> >>,
L<http://ttt.ermitejo.com/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2009 by MORIYA Masaki (a.k.a. "Gardejo"),
L<http://ttt.ermitejo.com>.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl> and L<perlartistic>.
=cut
Raw
Makefile.PL
#!/usr/bin/perl
use strict;
use warnings;
use inc::Module::Install;
my $application_root_module
= 'lib/Amikeco/Value/ValueLike.pm';
# ================================================================
# meta information
# ================================================================
# abstract, author, license, name, perl_version, version
all_from $application_root_module;
perl_version 5.008_001;
version "0.00";
# supplement
author 'MORIYA Masaki (a.k.a. "Gardejo") <moriya@cpan.org>';
resources (
repository
=> 'git://gist.github.com/232025.git',
bugtracker
=> undef,
homepage
=> 'http://gist.github.com/232025',
);
# no_index directory => 'examples';
# no_index directory => 'extlib';
# ================================================================
# build dependencies
# ================================================================
build_requires 'Module::Install' => '0.80'; # YAML::Tiny problem
build_requires 'Module::Load' => '0'; # > perl 5.009_004
# ================================================================
# general dependencies
# ================================================================
requires 'List::MoreUtils' => '0';
requires 'Memoize' => '0';
requires 'Moose' => '0.41';
requires 'Sub::Name' => '0';
requires 'namespace::clean' => '0.08'; # cf. MX-Types-DateTime
# ================================================================
# dependencies for tests
# ================================================================
test_requires 'Test::Class' => '0'; # without intention
test_requires 'Test::Exception' => '0.27'; # cf. MX-Types-DateTime
test_requires 'Test::More' => '0'; # without intention
test_requires 'Test::Warn' => '0'; # without intention
# ================================================================
# tests
# ================================================================
use_test_base;
tests 't/*.t';
author_tests 'xt';
# ================================================================
# installation
# ================================================================
auto_include;
auto_install;
# ================================================================
# META.yml writter
# ================================================================
WriteAll;
__END__
# ****************************************************************
# POD
# ****************************************************************
=pod
=head1 NAME
Makefile.PL - Makefile builder for gist: 232025
=head1 SYNOPSIS
$ cpan -t .
=head1 AUTHOR
=over 4
=item MORIYA Masaki (a.k.a. "Gardejo")
C<< <moriya@cpan.org> >>,
L<http://ttt.ermitejo.com/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2009 by MORIYA Masaki (a.k.a. "Gardejo"),
L<http://ttt.ermitejo.com>.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl> and L<perlartistic>.
=cut
Raw
MANIFEST.SKIP
# This MANIFEST.SKIP file was stolen from MooseX-Types-DateTime
# Avoid version control files.
\bRCS\b
\bCVS\b
\bSCCS\b
,v$
\B\.svn\b
\B\.git\b
\b_darcs\b
# Avoid Makemaker generated and utility files.
\bMANIFEST\.bak
\bMakefile$
\bblib/
\bMakeMaker-\d
\bpm_to_blib\.ts$
\bpm_to_blib$
\bblibdirs\.ts$ # 6.18 through 6.25 generated this
# Avoid Module::Build generated and utility files.
\bBuild$
\b_build/
# Avoid temp and backup files.
~$
\.old$
\#$
\b\.#
\.bak$
# Avoid Devel::Cover files.
\bcover_db\b
### DEFAULT MANIFEST.SKIP ENDS HERE ####
\.DS_Store$
\.sw.$
(\w+-)*(\w+)-\d\.\d+(?:\.tar\.gz)?$
\.t\.log$
Raw
meta.t
#!perl -T
use Test::More;
eval {
require Test::CPAN::Meta;
Test::CPAN::Meta->import;
die if Test::CPAN::Meta->VERSION < 0.12;
};
Test::More::plan( skip_all =>
"Test::CPAN::Meta 0.12 required " .
"for testing that META.yml file matches the current specification."
) if $@;
meta_yaml_ok();
Raw
no_tabs.t
#!perl -T
use FindBin;
eval {
require Test::NoTabs;
Test::NoTabs->import;
};
Test::More::plan( skip_all =>
"Test::NoTabs required " .
"for testing presence of tabs"
) if $@;
# inc/ModuleInstall/* will die.
# all_perl_files_ok();
# cannnot read /lib/* (?)
all_perl_files_ok("$FindBin::Bin/../lib");
Raw
perlcritic.t
#!perl -T
eval {
require Perl::Critic;
Perl::Critic->import;
die if Perl::Critic->VERSION < 1.094; # for equivalent_modules
require Test::Perl::Critic;
# 'use Any::Moose' and 'use Ark' are same as 'use strict' and 'use warnings'
Test::Perl::Critic->import(
-profile => 'xt/perlcriticrc',
);
};
Test::More::plan( skip_all =>
"Perl::Critic 1.094 and Test::Perl::Critic required " .
"for testing PBP compliance"
) if $@;
all_critic_ok();
Raw
perlcriticrc
[TestingAndDebugging::RequireUseStrict]
equivalent_modules = MooseX::Types
[TestingAndDebugging::RequireUseWarnings]
equivalent_modules = MooseX::Types
Raw
pod.t
#!perl -T
eval {
require Test::Pod;
Test::Pod->import;
die if Test::Pod->VERSION < 1.40;
};
Test::More::plan( skip_all =>
"Test::Pod 1.40 required " .
"for testing POD"
) if $@;
all_pod_files_ok();
Raw
pod_coverage.t
#!perl -T
eval {
require Test::Pod::Coverage;
Test::Pod::Coverage->import;
die if Test::Pod::Coverage->VERSION < 1.08;
};
Test::More::plan( skip_all =>
"Test::Pod::Coverage 1.08 required " .
"for testing POD coverage"
) if $@;
all_pod_coverage_ok('lib');
# note: Devel::Cover and Attribute::Protected and Test::Pod::Coverage
# are incompatible?
Raw
Race.pm
package Amikeco::Value::Race;
# ****************************************************************
# MOP dependency(-ies)
# ****************************************************************
use Moose;
# ****************************************************************
# namespace clearer
# ****************************************************************
use namespace::clean -except => [qw(meta)];
# ****************************************************************
# consuming role(s)
# ****************************************************************
with qw(
Amikeco::Value::ValueLike
);
# ****************************************************************
# method(s) as class constant(s)
# ****************************************************************
sub alignment {
{
# name => number
q{hyuran} => 0, # ヒューラン
q{lalafell} => 1, # ララフェル
q{roegadyn} => 2, # ルガディン
q{elezen} => 3, # エレゼン
q{miqo'te} => 4, # ミコッテ
};
}
sub default {
confess 'Default race is not defined';
}
# ****************************************************************
# compile-time process(es)
# ****************************************************************
__PACKAGE__->_modify_type_constraints;
__PACKAGE__->meta->make_immutable;
# ****************************************************************
# return true
# ****************************************************************
1;
__END__
# ****************************************************************
# POD
# ****************************************************************
=pod
=head1 NAME
Amikeco::Value::Race - Race as Value Object
=head1 SYNOPSIS
package Amikeco::Schema::Avatar;
# created by DBIx::Class::Schema::Loader
# ...
use Amikeco::Value::Race;
__PACKAGE__->inflate_column('race' => {
inflate => sub { Amikeco::Value::Race->inflate($_[0]); },
deflate => sub { $_[0]->deflate; },
});
# ...
=head1 DESCRIPTION
This Moose class explains avatar's race as Value Object.
=head1 METHODS
=head2 Methods as class constants
=head3 C<< Amikeco::Value::Race->alignment >>
Returns a hash reference that defines the relationship
between race names and race numbers.
=head3 C<< Amikeco::Value::Race->default >>
Throws an exception, because this class has no default race.
=head1 SEE ALSO
=over 4
=item localizer
To localize names, use any localizer
(L<Data::Localize>, L<Locale::Maketext>, etc.).
=item L<Amikeco::Value::LevelLike>
This consumied role provides several methods.
=back
=head1 INCOMPATIBILITIES
See L<the same section on document of Amikeco|Amikeco/INCOMPATIBILITIES>
=head1 BUGS AND LIMITATIONS
See L<the same section on document of Amikeco|Amikeco/BUGS_AND_LIMITATIONS>
=head1 SUPPORT
See L<the same section on document of Amikeco|Amikeco/SUPPORT>
=head1 VERSION CONTROL
This module is maintained using git.
You can get the latest version from
L<git://github.com/gardejo/p5-amikeco.git>.
=head1 AUTHOR
=over 4
=item MORIYA Masaki (a.k.a. "Gardejo")
C<< <moriya@cpan.org> >>,
L<http://ttt.ermitejo.com/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2009 by MORIYA Masaki (a.k.a. "Gardejo"),
L<http://ttt.ermitejo.com>.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl> and L<perlartistic>.
=cut
Raw
Race.pm
package Test::Amikeco::Value::Race;
# ****************************************************************
# pragma(s)
# ****************************************************************
use strict;
use warnings;
# ****************************************************************
# superclass(es)
# ****************************************************************
use base qw(
Test::Amikeco::Value::ValueLike
);
# ****************************************************************
# general dependency(-ies)
# ****************************************************************
use Test::Exception;
# ****************************************************************
# namespace clearer
# ****************************************************************
use namespace::clean;
# ****************************************************************
# internal dependency(-ies)
# ****************************************************************
use Amikeco::Value::Race;
# ****************************************************************
# method(s) as class constant(s)
# ****************************************************************
sub _target_class {
'Amikeco::Value::Race';
}
sub _value_numbers {
return (0 .. 4);
# oops, the logic below is same as tested class...
# return sort { $a <=> $b } values %{ { $_[0]->_alignment } };
}
sub _alignment {
return (
q{hyuran} => 0,
q{lalafell} => 1,
q{roegadyn} => 2,
q{elezen} => 3,
q{miqo'te} => 4,
);
}
sub _message_pattern {
my ($self, $key) = @_;
my %message_pattern = (
$self->SUPER::_message_pattern,
(
default_not_supported
=> qr{Default race is not defined},
),
);
return $key ? $message_pattern{$key} : %message_pattern;
}
# ****************************************************************
# test(s)
# ****************************************************************
sub test_default : Tests(1) {
my $self = shift;
my $message_pattern = $self->_message_pattern('default_not_supported');
throws_ok {
$self->{class}->default;
} $message_pattern
=> q{default not supported};
return;
}
sub test_reset : Tests(1) {
my $self = shift;
my $message_pattern = $self->_message_pattern('default_not_supported');
throws_ok {
$self->{class}->reset;
} $message_pattern
=> q{default not supported};
return;
}
# ****************************************************************
# return true
# ****************************************************************
1;
__END__
# ****************************************************************
# POD
# ****************************************************************
=pod
=head1 NAME
Test::Amikeco::Value::Race - Testing baseclass for Amikeco::Value::Race
=head1 SYNOPSIS
use Test::Amikeco::Value::Race;
Test::Amikeco::Value::Race->runtests;
=head1 DESCRIPTION
This module tests L<Amikeco::Value::Race>.
=head1 AUTHOR
=over 4
=item MORIYA Masaki (a.k.a. "Gardejo")
C<< <moriya@cpan.org> >>,
L<http://ttt.ermitejo.com/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2009 by MORIYA Masaki (a.k.a. "Gardejo"),
L<http://ttt.ermitejo.com>.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl> and L<perlartistic>.
=cut
Raw
Rank.pm
package Amikeco::Value::Member::Rank;
# ****************************************************************
# MOP dependency(-ies)
# ****************************************************************
use Moose;
# ****************************************************************
# namespace clearer
# ****************************************************************
use namespace::clean -except => [qw(meta)];
# ****************************************************************
# consuming role(s)
# ****************************************************************
with qw(
Amikeco::Value::LevelLike
);
# ****************************************************************
# method(s) as class constant(s)
# ****************************************************************
sub alignment {
{
# name => number(level)
guest => 0, # 客員
applicant => 1, # 応募者
mate => 4, # 正員
officer => 6, # 役員
vice_leader => 8, # 副代表
leader => 9, # 代表
};
}
sub default {
'guest';
}
# ****************************************************************
# compile-time process(es)
# ****************************************************************
__PACKAGE__->_modify_type_constraints;
__PACKAGE__->meta->make_immutable;
# ****************************************************************
# return true
# ****************************************************************
1;
__END__
# ****************************************************************
# POD
# ****************************************************************
=pod
=head1 NAME
Amikeco::Value::Member::Rank - Rank of membership as Value Object
=head1 SYNOPSIS
package Amikeco::Schema::Member;
# created by DBIx::Class::Schema::Loader
# ...
use Amikeco::Value::Member::Rank;
__PACKAGE__->inflate_column('rank' => {
inflate => sub { Amikeco::Value::Member::Rank->inflate($_[0]); },
deflate => sub { $_[0]->deflate; },
});
# ...
=head1 DESCRIPTION
This Moose class explains avatar's rank in communities as Value Object.
=head1 METHODS
=head2 Methods as class constants
=head3 C<< Amikeco::Value::Member::Rank->alignment >>
Returns a hash reference that defines the relationship
between rank names and rank numbers.
=head3 C<< Amikeco::Value::Member::Rank->default >>
Returns a string that defines the name of the default member rank.
=head1 SEE ALSO
=over 4
=item localizer
To localize names, use any localizer
(L<Data::Localize>, L<Locale::Maketext>, etc.).
=item L<Amikeco::Value::LevelLike>
This consumied role provides several methods.
=back
=head1 INCOMPATIBILITIES
See L<the same section on document of Amikeco|Amikeco/INCOMPATIBILITIES>
=head1 BUGS AND LIMITATIONS
See L<the same section on document of Amikeco|Amikeco/BUGS_AND_LIMITATIONS>
=head1 SUPPORT
See L<the same section on document of Amikeco|Amikeco/SUPPORT>
=head1 VERSION CONTROL
This module is maintained using git.
You can get the latest version from
L<git://github.com/gardejo/p5-amikeco.git>.
=head1 AUTHOR
=over 4
=item MORIYA Masaki (a.k.a. "Gardejo")
C<< <moriya@cpan.org> >>,
L<http://ttt.ermitejo.com/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2009 by MORIYA Masaki (a.k.a. "Gardejo"),
L<http://ttt.ermitejo.com>.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl> and L<perlartistic>.
=cut
Raw
Rank.pm
package Test::Amikeco::Value::Member::Rank;
# ****************************************************************
# pragma(s)
# ****************************************************************
use strict;
use warnings;
# ****************************************************************
# superclass(es)
# ****************************************************************
use base qw(
Test::Amikeco::Value::LevelLike
);
# ****************************************************************
# namespace clearer
# ****************************************************************
use namespace::clean;
# ****************************************************************
# internal dependency(-ies)
# ****************************************************************
use Amikeco::Value::Member::Rank;
# ****************************************************************
# method(s) as class constant(s)
# ****************************************************************
sub _target_class {
'Amikeco::Value::Member::Rank';
}
sub _value_numbers {
return qw(0 1 4 6 8 9);
# oops, the logic below is same as tested class...
# return sort { $a <=> $b } values %{ { $_[0]->_alignment } };
}
sub _alignment {
return (
guest => 0,
applicant => 1,
mate => 4,
officer => 6,
vice_leader => 8,
leader => 9,
);
}
sub _default {
'guest';
}
# ****************************************************************
# return true
# ****************************************************************
1;
__END__
# ****************************************************************
# POD
# ****************************************************************
=pod
=head1 NAME
Test::Amikeco::Value::Member::Rank - Testing class for Amikeco::Value::Member::Rank
=head1 SYNOPSIS
use Test::Amikeco::Value::Member::Rank;
Test::Amikeco::Value::Member::Rank->runtests;
=head1 DESCRIPTION
This module tests L<Amikeco::Value::Member::Rank>.
=head1 AUTHOR
=over 4
=item MORIYA Masaki (a.k.a. "Gardejo")
C<< <moriya@cpan.org> >>,
L<http://ttt.ermitejo.com/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2009 by MORIYA Masaki (a.k.a. "Gardejo"),
L<http://ttt.ermitejo.com>.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl> and L<perlartistic>.
=cut
Raw
synopsis.t
#!perl -T
eval {
require Test::Synopsis;
Test::Synopsis->import;
die if Test::Synopsis->VERSION < 0.06;
};
Test::More::plan( skip_all =>
"Test::Synopsis 0.06 required " .
"for testing POD synopsis"
) if $@;
all_synopsis_ok('lib');
Raw
use_all_modules.t
#!perl -T
eval {
require Test::UseAllModules;
Test::UseAllModules->import;
};
Test::More::plan( skip_all =>
"Test::UseAllModules required " .
"for testing presence of all manifested modules"
) if $@;
all_uses_ok();
Raw
ValueLike.pm
package Amikeco::Value::ValueLike;
# ****************************************************************
# MOP dependency(-ies)
# ****************************************************************
use Moose::Role;
# ****************************************************************
# general dependency(-ies)
# ****************************************************************
use Memoize qw(memoize);
use Sub::Name qw(subname);
# ****************************************************************
# namespace clearer
# ****************************************************************
use namespace::clean -except => [qw(meta)];
# ****************************************************************
# consuming role(s) : must write after overriden methods
# ****************************************************************
with qw(
Amikeco::Value::WithValueObjectUtility
);
# ****************************************************************
# builder(s)
# ****************************************************************
sub _build_number {
$_[0]->has_name ? $_[0]->to_number( $_[0]->name )
: $_[0]->to_number( $_[0]->default );
}
sub _build_name {
$_[0]->has_number ? $_[0]->to_name( $_[0]->number )
: $_[0]->default;
}
# ****************************************************************
# trigger(s)
# ****************************************************************
sub _trigger_name {
$_[0]->clear_number;
}
sub _trigger_number {
$_[0]->clear_name;
}
# ****************************************************************
# modifier(s) of type constraint(s)
# ****************************************************************
sub _type_constraints {
my $role = shift;
return {
name => {
name => $role . '::ValueName',
enum => $role->_names,
},
number => {
name => $role . '::ValueNumber',
enum => $role->_numbers,
},
};
}
# ****************************************************************
# memoization
# ****************************************************************
# it is not capable that Amikeco::Value::WithValueObjectUtility::_memoize
# memoizes $consumed_role->_memoizing_methods
sub _memoize {
no strict 'refs'; ## no critic
foreach my $method qw(
_numbers _names
_names_to_numbers _numbers_to_names
to_number to_name
) {
*{ $method } = subname __PACKAGE__ . '::' . $method => memoize($method);
}
}
# ****************************************************************
# compile-time process(es)
# ****************************************************************
__PACKAGE__->_memoize;
# ****************************************************************
# return true
# ****************************************************************
1;
__END__
# ****************************************************************
# POD
# ****************************************************************
=pod
=head1 NAME
Amikeco::Value::ValueLike - Role of Value Objects for Moose
=head1 SYNOPSIS
{
package Amikeco::Value::Race;
use Moose;
with qw(Amikeco::Value::ValueLike);
sub alignment {
{
q{hyuran} => 0,
q{lalafell} => 1,
q{roegadyn} => 2,
q{elezen} => 3,
q{miqo'te} => 4,
};
}
sub default {
confess 'Default race is not defined';
}
__PACKAGE__->_modify_type_constraints; # CAVEAT: REMEMBER IT!
__PACKAGE__->meta->make_immutable;
}
{
package main;
my $from_database = 0; # 0
my $race = Amikeco::Value::Race->inflate($from_database);
$race->number(4); # 0(hyuran) to 4(miqo'te)
$race->name('lalafell'); # 4(miqo'te) to 1(lalafell)
my $to_database = $race->deflate; # 1
}
=head1 DESCRIPTION
This Moose::Role module provides basic infrastructure of
Value Objects to Moose class that consumes this role.
=head1 ATTRIBUTES
See L<the same section on document of Amikeco::Value::WithValueObjectUtility
|Amikeco::Value::WithValueObjectUtility/ATTRIBUTES>.
=head1 INTERFACES
See L<the same section on document of Amikeco::Value::WithValueObjectUtility
|Amikeco::Value::WithValueObjectUtility/INTERFACES>.
=head1 METHODS
All public methods are provided by L<Amikeco::Value::WithValueObjectUtility>.
See L<the same section on document of Amikeco::Value::WithValueObjectUtility
|Amikeco::Value::WithValueObjectUtility/METHODS>.
=head1 NOTE
=head2 Mousification
To run this role with L<Mouse>, change
use Moose::Role;
into
use Any::Moose '::Role';
simply.
But, Mousification in L<Amikeco::Value::LevelLike> is a hard work.
See L<Mousification in Amikeco::Value::LevelLike|
Amikeco::Value::LevelLike/Mousification>.
=head3 Effects of Mousification
=head4 Moose version
$ prove -l --timer
[01:05:33] t\00_race.t ......... ok 614 ms
[01:05:34] t\10_member_rank.t .. ok 681 ms
[01:05:34]
All tests successful.
Files=2, Tests=192, 1 wallclock secs ( 0.13 usr + 0.02 sys = 0.14 CPU)
Result: PASS
=head4 Mouse version
$ prove -l --timer
[01:02:05] t\00_race.t ......... ok 338 ms
[01:02:05] t\10_member_rank.t .. ok 394 ms
[01:02:05]
All tests successful.
Files=2, Tests=192, 1 wallclock secs ( 0.11 usr + 0.00 sys = 0.11 CPU)
Result: PASS
=head1 SEE ALSO
=over 4
=item L<Amikeco::Value::WithValueObjectUtility>
This role provides several methods below:
C<< $value->reset() >>,
C<< ValueClass->inflate($number) >>, C<< $value->deflate() >>,
C<< ValueClass->to_number($name) >>, C<< ValueClass->to_name($number) >>.
=item L<Amikeco::Value::LevelLike>
This role is variant of L<Amikeco::Value::ValueLike>.
Below is additional methods:
C<< $level->is_maximum() >>, C<< $level->is_minimum() >>,
C<< $level->maximize() >>, C<< $level->minimize() >>,
C<< LevelClass->maximum_number() >>, C<< LevelClass->minimum_number() >>,
C<< LevelClass->maximum_name() >>, C<< LevelClass->minimum_name() >>.
=item Memoizing role methods
L<http://thread.gmane.org/gmane.comp.lang.perl.moose/793/focus=797>
=item Value Objects
Martin Fowler,
I<Patterns of Enterprise Application Architecture>,
Toronto: Addison-Wesley Professional,
2002,
560p.,
ISBN 0321127420 / 978-0321127426
=item dualvar
This module does not use L<Scalar::Util::dualvar()|Scalar::Util>
for number/name alignment
because non-acrobatic values favorable for return value.
=back
=head1 INCOMPATIBILITIES
See L<the same section on document of Amikeco|Amikeco/INCOMPATIBILITIES>
=head1 BUGS AND LIMITATIONS
See L<the same section on document of Amikeco|Amikeco/BUGS_AND_LIMITATIONS>
=head1 SUPPORT
See L<the same section on document of Amikeco|Amikeco/SUPPORT>
=head1 VERSION CONTROL
This module is maintained using git.
You can get the latest version from
L<git://github.com/gardejo/p5-amikeco.git>.
=head1 AUTHOR
=over 4
=item MORIYA Masaki (a.k.a. "Gardejo")
C<< <moriya@cpan.org> >>,
L<http://ttt.ermitejo.com/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2009 by MORIYA Masaki (a.k.a. "Gardejo"),
L<http://ttt.ermitejo.com>.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl> and L<perlartistic>.
=cut
Raw
ValueLike.pm
package Test::Amikeco::Value::ValueLike;
# ****************************************************************
# pragma(s)
# ****************************************************************
use strict;
use warnings;
# ****************************************************************
# superclass(es)
# ****************************************************************
use base qw(
Test::Class
);
# ****************************************************************
# namespace clearer
# ****************************************************************
use namespace::clean;
# ****************************************************************
# general dependency(-ies)
# ****************************************************************
use Test::Exception;
use Test::More;
# use Test::Most;
# ****************************************************************
# method(s) as class constant(s)
# ****************************************************************
sub _message_pattern {
my ($self, $key) = @_;
my %message_pattern = (
non_enumrated_name
=> qr{^Attribute \(name\) does not pass the type constraint},
non_enumrated_number
=> qr{^Attribute \(number\) does not pass the type constraint},
dual_wield_construction
=> qr{^Initialization argument must be any one of name or number},
);
return $key ? $message_pattern{$key} : %message_pattern;
}
# ****************************************************************
# utility(-ies)
# ****************************************************************
sub _random_number {
my $self = shift;
my @value_numbers = $self->_value_numbers;
return $value_numbers[ int( rand($#value_numbers) ) ];
}
# ****************************************************************
# test(s)
# ****************************************************************
sub _setup : Test(setup) {
my $self = shift;
$self->{class} = $self->_target_class;
$self->{instance} = $self->{class}->new;
return;
}
sub test_to_name : Tests(no_plan) {
my $self = shift;
my %alignment = $self->_alignment;
while (my ($name, $number) = each %alignment) {
is $self->{class}->to_name($number), $name
=> sprintf('to_name(%d) is (%s) ok', $number, $name);
}
return;
}
sub test_to_number : Tests(no_plan) {
my $self = shift;
my %alignment = $self->_alignment;
while (my ($name, $number) = each %alignment) {
is $self->{class}->to_number($name), $number
=> sprintf('to_number(%s) is (%d) ok', $name, $number);
}
return;
}
sub test_name : Tests(no_plan) {
my $self = shift;
my %alignment = $self->_alignment;
while (my ($name, $number) = each %alignment) {
$self->{instance} = $self->{class}->new(
name => $name,
);
is $self->{instance}->name, $name
=> sprintf('get name (%s) ok', $name);
is $self->{instance}->number, $number
=> sprintf('get number (%d) ok', $number);
is $self->{instance}->name($name), $name
=> sprintf('set name (%s) ok', $name);
is $self->{instance}->name, $name
=> sprintf('get name (%s) ok', $name);
is $self->{instance}->number, $number
=> sprintf('get number (%d) ok', $number);
}
return;
}
sub test_number : Tests(no_plan) {
my $self = shift;
my %alignment = reverse $self->_alignment;
while (my ($number, $name) = each %alignment) {
$self->{instance} = $self->{class}->new(
number => $number,
);
is $self->{instance}->number, $number
=> sprintf('get number (%d) ok', $number);
is $self->{instance}->name, $name
=> sprintf('get name (%s) ok', $name);
is $self->{instance}->number($number), $number
=> sprintf('set number (%d) ok', $number);
is $self->{instance}->number, $number
=> sprintf('get number (%d) ok', $number);
is $self->{instance}->name, $name
=> sprintf('get name (%s) ok', $name);
}
return;
}
sub test_non_enumrated_name : Tests(3) {
my $self = shift;
my $message_pattern = $self->_message_pattern('non_enumrated_name');
throws_ok {
$self->{class}->new(
name => '!!JUNK!!',
);
} $message_pattern
=> q{non-enumrated name ('!!JUNK!!') throws exception};
throws_ok {
$self->{instance}->name('!!JUNK!!');
} $message_pattern
=> q{non-enumrated name ('!!JUNK!!') throws exception};
throws_ok {
$self->{instance}->name(undef);
} $message_pattern
=> q{non-enumrated name (undef) throws exception};
return;
}
sub test_non_enumrated_number : Tests(3) {
my $self = shift;
my $message_pattern = $self->_message_pattern('non_enumrated_number');
throws_ok {
$self->{class}->new(
number => 42,
);
} $message_pattern
=> q{non-enumrated name (42) throws exception};
throws_ok {
$self->{instance}->number(42);
} $message_pattern
=> q{non-enumrated number (42) throws exception};
throws_ok {
$self->{instance}->number(undef);
} $message_pattern
=> q{non-enumrated number (undef) throws exception};
return;
}
sub test_inflate : Tests(no_plan) {
my $self = shift;
foreach my $value_number ($self->_value_numbers) {
$self->{instance} = $self->{class}->inflate($value_number);
is $self->{instance}->number, $value_number
=> sprintf('inflate (%d) ok', $value_number);
}
return;
}
sub test_deflate : Tests(no_plan) {
my $self = shift;
foreach my $value_number ($self->_value_numbers) {
$self->{instance}->number($value_number);
is $self->{instance}->deflate, $value_number
=> sprintf('deflate (%d) ok', $value_number);
}
return;
}
sub test_default : Test(1) {
my $self = shift;
is $self->{class}->default, $self->_default,
=> 'default ok';
return;
}
sub test_reset : Test(1) {
my $self = shift;
$self->{instance}->number( $self->_random_number );
is $self->{instance}->reset, $self->_default,
=> 'reset ok';
return;
}
sub test_dual_wield_construction : Tests(1) {
my $self = shift;
my $message_pattern = $self->_message_pattern('dual_wield_construction');
my @value_numbers = $self->_value_numbers;
throws_ok {
$self->{class}->new(
number => $value_numbers[0],
name => $self->{class}->to_name($value_numbers[0]),
);
} $message_pattern
=> q{dual_wield_construction};
return;
}
# ****************************************************************
# return true
# ****************************************************************
1;
__END__
# ****************************************************************
# POD
# ****************************************************************
=pod
=head1 NAME
Test::Amikeco::Value::ValueLike - Testing baseclass for classes that consumes Amikeco::Value::ValueLike
=head1 SYNOPSIS
package Test::Amikeco::Value::Race;
use base qw(
Test::Amikeco::Value::ValueLike
);
# ...
=head1 DESCRIPTION
This module tests classes that consumes L<Amikeco::Value::ValueLike>.
=head1 AUTHOR
=over 4
=item MORIYA Masaki (a.k.a. "Gardejo")
C<< <moriya@cpan.org> >>,
L<http://ttt.ermitejo.com/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2009 by MORIYA Masaki (a.k.a. "Gardejo"),
L<http://ttt.ermitejo.com>.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl> and L<perlartistic>.
=cut
Raw
WithValueObjectUtility.pm
package Amikeco::Value::WithValueObjectUtility;
# ****************************************************************
# MOP dependency(-ies)
# ****************************************************************
use Moose::Role;
use Moose::Util::TypeConstraints;
# ****************************************************************
# general dependency(-ies)
# ****************************************************************
use List::MoreUtils qw(all uniq);
# ****************************************************************
# namespace clearer
# ****************************************************************
use namespace::clean -except => [qw(meta)];
# ****************************************************************
# interface(s)
# ****************************************************************
requires qw(
alignment
default
);
# ****************************************************************
# attribute(s)
# ****************************************************************
has 'name' => (
is => 'rw',
# isa => 'Str', # dynamically assigned by _modify_type_constraints()
lazy_build => 1,
trigger => sub {
$_[0]->_trigger_name;
},
);
has 'number' => (
is => 'rw',
# isa => 'Int', # dynamically assigned by _modify_type_constraints()
lazy_build => 1,
trigger => sub {
$_[0]->_trigger_number;
},
);
# ****************************************************************
# hook(s) on construction
# ****************************************************************
around BUILDARGS => sub {
my ($next, $class, @args) = @_;
my $init_args = $class->$next(@args);
confess 'Initialization argument must be any one of name or number'
if exists $init_args->{name} && exists $init_args->{number};
return $init_args;
};
# ****************************************************************
# modifier(s) of type constraint(s)
# ****************************************************************
sub _modify_type_constraints {
my $role = shift;
my $type_constraints = $role->_type_constraints;
return
if all {
find_type_constraint($_->{name});
} values %$type_constraints;
my $is_immutable = $role->meta->is_immutable;
$role->meta->make_mutable
if $is_immutable;
while (my ($attribute, $type) = each %$type_constraints) {
$role->meta->add_attribute( '+' . $attribute => (
isa => enum $type->{name} => @{ $type->{enum} },
) );
}
$role->meta->make_immutable
if $is_immutable;
return;
}
# ****************************************************************
# convenience mutator(s)
# ****************************************************************
sub reset {
$_[0]->name($_[0]->default);
}
# ****************************************************************
# interface(s) to persistent storage
# ****************************************************************
sub inflate {
$_[0]->new(
number => $_[1],
);
}
sub deflate {
$_[0]->number;
}
# ****************************************************************
# method(s) as class constant(s)
# ****************************************************************
sub _names_to_numbers {
# this role cannot validate the names-to-numbers alignment
# (keys of alignment are already unique)
return $_[0]->alignment;
}
sub _numbers_to_names {
my @numbers = values %{ $_[0]->_names_to_numbers };
# validation is not capabile in (this role's) compile-time
confess 'Numbers of value are not unique'
if @numbers != scalar uniq @numbers;
return {
reverse %{ $_[0]->_names_to_numbers }
};
}
sub _names {
# sort keys by value
my $names_to_numbers = $_[0]->_names_to_numbers;
return [
map {
$_->[0]
} sort {
$a->[1] <=> $b->[1];
} map {
[ $_, $names_to_numbers->{ $_ } ];
} keys %$names_to_numbers
];
}
sub _numbers {
return [
sort { $a <=> $b } values %{ $_[0]->_names_to_numbers }
];
}
# ****************************************************************
# utility method(s) of handmade coercion
# ****************************************************************
sub to_number {
return ${ $_[0]->_names_to_numbers }{ $_[1] };
}
sub to_name {
return ${ $_[0]->_numbers_to_names }{ $_[1] };
}
# ****************************************************************
# return true
# ****************************************************************
1;
__END__
# ****************************************************************
# POD
# ****************************************************************
=pod
=head1 NAME
Amikeco::Value::WithValueObjectUtility - Base role of Value Objects for Moose
=head1 SYNOPSIS
package Amikeco::Value::ValueLike;
use Moose::Role;
with qw(Amikeco::Value::WithValueObjectUtility);
# ...
=head1 DESCRIPTION
This Moose::Role module provides basic infrastructure of
Value Objects to Moose class that consumes this role.
=head1 ATTRIBUTES
=head2 C<< name >>
Is a string of a value name.
=head2 C<< number >>
Is an integer of a value number.
=head1 INTERFACES
Consumer classes of this role must implement these methods.
=head2 C<< ValueClass->alignment() >>
Returns a hash reference that defines the relationship
between value names and value numbers.
=head2 C<< ValueClass->default() >>
Returns a string that defines the default value name.
If a consumer class has not a default value,
we should bring the method to throw an exception.
=head1 METHODS
=head2 Convenience mutator
=head3 C<< $value->reset() >>
It is the sugar method of C<< $value->name($value->default) >>.
=head2 Interfaces to persistent storage
These methods give us the usage of inflation and deflation.
This let us to store the value as an integer for a database,
and to treat the value as an object in our codes.
For example, in case of schema with L<DBIx::Class>,
package Amikeco::Schema::Avatar;
use Amikeco::Value::Race;
# ...
__PACKAGE__->inflate_column('race' => {
inflate => sub { Amikeco::Value::Race->inflate($_[0]); },
deflate => sub { $_[0]->deflate; },
});
# ...
=head3 C<< ValueClass->inflate($number) >>
It is the sugar method of C<< ValueClass->new(number => $number) >>.
=head3 C<< $value->deflate() >>
It is the sugar method of C<< $value->number() >>.
=head2 Utility methods of handmade coercion
=head3 C<< ValueClass->to_number($name) >>
Returns an integer of value number
that corresponds to the specified value C<$name>.
=head3 C<< ValueClass->to_name($number) >>
Returns a string of value name
that corresponds to the specified value C<$number>.
=head1 INCOMPATIBILITIES
See L<the same section on document of Amikeco|Amikeco/INCOMPATIBILITIES>
=head1 BUGS AND LIMITATIONS
See L<the same section on document of Amikeco|Amikeco/BUGS_AND_LIMITATIONS>
=head1 SUPPORT
See L<the same section on document of Amikeco|Amikeco/SUPPORT>
=head1 VERSION CONTROL
This module is maintained using git.
You can get the latest version from
L<git://github.com/gardejo/p5-amikeco.git>.
=head1 AUTHOR
=over 4
=item MORIYA Masaki (a.k.a. "Gardejo")
C<< <moriya@cpan.org> >>,
L<http://ttt.ermitejo.com/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2009 by MORIYA Masaki (a.k.a. "Gardejo"),
L<http://ttt.ermitejo.com>.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl> and L<perlartistic>.
=cut
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment