Create a gist now

Instantly share code, notes, and snippets.

Several implementation for the table inheritance patterns
package MyApp::ClassTableInheritance::Schema::Base::Result::Bowler;
use namespace::autoclean;
use Moose;
extends qw(
MyApp::ClassTableInheritance::Schema::Base::Result::Cricketer
);
# ****************************************************************
# painful accessor(s)
# ****************************************************************
sub name { # It is less than smart...
my $self = shift;
return $self->cricketer->name(@_); # $cricketer->player->name
}
sub batting_average { # It is less than smart...
my $self = shift;
return $self->cricketer->batting_average(@_);
}
# ****************************************************************
# business logic(s)
# ****************************************************************
sub bat { # It is less than smart...
my $self = shift;
return $self->cricketer->bat(@_);
}
sub bowl {
my $self = shift;
printf(
"%s (ave.: %0.3f) bowls a ball!\n",
$self->name,
$self->bowling_average,
);
return;
}
# ****************************************************************
# compile-time process(es)
# ****************************************************************
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=encoding utf-8
=head1 NAME
MyApp::ClassTableInheritance::Schema::Base::Result::Bowler - blah blah blah
=head1 SYNOPSIS
# yada yada yada
=head1 DESCRIPTION
blah blah blah
=head1 AUTHOR
=over 4
=item MORIYA Masaki, alias Gardejo
C<< <moriya at cpan dot org> >>,
L<http://gardejo.org/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2010 MORIYA Masaki, alias Gardejo.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl|perlgpl> and L<perlartistic|perlartistic>.
The full text of the license can be found in the F<LICENSE> file included with
this distribution.
=cut
package MyApp::ClassTableInheritance::Schema::Result::Bowler;
use namespace::autoclean;
use Moose;
use MooseX::Types::Moose qw(Num);
extends qw(
MyApp::ClassTableInheritance::Schema::Base::Result::Bowler
);
# ****************************************************************
# table setting(s)
# ****************************************************************
__PACKAGE__->table('bowlers');
__PACKAGE__->add_columns(
bowling_average => {
data_type => 'float',
},
);
# Or, use DBIx::Class::MooseColumns
with (
'MyApp::Role::Schema::Result::Validatable' => {
columns => {
bowling_average => { isa => Num },
},
},
);
after _prepare_table => sub {
my ($class) = @_;
$class->belongs_to(
'cricketer' =>
'MyApp::ClassTableInheritance::Schema::Result::Cricketer',
'id'
);
return;
};
# ****************************************************************
# compile-time process(es)
# ****************************************************************
__PACKAGE__->_prepare_table;
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=encoding utf-8
=head1 NAME
MyApp::ClassTableInheritance::Schema::Result::Bowler - blah blah blah
=head1 SYNOPSIS
# yada yada yada
=head1 DESCRIPTION
blah blah blah
=head1 AUTHOR
=over 4
=item MORIYA Masaki, alias Gardejo
C<< <moriya at cpan dot org> >>,
L<http://gardejo.org/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2010 MORIYA Masaki, alias Gardejo.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl|perlgpl> and L<perlartistic|perlartistic>.
The full text of the license can be found in the F<LICENSE> file included with
this distribution.
=cut
package MyApp::ConcreteTableInheritance::Schema::Result::Bowler;
use namespace::autoclean;
use Moose;
use MooseX::Types::Moose qw(Num);
extends qw(
MyApp::ConcreteTableInheritance::Schema::Result::Cricketer
);
# ****************************************************************
# table setting(s)
# ****************************************************************
__PACKAGE__->table('bowlers');
__PACKAGE__->add_columns(
bowling_average => {
data_type => 'float',
},
);
# Or, use DBIx::Class::MooseColumns
with (
'MyApp::Role::Schema::Result::Validatable' => {
columns => {
bowling_average => { isa => Num },
},
},
);
after _prepare_table => sub {
my ($class) = @_;
# some preparations
return;
};
# ****************************************************************
# business logic(s)
# ****************************************************************
sub bowl {
my $self = shift;
printf(
"%s (ave.: %0.3f) bowls a ball!\n",
$self->name,
$self->bowling_average,
);
return;
}
# ****************************************************************
# compile-time process(es)
# ****************************************************************
__PACKAGE__->_prepare_table;
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=encoding utf-8
=head1 NAME
MyApp::ConcreteTableInheritance::Schema::Result::Bowler - blah blah blah
=head1 SYNOPSIS
# yada yada yada
=head1 DESCRIPTION
blah blah blah
=head1 AUTHOR
=over 4
=item MORIYA Masaki, alias Gardejo
C<< <moriya at cpan dot org> >>,
L<http://gardejo.org/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2010 MORIYA Masaki, alias Gardejo.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl|perlgpl> and L<perlartistic|perlartistic>.
The full text of the license can be found in the F<LICENSE> file included with
this distribution.
=cut
package MyApp::SingleTableInheritance::Schema::Result::Bowler;
use namespace::autoclean;
use Moose;
extends qw(
MyApp::SingleTableInheritance::Schema::Result::Cricketer
);
# ****************************************************************
# table setting(s)
# ****************************************************************
__PACKAGE__->table('players');
# ****************************************************************
# business logic(s)
# ****************************************************************
sub bowl {
my $self = shift;
printf(
"%s (ave.: %0.3f) bowls a ball!\n",
$self->name,
$self->bowling_average,
);
return;
}
# ****************************************************************
# compile-time process(es)
# ****************************************************************
__PACKAGE__->_prepare_table;
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=encoding utf-8
=head1 NAME
MyApp::SingleTableInheritance::Schema::Result::Bowler - blah blah blah
=head1 SYNOPSIS
# yada yada yada
=head1 DESCRIPTION
blah blah blah
=head1 AUTHOR
=over 4
=item MORIYA Masaki, alias Gardejo
C<< <moriya at cpan dot org> >>,
L<http://gardejo.org/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2010 MORIYA Masaki, alias Gardejo.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl|perlgpl> and L<perlartistic|perlartistic>.
The full text of the license can be found in the F<LICENSE> file included with
this distribution.
=cut
#!/usr/bin/perl
use 5.010_000;
use strict;
use warnings;
use utf8;
use FindBin;
use lib "$FindBin::Bin/../lib";
use MyApp::ClassTableInheritance::Schema;
my $schema = MyApp::ClassTableInheritance::Schema->connect(
'dbi:SQLite:dbname=:memory:',
);
$schema->deploy;
my $txn_guard = $schema->txn_scope_guard;
say 'Footballer:';
my $player_rs = $schema->resultset('Player');
my $new_player_as_football = $player_rs->create({
name => 'Foo Bar the Kicker',
});
# Fix Me: WTF?
# my $new_footballer = $new_player_as_football->add_to_footballer({
# id => $new_player
# club => 'Baz F.C.',
# });
my $new_footballer = $new_player_as_football->create_related('footballer', {
club => 'Baz F.C.',
});
$new_footballer->salute;
$new_footballer->kick;
say q();
say 'Cricketer:';
my $new_player_as_cricketer = $player_rs->create({
name => 'Foo Bar the Batter',
});
my $new_cricketer = $new_player_as_cricketer->create_related('cricketer', {
batting_average => 0.345,
});
$new_cricketer->salute;
$new_cricketer->bat;
say q();
say 'Bowler:';
my $new_player_as_bowler = $player_rs->create({
name => 'Foo Bar the Bowler',
});
my $new_cricketer_as_bowler = $new_player_as_bowler->create_related('cricketer', {
batting_average => 0.234,
});
my $new_bowler = $new_cricketer_as_bowler->create_related('bowler', {
bowling_average => 0.123,
});
$new_bowler->salute;
$new_bowler->bat;
$new_bowler->bowl;
say q();
$txn_guard->commit;
say 'Players:';
my $all_players_rs = $player_rs->search({});
while (my $player = $all_players_rs->next) {
printf(
"%s,%s\n",
$player->id,
$player->name,
);
}
say q();
say 'Footballers:';
my $footballer_rs = $schema->resultset('Footballer');
my $all_footballers_rs = $footballer_rs->search({});
while (my $footballer = $all_footballers_rs->next) {
printf(
"%s,%s\n",
$footballer->id,
$footballer->club,
);
}
say q();
say 'Cricketers:';
my $cricketer_rs = $schema->resultset('Cricketer');
my $all_cricketers_rs = $cricketer_rs->search({});
while (my $cricketer = $all_cricketers_rs->next) {
printf(
"%s,%0.3f\n",
$cricketer->id,
$cricketer->batting_average,
);
}
say q();
say 'Bowlers:';
my $bowler_rs = $schema->resultset('Bowler');
my $all_bowlers_rs = $bowler_rs->search({});
while (my $bowler = $all_bowlers_rs->next) {
printf(
"%s,%0.3f\n",
$bowler->id,
$bowler->bowling_average,
);
}
say q();
exit;
__END__
=pod
=encoding utf-8
=head1 NAME
class_table_inheritance - An implementation of the Class Table Inheritance pattern
=head1 SYNOPSIS
% perl class_table_inheritance.pl
Footballer:
Hello, my name is Foo Bar the Kicker.
Foo Bar the Kicker (Baz F.C.) kicks a ball!
Cricketer:
Hello, my name is Foo Bar the Batter.
Foo Bar the Batter (ave.: 0.345) bats a ball!
Bowler:
Hello, my name is Foo Bar the Bowler.
Foo Bar the Bowler (ave.: 0.234) bats a ball!
Foo Bar the Bowler (ave.: 0.123) bowls a ball!
Players:
B11584C3-723F-1014-92FA-98A5DC3A33E2,Foo Bar the Kicker
B5556DE7-723F-1014-A7B4-9A1D6EDACD88,Foo Bar the Batter
B5D3051A-723F-1014-92C9-9A937BB8010E,Foo Bar the Bowler
Footballers:
B11584C3-723F-1014-92FA-98A5DC3A33E2,Baz F.C.
Cricketers:
B5556DE7-723F-1014-A7B4-9A1D6EDACD88,0.345
B5D3051A-723F-1014-92C9-9A937BB8010E,0.234
Bowlers:
B5D3051A-723F-1014-92C9-9A937BB8010E,0.123
=head1 DESCRIPTION
blah blah blah
=head2 Schema
CREATE TABLE players (
id char(36) NOT NULL,
name varchar(32) NOT NULL,
PRIMARY KEY (id)
);
CREATE TABLE footballers (
id char(36) NOT NULL,
club varchar(32) NOT NULL,
PRIMARY KEY (id)
);
CREATE TABLE cricketers (
id char(36) NOT NULL,
batting_average float NOT NULL,
PRIMARY KEY (id)
);
CREATE TABLE bowlers (
id char(36) NOT NULL,
bowling_average float NOT NULL,
PRIMARY KEY (id)
);
CREATE UNIQUE INDEX players_name ON players (name);
=head1 TO DO
=over 4
=item *
L<MyApp::ClassTableInheritance::Schema::Result::Player|
MyApp::ClassTableInheritance::Schema::Result::Player> does not have
C<add_to_footballer> method.
=item *
L<DBIx::Class::MooseColumns|DBIx::Class::MooseColumns> 0.10 cannot apply type
constraints at instanciation.
=back
=head1 SEE ALSO
=over 4
=item *
L<http://www.martinfowler.com/eaaCatalog/classTableInheritance.html>
=item *
L<http://capsctrl.que.jp/kdmsnr/wiki/PofEAA/?ClassTableInheritance>
=back
=head1 AUTHOR
=over 4
=item MORIYA Masaki, alias Gardejo
C<< <moriya at cpan dot org> >>,
L<http://gardejo.org/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2010 MORIYA Masaki, alias Gardejo.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl|perlgpl> and L<perlartistic|perlartistic>.
The full text of the license can be found in the F<LICENSE> file included with
this distribution.
=cut
#!/usr/bin/perl
use 5.010_000;
use strict;
use warnings;
use utf8;
use FindBin;
use lib "$FindBin::Bin/../lib";
use MyApp::ConcreteTableInheritance::Schema;
my $schema = MyApp::ConcreteTableInheritance::Schema->connect(
'dbi:SQLite:dbname=:memory:',
);
$schema->deploy;
my $txn_guard = $schema->txn_scope_guard;
say 'Footballer:';
my $footballer_rs = $schema->resultset('Footballer');
my $new_footballer = $footballer_rs->create({
name => 'Foo Bar the Kicker',
club => 'Baz F.C.',
});
$new_footballer->salute;
$new_footballer->kick;
say q();
say 'Cricketer:';
my $cricketer_rs = $schema->resultset('Cricketer');
my $new_cricketer = $cricketer_rs->create({
name => 'Foo Bar the Cricketer',
batting_average => 0.345,
});
$new_cricketer->salute;
$new_cricketer->bat;
say q();
say 'Bowler:';
my $bowler_rs = $schema->resultset('Bowler');
my $new_bowler = $bowler_rs->create({
name => 'Foo Bar the Bowler',
batting_average => 0.234,
bowling_average => 0.123,
});
$new_bowler->salute;
$new_bowler->bat;
$new_bowler->bowl;
say q();
$txn_guard->commit;
say 'Footballers:';
my $all_footballers_rs = $footballer_rs->search({});
while (my $footballer = $all_footballers_rs->next) {
printf(
"%s,%s,%s\n",
$footballer->id,
$footballer->name,
$footballer->club,
);
}
say q();
say 'Cricketers:';
my $all_cricketers_rs = $cricketer_rs->search({});
while (my $cricketer = $all_cricketers_rs->next) {
printf(
"%s,%s,%0.3f\n",
$cricketer->id,
$cricketer->name,
$cricketer->batting_average,
);
}
say q();
say 'Bowlers:';
my $all_bowlers_rs = $bowler_rs->search({});
while (my $bowler = $all_bowlers_rs->next) {
printf(
"%s,%s,%0.3f,%0.3f\n",
$bowler->id,
$bowler->name,
$bowler->batting_average,
$bowler->bowling_average,
);
}
say q();
exit;
__END__
=pod
=encoding utf-8
=head1 NAME
concrete_table_inheritance - An implementation of the Concrete Table Inheritance pattern
=head1 SYNOPSIS
% perl concrete_table_inheritance.pl
Footballer:
Hello, my name is Foo Bar the Kicker.
Foo Bar the Kicker (Baz F.C.) kicks a ball!
Cricketer:
Hello, my name is Foo Bar the Cricketer.
Foo Bar the Cricketer (ave.: 0.345) bats a ball!
Bowler:
Hello, my name is Foo Bar the Bowler.
Foo Bar the Bowler (ave.: 0.234) bats a ball!
Foo Bar the Bowler (ave.: 0.123) bowls a ball!
Footballers:
D1187178-97B2-1014-A58F-D4AC52A7D995,Foo Bar the Kicker,Baz F.C.
Cricketers:
D4E37767-97B2-1014-B8E9-EC12DD115C94,Foo Bar the Cricketer,0.345
Bowlers:
D520973D-97B2-1014-B909-CBDD2129B220,Foo Bar the Bowler,0.234,0.123
=head1 DESCRIPTION
blah blah blah
=head2 Schema
CREATE TABLE footballers (
id CHAR(36) NOT NULL,
name VARCHAR(32) NOT NULL,
club VARCHAR(32) NOT NULL,
PRIMARY KEY (id)
);
CREATE TABLE cricketers (
id char(36) NOT NULL,
name varchar(32) NOT NULL,
batting_average float NOT NULL,
PRIMARY KEY (id)
);
CREATE TABLE bowlers (
id CHAR(36) NOT NULL,
name VARCHAR(32) NOT NULL,
batting_average float NOT NULL,
bowling_average float NOT NULL,
PRIMARY KEY (id)
);
CREATE UNIQUE INDEX __PLACEHOLDER___name ON bowlers (name); -- sucks
CREATE UNIQUE INDEX __PLACEHOLDER___name02 ON cricketers (name); -- sucks
CREATE UNIQUE INDEX __PLACEHOLDER___name03 ON footballers (name); -- sucks
CREATE UNIQUE INDEX bowlers_name ON bowlers (name);
CREATE UNIQUE INDEX cricketers_name ON bowlers (name);
CREATE UNIQUE INDEX cricketers_name02 ON cricketers (name); -- sucks
CREATE UNIQUE INDEX footballers_name ON footballers (name);
=head1 TO DO
=over 4
=item *
L<DBIx::Class::MooseColumns|DBIx::Class::MooseColumns> 0.10 cannot apply type
constraints at instanciation.
=back
=head1 SEE ALSO
=over 4
=item *
L<http://www.martinfowler.com/eaaCatalog/concreteTableInheritance.html>
=item *
L<http://capsctrl.que.jp/kdmsnr/wiki/PofEAA/?ConcreteTableInheritance>
=back
=head1 AUTHOR
=over 4
=item MORIYA Masaki, alias Gardejo
C<< <moriya at cpan dot org> >>,
L<http://gardejo.org/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2010 MORIYA Masaki, alias Gardejo.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl|perlgpl> and L<perlartistic|perlartistic>.
The full text of the license can be found in the F<LICENSE> file included with
this distribution.
=cut
package MyApp::ClassTableInheritance::Schema::Base::Result::Cricketer;
use namespace::autoclean;
use Moose;
extends qw(
MyApp::ClassTableInheritance::Schema::Base::Result::Player
);
# ****************************************************************
# painful accessor(s)
# ****************************************************************
sub name { # It is less than smart...
my $self = shift;
return $self->player->name(@_);
}
# ****************************************************************
# business logic(s)
# ****************************************************************
sub bat {
my $self = shift;
printf(
"%s (ave.: %0.3f) bats a ball!\n",
$self->name,
$self->batting_average,
);
return;
}
# ****************************************************************
# compile-time process(es)
# ****************************************************************
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=encoding utf-8
=head1 NAME
MyApp::ClassTableInheritance::Schema::Base::Result::Cricketer - blah blah blah
=head1 SYNOPSIS
# yada yada yada
=head1 DESCRIPTION
blah blah blah
=head1 AUTHOR
=over 4
=item MORIYA Masaki, alias Gardejo
C<< <moriya at cpan dot org> >>,
L<http://gardejo.org/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2010 MORIYA Masaki, alias Gardejo.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl|perlgpl> and L<perlartistic|perlartistic>.
The full text of the license can be found in the F<LICENSE> file included with
this distribution.
=cut
package MyApp::ClassTableInheritance::Schema::Result::Cricketer;
use namespace::autoclean;
use Moose;
use MooseX::Types::Moose qw(Num);
extends qw(
MyApp::ClassTableInheritance::Schema::Base::Result::Cricketer
);
# ****************************************************************
# table setting(s)
# ****************************************************************
__PACKAGE__->table('cricketers');
__PACKAGE__->add_columns(
batting_average => {
data_type => 'float',
},
);
# Or, use DBIx::Class::MooseColumns
with (
'MyApp::Role::Schema::Result::Validatable' => {
columns => {
batting_average => { isa => Num },
},
},
);
after _prepare_table => sub {
my ($class) = @_;
$class->belongs_to(
'player' =>
'MyApp::ClassTableInheritance::Schema::Result::Player',
'id'
);
$class->might_have(
'bowler' =>
'MyApp::ClassTableInheritance::Schema::Result::Bowler',
'id'
);
return;
};
# ****************************************************************
# compile-time process(es)
# ****************************************************************
__PACKAGE__->_prepare_table;
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=encoding utf-8
=head1 NAME
MyApp::ClassTableInheritance::Schema::Result::Cricketer - blah blah blah
=head1 SYNOPSIS
# yada yada yada
=head1 DESCRIPTION
blah blah blah
=head1 AUTHOR
=over 4
=item MORIYA Masaki, alias Gardejo
C<< <moriya at cpan dot org> >>,
L<http://gardejo.org/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2010 MORIYA Masaki, alias Gardejo.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl|perlgpl> and L<perlartistic|perlartistic>.
The full text of the license can be found in the F<LICENSE> file included with
this distribution.
=cut
package MyApp::ConcreteTableInheritance::Schema::Result::Cricketer;
use namespace::autoclean;
use Moose;
use MooseX::Types::Moose qw(Num);
extends qw(
MyApp::ConcreteTableInheritance::Schema::Base::Result::Player
);
# ****************************************************************
# table setting(s)
# ****************************************************************
__PACKAGE__->table('cricketers');
__PACKAGE__->add_columns(
batting_average => {
data_type => 'float',
},
);
# Or, use DBIx::Class::MooseColumns
with (
'MyApp::Role::Schema::Result::Validatable' => {
columns => {
batting_average => { isa => Num },
},
},
);
after _prepare_table => sub {
my ($class) = @_;
# some preparations
return;
};
# ****************************************************************
# business logic(s)
# ****************************************************************
sub bat {
my $self = shift;
printf(
"%s (ave.: %0.3f) bats a ball!\n",
$self->name,
$self->batting_average,
);
return;
}
# ****************************************************************
# compile-time process(es)
# ****************************************************************
__PACKAGE__->_prepare_table;
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=encoding utf-8
=head1 NAME
MyApp::ConcreteTableInheritance::Schema::Result::Cricketer - blah blah blah
=head1 SYNOPSIS
# yada yada yada
=head1 DESCRIPTION
blah blah blah
=head1 AUTHOR
=over 4
=item MORIYA Masaki, alias Gardejo
C<< <moriya at cpan dot org> >>,
L<http://gardejo.org/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2010 MORIYA Masaki, alias Gardejo.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl|perlgpl> and L<perlartistic|perlartistic>.
The full text of the license can be found in the F<LICENSE> file included with
this distribution.
=cut
package MyApp::SingleTableInheritance::Schema::Result::Cricketer;
use namespace::autoclean;
use Moose;
extends qw(
MyApp::SingleTableInheritance::Schema::Result::Player
);
# ****************************************************************
# table setting(s)
# ****************************************************************
__PACKAGE__->table('players');
# ****************************************************************
# business logic(s)
# ****************************************************************
sub bat {
my $self = shift;
printf(
"%s (ave.: %0.3f) bats a ball!\n",
$self->name,
$self->batting_average,
);
return;
}
# ****************************************************************
# compile-time process(es)
# ****************************************************************
__PACKAGE__->_prepare_table;
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=encoding utf-8
=head1 NAME
MyApp::SingleTableInheritance::Schema::Result::Cricketer - blah blah blah
=head1 SYNOPSIS
# yada yada yada
=head1 DESCRIPTION
blah blah blah
=head1 AUTHOR
=over 4
=item MORIYA Masaki, alias Gardejo
C<< <moriya at cpan dot org> >>,
L<http://gardejo.org/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2010 MORIYA Masaki, alias Gardejo.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl|perlgpl> and L<perlartistic|perlartistic>.
The full text of the license can be found in the F<LICENSE> file included with
this distribution.
=cut
package MyApp::ClassTableInheritance::Schema::Base::Result::Footballer;
use namespace::autoclean;
use Moose;
extends qw(
MyApp::ClassTableInheritance::Schema::Base::Result::Player
);
# ****************************************************************
# painful accessor(s)
# ****************************************************************
sub name { # It is less than smart...
my $self = shift;
return $self->player->name(@_);
}
# ****************************************************************
# business logic(s)
# ****************************************************************
sub kick {
my $self = shift;
printf(
"%s (%s) kicks a ball!\n",
$self->name,
$self->club,
);
return;
}
# ****************************************************************
# business logic(s)
# ****************************************************************
__PACKAGE__->_prepare_table;
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=encoding utf-8
=head1 NAME
MyApp::ClassTableInheritance::Schema::Base::Result::Footballer - blah blah blah
=head1 SYNOPSIS
# yada yada yada
=head1 DESCRIPTION
blah blah blah
=head1 AUTHOR
=over 4
=item MORIYA Masaki, alias Gardejo
C<< <moriya at cpan dot org> >>,
L<http://gardejo.org/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2010 MORIYA Masaki, alias Gardejo.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl|perlgpl> and L<perlartistic|perlartistic>.
The full text of the license can be found in the F<LICENSE> file included with
this distribution.
=cut
package MyApp::ClassTableInheritance::Schema::Result::Footballer;
use namespace::autoclean;
use Moose;
use MooseX::Types::Moose qw(Str);
extends qw(
MyApp::ClassTableInheritance::Schema::Base::Result::Footballer
);
# ****************************************************************
# table setting(s)
# ****************************************************************
__PACKAGE__->table('footballers');
__PACKAGE__->add_columns(
club => {
data_type => 'varchar',
size => 32,
},
);
# Or, use DBIx::Class::MooseColumns
with (
'MyApp::Role::Schema::Result::Validatable' => {
columns => {
club => { isa => Str },
},
},
);
after _prepare_table => sub {
my ($class) = @_;
$class->belongs_to(
'player' =>
'MyApp::ClassTableInheritance::Schema::Result::Player',
'id'
);
return;
};
# ****************************************************************
# compile-time process(es)
# ****************************************************************
__PACKAGE__->_prepare_table;
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=encoding utf-8
=head1 NAME
MyApp::ClassTableInheritance::Schema::Result::Footballer - blah blah blah
=head1 SYNOPSIS
# yada yada yada
=head1 DESCRIPTION
blah blah blah
=head1 AUTHOR
=over 4
=item MORIYA Masaki, alias Gardejo
C<< <moriya at cpan dot org> >>,
L<http://gardejo.org/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2010 MORIYA Masaki, alias Gardejo.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl|perlgpl> and L<perlartistic|perlartistic>.
The full text of the license can be found in the F<LICENSE> file included with
this distribution.
=cut
package MyApp::ConcreteTableInheritance::Schema::Result::Footballer;
use namespace::autoclean;
use Moose;
use MooseX::Types::Moose qw(Str);
extends qw(
MyApp::ConcreteTableInheritance::Schema::Base::Result::Player
);
# ****************************************************************
# table setting(s)
# ****************************************************************
__PACKAGE__->table('footballers');
__PACKAGE__->add_columns(
club => {
data_type => 'varchar',
size => 32,
},
);
# Or, use DBIx::Class::MooseColumns
with (
'MyApp::Role::Schema::Result::Validatable' => {
columns => {
club => { isa => Str },
},
},
);
after _prepare_table => sub {
my ($class) = @_;
# some preparations
return;
};
# ****************************************************************
# business logic(s)
# ****************************************************************
sub kick {
my $self = shift;
printf(
"%s (%s) kicks a ball!\n",
$self->name,
$self->club,
);
return;
}
# ****************************************************************
# compile-time process(es)
# ****************************************************************
__PACKAGE__->_prepare_table;
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=encoding utf-8
=head1 NAME
MyApp::ConcreteTableInheritance::Schema::Result::Footballer - blah blah blah
=head1 SYNOPSIS
# yada yada yada
=head1 DESCRIPTION
blah blah blah
=head1 AUTHOR
=over 4
=item MORIYA Masaki, alias Gardejo
C<< <moriya at cpan dot org> >>,
L<http://gardejo.org/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2010 MORIYA Masaki, alias Gardejo.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl|perlgpl> and L<perlartistic|perlartistic>.
The full text of the license can be found in the F<LICENSE> file included with
this distribution.
=cut
package MyApp::SingleTableInheritance::Schema::Result::Footballer;
use namespace::autoclean;
use Moose;
extends qw(
MyApp::SingleTableInheritance::Schema::Result::Player
);
# ****************************************************************
# table setting(s)
# ****************************************************************
__PACKAGE__->table('players');
# ****************************************************************
# business logic(s)
# ****************************************************************
sub kick {
my $self = shift;
printf(
"%s (%s) kicks a ball!\n",
$self->name,
$self->club,
);
return;
}
# ****************************************************************
# compile-time process(es)
# ****************************************************************
__PACKAGE__->_prepare_table;
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=encoding utf-8
=head1 NAME
MyApp::SingleTableInheritance::Schema::Result::Footballer - blah blah blah
=head1 SYNOPSIS
# yada yada yada
=head1 DESCRIPTION
blah blah blah
=head1 AUTHOR
=over 4
=item MORIYA Masaki, alias Gardejo
C<< <moriya at cpan dot org> >>,
L<http://gardejo.org/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2010 MORIYA Masaki, alias Gardejo.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl|perlgpl> and L<perlartistic|perlartistic>.
The full text of the license can be found in the F<LICENSE> file included with
this distribution.
=cut
package MyApp::ClassTableInheritance::Schema::Base::Result::Player;
use namespace::autoclean;
use Moose;
use MooseX::NonMoose;
use MooseX::Types::UUID qw(UUID);
extends qw(
DBIx::Class::Core
);
__PACKAGE__->load_components(qw(
UUIDColumns
));
# ****************************************************************
# table setting(s)
# ****************************************************************
# It is overwritten with concrete classes.
__PACKAGE__->table('__PLACEHOLDER__');
__PACKAGE__->add_columns(
id => {
data_type => 'char',
size => 36,
is_foreign_key => 1,
},
);
# Or, use DBIx::Class::MooseColumns
with (
'MyApp::Role::Schema::Result::Validatable' => {
columns => {
id => { isa => UUID },
},
},
);
sub _prepare_table {
my ($class) = @_;
$class->set_primary_key(qw(id));
$class->uuid_columns(qw(id));
return;
}
# ****************************************************************
# business logic(s)
# ****************************************************************
sub salute {
my ($self) = @_;
printf(
"Hello, my name is %s.\n",
$self->name,
);
}
# ****************************************************************
# compile-time process(es)
# ****************************************************************
__PACKAGE__->_prepare_table;
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=encoding utf-8
=head1 NAME
MyApp::ClassTableInheritance::Schema::Base::Result::Player - blah blah blah
=head1 SYNOPSIS
# yada yada yada
=head1 DESCRIPTION
blah blah blah
=head1 AUTHOR
=over 4
=item MORIYA Masaki, alias Gardejo
C<< <moriya at cpan dot org> >>,
L<http://gardejo.org/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2010 MORIYA Masaki, alias Gardejo.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl|perlgpl> and L<perlartistic|perlartistic>.
The full text of the license can be found in the F<LICENSE> file included with
this distribution.
=cut
package MyApp::ClassTableInheritance::Schema::Result::Player;
use namespace::autoclean;
use Moose;
use MooseX::Types::Moose qw(Str);
extends qw(
MyApp::ClassTableInheritance::Schema::Base::Result::Player
);
# ****************************************************************
# table setting(s)
# ****************************************************************
__PACKAGE__->table('players');
__PACKAGE__->add_columns(
name => {
data_type => 'varchar',
size => 32,
},
);
# Or, use DBIx::Class::MooseColumns
with (
'MyApp::Role::Schema::Result::Validatable' => {
columns => {
name => { isa => Str },
},
},
);
after _prepare_table => sub {
my ($class) = @_;
$class->add_unique_constraint( [qw(name)] );
$class->might_have(
'footballer' =>
'MyApp::ClassTableInheritance::Schema::Result::Footballer',
'id'
);
$class->might_have(
'cricketer' =>
'MyApp::ClassTableInheritance::Schema::Result::Cricketer',
'id'
);
return;
};
# ****************************************************************
# compile-time process(es)
# ****************************************************************
__PACKAGE__->_prepare_table;
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=encoding utf-8
=head1 NAME
MyApp::ClassTableInheritance::Schema::Result::Player - blah blah blah
=head1 SYNOPSIS
# yada yada yada
=head1 DESCRIPTION
blah blah blah
=head1 AUTHOR
=over 4
=item MORIYA Masaki, alias Gardejo
C<< <moriya at cpan dot org> >>,
L<http://gardejo.org/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2010 MORIYA Masaki, alias Gardejo.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl|perlgpl> and L<perlartistic|perlartistic>.
The full text of the license can be found in the F<LICENSE> file included with
this distribution.
=cut
package MyApp::ConcreteTableInheritance::Schema::Base::Result::Player;
use namespace::autoclean;
use Moose;
use MooseX::NonMoose;
use MooseX::Types::Moose qw(Str);
use MooseX::Types::UUID qw(UUID);
extends qw(
DBIx::Class::Core
);
__PACKAGE__->load_components(qw(
UUIDColumns
));
# ****************************************************************
# table setting(s)
# ****************************************************************
# It is overwritten with concrete classes.
__PACKAGE__->table('__PLACEHOLDER__');
__PACKAGE__->add_columns(
id => {
data_type => 'char',
size => 36,
},
name => {
data_type => 'varchar',
size => 32,
},
);
# Or, use DBIx::Class::MooseColumns
with (
'MyApp::Role::Schema::Result::Validatable' => {
columns => {
id => { isa => UUID },
name => { isa => Str },
},
},
);
sub _prepare_table {
my ($class) = @_;
$class->set_primary_key( qw(id) );
$class->uuid_columns( qw(id) );
$class->add_unique_constraint( [qw(name)] );
return;
}
# ****************************************************************
# business logic(s)
# ****************************************************************
sub salute {
my ($self) = @_;
printf(
"Hello, my name is %s.\n",
$self->name,
);
}
# ****************************************************************
# compile-time process(es)
# ****************************************************************
__PACKAGE__->_prepare_table;
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=encoding utf-8
=head1 NAME
MyApp::ConcreteTableInheritance::Schema::Base::Result::Player - blah blah blah
=head1 SYNOPSIS
# yada yada yada
=head1 DESCRIPTION
blah blah blah
=head1 AUTHOR
=over 4
=item MORIYA Masaki, alias Gardejo
C<< <moriya at cpan dot org> >>,
L<http://gardejo.org/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2010 MORIYA Masaki, alias Gardejo.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl|perlgpl> and L<perlartistic|perlartistic>.
The full text of the license can be found in the F<LICENSE> file included with
this distribution.
=cut
package MyApp::SingleTableInheritance::Schema::Result::Player;
use namespace::autoclean;
use Moose;
use MooseX::NonMoose;
use MooseX::Types::Moose qw(Str Num Undef);
use MooseX::Types::UUID qw(UUID);
extends qw(
DBIx::Class::Core
);
__PACKAGE__->load_components(qw(
UUIDColumns
));
# ****************************************************************
# table setting(s)
# ****************************************************************
__PACKAGE__->table('players');
__PACKAGE__->add_columns(
id => {
data_type => 'char',
size => 36,
},
name => {
data_type => 'varchar',
size => 32,
},
club => {
data_type => 'varchar',
size => 32,
is_nullable => 1,
},
batting_average => {
data_type => 'float',
is_nullable => 1,
},
bowling_average => {
data_type => 'float',
is_nullable => 1,
},
type => {
data_type => 'text',
},
);
# Or, use DBIx::Class::MooseColumns
with (
'MyApp::Role::Schema::Result::Validatable' => {
columns => {
id => { isa => UUID },
name => { isa => Str },
club => { isa => Str|Undef },
batting_average => { isa => Num|Undef },
bowling_average => { isa => Num|Undef },
type => { isa => Str },
},
},
);
sub _prepare_table {
my ($class) = @_;
$class->set_primary_key( qw(id) );
$class->uuid_columns( qw(id) );
$class->add_unique_constraint( [qw(name)] );
return;
}
sub insert {
my ($self, $arguments) = @_;
$self->type(blessed $self);
return $self->next::method($arguments);
}
sub update {
my ($self, $arguments) = @_;
delete $arguments->{type}
if defined $arguments
&& ref $arguments eq 'HASH'
&& exists $arguments->{type};
return $self->next::method($arguments);
}
# ****************************************************************
# business logic(s)
# ****************************************************************
sub salute {
my ($self) = @_;
printf(
"Hello, my name is %s.\n",
$self->name,
);
}
# ****************************************************************
# compile-time process(es)
# ****************************************************************
__PACKAGE__->_prepare_table;
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=encoding utf-8
=head1 NAME
MyApp::SingleTableInheritance::Schema::Result::Player - blah blah blah
=head1 SYNOPSIS
# yada yada yada
=head1 DESCRIPTION
blah blah blah
=head1 AUTHOR
=over 4
=item MORIYA Masaki, alias Gardejo
C<< <moriya at cpan dot org> >>,
L<http://gardejo.org/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2010 MORIYA Masaki, alias Gardejo.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl|perlgpl> and L<perlartistic|perlartistic>.
The full text of the license can be found in the F<LICENSE> file included with
this distribution.
=cut
package MyApp::ClassTableInheritance::Schema;
use namespace::autoclean;
use Moose;
use MooseX::NonMoose;
extends qw(
DBIx::Class::Schema
);
__PACKAGE__->load_namespaces;
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=encoding utf-8
=head1 NAME
MyApp::ClassTableInheritance::Schema - blah blah blah
=head1 SYNOPSIS
# yada yada yada
=head1 DESCRIPTION
blah blah blah
=head1 AUTHOR
=over 4
=item MORIYA Masaki, alias Gardejo
C<< <moriya at cpan dot org> >>,
L<http://gardejo.org/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2010 MORIYA Masaki, alias Gardejo.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl|perlgpl> and L<perlartistic|perlartistic>.
The full text of the license can be found in the F<LICENSE> file included with
this distribution.
=cut
package MyApp::ConcreteTableInheritance::Schema;
use namespace::autoclean;
use Moose;
use MooseX::NonMoose;
extends qw(
DBIx::Class::Schema
);
__PACKAGE__->load_namespaces;
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=encoding utf-8
=head1 NAME
MyApp::ConcreteTableInheritance::Schema - blah blah blah
=head1 SYNOPSIS
# yada yada yada
=head1 DESCRIPTION
blah blah blah
=head1 AUTHOR
=over 4
=item MORIYA Masaki, alias Gardejo
C<< <moriya at cpan dot org> >>,
L<http://gardejo.org/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2010 MORIYA Masaki, alias Gardejo.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl|perlgpl> and L<perlartistic|perlartistic>.
The full text of the license can be found in the F<LICENSE> file included with
this distribution.
=cut
package MyApp::SingleTableInheritance::Schema;
use namespace::autoclean;
use Moose;
use MooseX::NonMoose;
extends qw(
DBIx::Class::Schema
);
__PACKAGE__->load_namespaces;
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=encoding utf-8
=head1 NAME
MyApp::SingleTableInheritance::Schema - blah blah blah
=head1 SYNOPSIS
# yada yada yada
=head1 DESCRIPTION
blah blah blah
=head1 AUTHOR
=over 4
=item MORIYA Masaki, alias Gardejo
C<< <moriya at cpan dot org> >>,
L<http://gardejo.org/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2010 MORIYA Masaki, alias Gardejo.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl|perlgpl> and L<perlartistic|perlartistic>.
The full text of the license can be found in the F<LICENSE> file included with
this distribution.
=cut
#!/usr/bin/perl
use 5.010_000;
use strict;
use warnings;
use utf8;
use FindBin;
use lib "$FindBin::Bin/../lib";
use MyApp::SingleTableInheritance::Schema;
my $schema = MyApp::SingleTableInheritance::Schema->connect(
'dbi:SQLite:dbname=:memory:',
);
$schema->deploy;
my $txn_guard = $schema->txn_scope_guard;
say 'Footballer:';
my $footballer_rs = $schema->resultset('Footballer');
my $new_footballer = $footballer_rs->create({
name => 'Foo Bar the Kicker',
club => 'Baz F.C.',
});
$new_footballer->salute;
$new_footballer->kick;
say q();
say 'Cricketer:';
my $cricketer_rs = $schema->resultset('Cricketer');
my $new_cricketer = $cricketer_rs->create({
name => 'Foo Bar the Batter',
batting_average => 0.345,
});
$new_cricketer->salute;
$new_cricketer->bat;
say q();
say 'Bowler:';
my $bowler_rs = $schema->resultset('Bowler');
my $new_bowler = $bowler_rs->create({
name => 'Foo Bar the Bowler',
batting_average => 0.234,
bowling_average => 0.123,
});
$new_bowler->salute;
$new_bowler->bat;
$new_bowler->bowl;
say q();
$txn_guard->commit;
say 'Players:';
my $player_rs = $schema->resultset('Player');
my $all_players_rs = $player_rs->search([
{ type => 'MyApp::SingleTableInheritance::Schema::Result::Footballer' },
{ type => 'MyApp::SingleTableInheritance::Schema::Result::Cricketer' },
{ type => 'MyApp::SingleTableInheritance::Schema::Result::Bowler' },
]);
while (my $player = $all_players_rs->next) {
printf(
"%s,%s,%s,%0.3f,%0.3f,%s\n",
$player->id,
$player->name,
( $player->club // q() ),
( $player->batting_average // 0 ),
( $player->bowling_average // 0 ),
$player->type,
);
}
say q();
say 'Footballers:';
my $all_footballers_rs = $footballer_rs->search({
type => 'MyApp::SingleTableInheritance::Schema::Result::Footballer',
});
while (my $footballer = $all_footballers_rs->next) {
printf(
"%s,%s,%s,%0.3f,%0.3f,%s\n",
$footballer->id,
$footballer->name,
$footballer->club,
( $footballer->batting_average // 0 ), # Always zero
( $footballer->bowling_average // 0 ), # Always zero
$footballer->type,
);
}
say q();
say 'Cricketers:';
my $all_cricketers_rs = $cricketer_rs->search([
{ type => 'MyApp::SingleTableInheritance::Schema::Result::Cricketer' },
{ type => 'MyApp::SingleTableInheritance::Schema::Result::Bowler' },
]);
while (my $cricketer = $all_cricketers_rs->next) {
printf(
"%s,%s,%s,%0.3f,%0.3f,%s\n",
$cricketer->id,
$cricketer->name,
( $cricketer->club // q() ), # Always empty
$cricketer->batting_average,
( $cricketer->bowling_average // 0 ),
$cricketer->type,
);
}
say q();
say 'Bowlers:';
my $all_bowlers_rs = $bowler_rs->search({
type => 'MyApp::SingleTableInheritance::Schema::Result::Bowler',
});
while (my $bowler = $all_bowlers_rs->next) {
printf(
"%s,%s,%s,%0.3f,%0.3f,%s\n",
$bowler->id,
$bowler->name,
( $bowler->club // q() ), # Always empty
$bowler->batting_average,
$bowler->bowling_average,
$bowler->type,
);
}
say q();
exit;
__END__
=pod
=encoding utf-8
=head1 NAME
single_table_inheritance - An implementation of the Single Table Inheritance pattern
=head1 SYNOPSIS
% perl single_table_inheritance.pl
Footballer:
Hello, my name is Foo Bar the Kicker.
Foo Bar the Kicker (Baz F.C.) kicks a ball!
Cricketer:
Hello, my name is Foo Bar the Batter.
Foo Bar the Batter (ave.: 0.345) bats a ball!
Bowler:
Hello, my name is Foo Bar the Bowler.
Foo Bar the Bowler (ave.: 0.234) bats a ball!
Foo Bar the Bowler (ave.: 0.123) bowls a ball!
Players:
0EA0CBEC-97DF-1014-9A17-AA71D4AEE843,Foo Bar the Kicker,Baz F.C.,0.000,0.000,MyApp::SingleTableInheritance::Schema::Result::Footballer
1289FDDC-97DF-1014-BA01-A5D691001037,Foo Bar the Batter,,0.345,0.000,MyApp::SingleTableInheritance::Schema::Result::Cricketer
12CD3D98-97DF-1014-BA42-DEF7DAD9ABDC,Foo Bar the Bowler,,0.234,0.123,MyApp::SingleTableInheritance::Schema::Result::Bowler
Footballers:
0EA0CBEC-97DF-1014-9A17-AA71D4AEE843,Foo Bar the Kicker,Baz F.C.,0.000,0.000,MyApp::SingleTableInheritance::Schema::Result::Footballer
Cricketers:
1289FDDC-97DF-1014-BA01-A5D691001037,Foo Bar the Batter,,0.345,0.000,MyApp::SingleTableInheritance::Schema::Result::Cricketer
12CD3D98-97DF-1014-BA42-DEF7DAD9ABDC,Foo Bar the Bowler,,0.234,0.123,MyApp::SingleTableInheritance::Schema::Result::Bowler
Bowlers:
12CD3D98-97DF-1014-BA42-DEF7DAD9ABDC,Foo Bar the Bowler,,0.234,0.123,MyApp::SingleTableInheritance::Schema::Result::Bowler
=head1 DESCRIPTION
blah blah blah
=head2 Schema
CREATE TABLE players (
id char(36) NOT NULL,
name varchar(32) NOT NULL,
club varchar(32),
batting_average float,
bowling_average float,
type text NOT NULL,
PRIMARY KEY (id)
);
CREATE UNIQUE INDEX players_name ON players (name);
=head1 TO DO
=over 4
=item *
L<DBIx::Class::MooseColumns|DBIx::Class::MooseColumns> 0.10 cannot apply type
constraints at instanciation.
=back
=head1 SEE ALSO
=over 4
=item *
L<http://www.martinfowler.com/eaaCatalog/singleTableInheritance.html>
=item *
L<http://capsctrl.que.jp/kdmsnr/wiki/PofEAA/?SingleTableInheritance>
=back
=head1 AUTHOR
=over 4
=item MORIYA Masaki, alias Gardejo
C<< <moriya at cpan dot org> >>,
L<http://gardejo.org/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2010 MORIYA Masaki, alias Gardejo.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl|perlgpl> and L<perlartistic|perlartistic>.
The full text of the license can be found in the F<LICENSE> file included with
this distribution.
=cut
package MyApp::Role::Schema::Result::Validatable;
# ****************************************************************
# pragma(ta)
# ****************************************************************
use strict;
use warnings;
use utf8;
# ****************************************************************
# namespace cleaner
# ****************************************************************
use namespace::autoclean;
# ****************************************************************
# MOP dependency(-ies)
# ****************************************************************
use MooseX::Params::Validate qw(validated_list);
use MooseX::Role::Parameterized;
use MooseX::Types::Moose qw(HashRef);
# ****************************************************************
# parameter(s)
# ****************************************************************
parameter columns => (
isa => HashRef,
required => 1,
);
# ****************************************************************
# validation behavior(s)
# ****************************************************************
role {
my $parameter = shift;
while ( my ($column_name, $constraint) = each %{ $parameter->columns } ) {
my $accessor = $column_name;
my $validator = "_validate_$column_name";
around BUILDARGS => sub {
my $next = shift;
my $class = shift;
my $init_args = $class->$next(@_);
$class->$validator( $init_args->{$column_name} )
if exists $init_args->{$column_name};
return $init_args;
};
before $accessor => sub {
my $self = shift;
$self->$validator($_[0])
if scalar @_;
return;
};
method $validator => sub {
# To do: Replace MooseX::Params::Validate with Smart::Args
my ($invocant, $value) = @_;
return validated_list(
[ $column_name => $value ],
$column_name => $constraint,
);
};
}
};
# ****************************************************************
# return ture
# ****************************************************************
1;
__END__
# ****************************************************************
# POD
# ****************************************************************
=pod
=encoding utf-8
=head1 NAME
Amikeco::Role::Schema::Result::Validatable - A validator role for column(s) of DBIx::Class
=head1 SYNOPSIS
package Amikeco::Schema::Result::Foobar;
use Moose;
use MooseX::StrictConstructor;
use MooseX::Types::DateTimeX qw(DateTime);
use MooseX::Types::UUID qw(UUID);
extends qw(Amikeco::Schema::Base::Result);
__PACKAGE__->load_components( qw(
TimeStamp
UUIDColumns
) );
__PACKAGE__->table('foobars');
__PACKAGE__->add_columns(
id => { data_type => 'char', size => 36, },
created_on => { data_type => 'char', size => 36,
set_on_create => 1 },
);
__PACKAGE__->set_primary_key( qw(id) );
__PACKAGE__->uuid_columns( qw(id) );
with (
'Amikeco::Role::Schema::Result::Validatable' => {
columns => {
id => { isa => UUID },
created_on => { isa => DateTime, coerce => 1 },
},
},
);
# ...
=head1 DESCRIPTION
This is a validator role for column(s) of L<DBIx::Class|DBIx::Class>.
=head1 SEE ALSO
=over 4
=item DBIx::Class::MooseColumn 0.10 cannot validate attributes until instantiation (My gist)
L<http://gist.github.org/xxxxxx>
=item DBIx::Class::MooseColumn (CPAN)
L<DBIx::Class::MooseColumn|DBIx::Class::MooseColumn>
=back
=head1 AUTHOR
=over 4
=item MORIYA Masaki, alias Gardejo
C<< <moriya at cpan dot org> >>,
L<http://gardejo.org/>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2009-2010 MORIYA Masaki, alias Gardejo.
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
See L<perlgpl|perlgpl> and L<perlartistic|perlartistic>.
The full text of the license can be found in the F<LICENSE> file included with
this distribution.
=cut
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment