Skip to content

Instantly share code, notes, and snippets.

@gardejo
Created December 9, 2010 15:45
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save gardejo/734858 to your computer and use it in GitHub Desktop.
Save gardejo/734858 to your computer and use it in GitHub Desktop.
Several implementation for the table inheritance patterns (with DBIx::ObjectMapper)
package MyApp::Domain::Bowler;
use namespace::autoclean;
use Moose;
extends qw(
MyApp::Domain::Cricketer
);
has bowling_average => (
is => 'rw',
isa => 'Num',
);
sub bowl {
my $self = shift;
printf(
"%s (ave.: %0.3f) bowls a ball!\n",
$self->name,
$self->bowling_average,
);
return;
}
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=encoding utf-8
=head1 NAME
MyApp::Domain::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.008_001;
use strict;
use warnings;
use utf8;
use FindBin;
use lib "$FindBin::Bin/../lib";
use MyApp::Mapper;
use MyApp::Service;
my $service = MyApp::Service->new(
mapper => MyApp::Mapper->new_with_config(
configfile => "$FindBin::Bin/../etc/class_table_inheritance.yml",
)->mapper,
);
$service->add_footballer;
$service->add_cricketer;
$service->add_bowler;
$service->session->commit;
$service->show_players;
$service->show_footballers;
$service->show_cricketers;
$service->show_bowlers;
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:
23E3FA3F-DDC0-1014-8CCC-988FAC9270DA,Foo Bar the Kicker
2421FC1A-DDC0-1014-8E71-CC75B9FCC636,Foo Bar the Batter
24551CC6-DDC0-1014-B9E1-8C485EB7137D,Foo Bar the Bowler
Footballers:
23E3FA3F-DDC0-1014-8CCC-988FAC9270DA,Foo Bar the Kicker,Baz F.C.
Cricketers:
2421FC1A-DDC0-1014-8E71-CC75B9FCC636,Foo Bar the Batter,0.345
24551CC6-DDC0-1014-B9E1-8C485EB7137D,Foo Bar the Bowler,0.234
Bowlers:
24551CC6-DDC0-1014-B9E1-8C485EB7137D,Foo Bar the Bowler,0.234,0.123
=head1 DESCRIPTION
blah blah blah
=head2 Schema
See the L<class_table_inheritance.yml> file included with this distribution.
=head1 SEE ALSO
=over 4
=item *
L<http://www.martinfowler.com/eaaCatalog/classTableInheritance.html>
=item *
L<http://capsctrl.que.jp/kdmsnr/wiki/PofEAA/?ClassTableInheritance>
=item *
L<DBIx::ObjectMapper|DBIx::ObjectMapper>
=item *
L<http://blog.eorzea.asia/2010/12/post_94.html>
=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
connection :
dsn : "dbi:SQLite:dbname=:memory:"
username : ~
password : ~
sqlite_unicode : 1
on_connect_do :
# - |+
# PRAGMA foreign_keys = ON
- |+
CREATE TABLE players (
id TEXT NOT NULL,
name TEXT NOT NULL,
type TEXT NOT NULL, -- hmm...
PRIMARY KEY (id)
)
- |+
CREATE UNIQUE INDEX players_name ON players (name)
- |+
CREATE TABLE footballers (
id TEXT NOT NULL,
club TEXT NOT NULL,
PRIMARY KEY (id)
-- PRIMARY KEY (id),
-- FOREIGN KEY (id) REFERENCES players (id)
)
- |+
CREATE TABLE cricketers (
id TEXT NOT NULL,
batting_average REAL NOT NULL,
PRIMARY KEY (id)
-- PRIMARY KEY (id),
-- FOREIGN KEY (id) REFERENCES players (id)
)
- |+
CREATE TABLE bowlers (
id TEXT NOT NULL,
bowling_average REAL NOT NULL,
PRIMARY KEY (id)
-- PRIMARY KEY (id),
-- FOREIGN KEY (id) REFERENCES cricketers (id)
)
session :
autocommit : 0
no_cache : 1
mapping :
- - players
- MyApp::Domain::Player
- attributes :
include :
- id
- name
# hmm...
polymorphic_on : type
- - footballers
- MyApp::Domain::Footballer
- attributes :
include :
- id
- name
- club
inherits : MyApp::Domain::Player
# hmm...
polymorphic_identity : footballer
- - cricketers
- MyApp::Domain::Cricketer
- attributes :
include :
- id
- name
- batting_average
inherits : MyApp::Domain::Player
# hmm...
polymorphic_identity : cricketer
- - bowlers
- MyApp::Domain::Bowler
- attributes :
include :
- id
- name
- batting_average
- bowling_average
inherits : MyApp::Domain::Cricketer
# hmm...
polymorphic_identity : bowler
#!/usr/bin/perl
use 5.008_001;
use strict;
use warnings;
use utf8;
use FindBin;
use lib "$FindBin::Bin/../lib";
use MyApp::Mapper;
use MyApp::Service;
my $service = MyApp::Service->new(
mapper => MyApp::Mapper->new_with_config(
configfile => "$FindBin::Bin/../etc/concrete_table_inheritance.yml",
)->mapper,
);
$service->add_footballer;
$service->add_cricketer;
$service->add_bowler;
$service->session->commit;
$service->show_footballers;
$service->show_cricketers;
$service->show_bowlers;
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 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!
Footballers:
DF13655A-D8C9-1014-BE0F-D6F1743343BE,Foo Bar the Kicker,Baz F.C.
Cricketers:
DF4D96BE-D8C9-1014-B96A-D4B3A4DECFF7,Foo Bar the Batter,0.345
Bowlers:
DF895AB5-D8C9-1014-8361-A3DB137E06E9,Foo Bar the Bowler,0.234,0.123
=head1 DESCRIPTION
blah blah blah
=head2 Schema
See the L<concrete_table_inheritance.yml> file included with this distribution.
=head1 SEE ALSO
=over 4
=item *
L<http://www.martinfowler.com/eaaCatalog/concreteTableInheritance.html>
=item *
L<http://capsctrl.que.jp/kdmsnr/wiki/PofEAA/?ConcreteTableInheritance>
=item *
L<DBIx::ObjectMapper|DBIx::ObjectMapper>
=item *
L<http://blog.eorzea.asia/2010/12/post_94.html>
=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
connection :
dsn : "dbi:SQLite:dbname=:memory:"
username : ~
password : ~
sqlite_unicode : 1
on_connect_do :
- |+
CREATE TABLE footballers (
id TEXT NOT NULL,
name TEXT NOT NULL,
club TEXT NOT NULL,
PRIMARY KEY (id)
)
- |+
CREATE UNIQUE INDEX footballers_name ON footballers (name)
- |+
CREATE TABLE cricketers (
id TEXT NOT NULL,
name TEXT NOT NULL,
batting_average REAL NOT NULL,
PRIMARY KEY (id)
)
- |+
CREATE UNIQUE INDEX cricketers_name ON cricketers (name)
- |+
CREATE TABLE bowlers (
id TEXT NOT NULL,
name TEXT NOT NULL,
batting_average REAL NOT NULL,
bowling_average REAL NOT NULL,
PRIMARY KEY (id)
)
- |+
CREATE UNIQUE INDEX bowlers_name ON bowlers (name)
session :
autocommit : 0
no_cache : 1
mapping :
- - footballers
- MyApp::Domain::Footballer
- attributes :
include :
- id
- name
- club
- - cricketers
- MyApp::Domain::Cricketer
- attributes :
include :
- id
- name
- batting_average
- - bowlers
- MyApp::Domain::Bowler
- attributes :
include :
- id
- name
- batting_average
- bowling_average
package MyApp::Domain::Cricketer;
use namespace::autoclean;
use Moose;
extends qw(
MyApp::Domain::Player
);
has batting_average => (
is => 'rw',
isa => 'Num',
);
sub bat {
my $self = shift;
printf(
"%s (ave.: %0.3f) bats a ball!\n",
$self->name,
$self->batting_average,
);
return;
}
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=encoding utf-8
=head1 NAME
MyApp::Domain::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::Domain::Footballer;
use namespace::autoclean;
use Moose;
extends qw(
MyApp::Domain::Player
);
has club => (
is => 'rw',
isa => 'Str',
);
sub kick {
my $self = shift;
printf(
"%s (%s) kicks a ball!\n",
$self->name,
$self->club,
);
return;
}
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=encoding utf-8
=head1 NAME
MyApp::Domain::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::Mapper;
use namespace::autoclean;
use Moose;
use DBIx::ObjectMapper;
use DBIx::ObjectMapper::Engine::DBI;
with qw(
MooseX::SimpleConfig
);
has [qw(connection session)] => (
is => 'ro',
required => 1,
isa => 'HashRef',
);
has mapping => (
traits => [qw(
Array
)],
is => 'ro',
required => 1,
isa => 'ArrayRef',
handles => {
all_mappings => 'elements',
},
);
has engine => (
is => 'ro',
init_arg => undef,
isa => 'DBIx::ObjectMapper::Engine::DBI',
lazy_build => 1,
);
has mapper => (
is => 'ro',
init_arg => undef,
isa => 'DBIx::ObjectMapper',
lazy_build => 1,
);
sub _build_engine {
my $self = shift;
my $connection = $self->connection;
my $engine = DBIx::ObjectMapper::Engine::DBI->new($connection);
return $engine;
}
sub _build_mapper {
my $self = shift;
my $mapper = DBIx::ObjectMapper->new(
engine => $self->engine,
session_attr => $self->session,
);
$mapper->metadata->autoload_all_tables;
foreach my $mapping ( $self->all_mappings ) {
my ($table_name, $class_name, $setting) = @$mapping;
my $table = $mapper->metadata->table($table_name);
$mapper->maps(
$table => $class_name,
( $setting ? %$setting : () ),
);
}
return $mapper;
}
__PACKAGE__->meta->make_immutable;
=pod
=encoding utf-8
=head1 NAME
MyApp::Mapper - 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::Domain::Player;
use namespace::autoclean;
use Moose;
use MooseX::Types::UUID qw(UUID);
use Data::UUID;
has id => (
is => 'rw', # Caveat: Do not set 'ro'!
isa => UUID,
lazy_build => 1,
);
has name => (
is => 'rw',
required => 1,
isa => 'Str',
);
# Note: We need not to set `type` attribute into the class
# to implement Single Table Inheritance and Class Table Inheritance.
sub _build_id {
return Data::UUID->new->create_str;
}
sub salute {
my ($self) = @_;
printf(
"Hello, my name is %s.\n",
$self->name,
);
}
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=encoding utf-8
=head1 NAME
MyApp::Domain::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::Service;
use namespace::autoclean;
use Moose;
use MyApp::Domain::Bowler;
use MyApp::Domain::Cricketer;
use MyApp::Domain::Footballer;
has mapper => (
is => 'rw',
required => 1,
isa => 'DBIx::ObjectMapper',
);
has session => (
is => 'rw',
isa => 'DBIx::ObjectMapper::Session',
lazy_build => 1,
);
sub _build_session {
my $self = shift;
return $self->mapper->begin_session;
}
sub add_footballer {
my $self = shift;
print "Footballer:\n";
my $new_footballer = MyApp::Domain::Footballer->new(
name => 'Foo Bar the Kicker',
club => 'Baz F.C.',
);
$new_footballer->salute;
$new_footballer->kick;
$self->session->add($new_footballer);
print "\n";
return;
}
sub add_cricketer {
my $self = shift;
print "Cricketer:\n";
my $new_cricketer = MyApp::Domain::Cricketer->new(
name => 'Foo Bar the Batter',
batting_average => 0.345,
);
$new_cricketer->salute;
$new_cricketer->bat;
$self->session->add($new_cricketer);
print "\n";
return;
}
sub add_bowler {
my $self = shift;
print "Bowler:\n";
my $new_bowler = MyApp::Domain::Bowler->new(
name => 'Foo Bar the Bowler',
batting_average => 0.234,
bowling_average => 0.123,
);
$new_bowler->salute;
$new_bowler->bat;
$new_bowler->bowl;
$self->session->add($new_bowler);
print "\n";
return;
}
sub show_players {
my $self = shift;
print "Players:\n";
my $all_players
= $self->session->search('MyApp::Domain::Player')->execute;
while ( my $player = $all_players->next ) {
printf(
"%s,%s\n",
$player->id,
$player->name,
);
}
print "\n";
return;
}
sub show_footballers {
my $self = shift;
print "Footballers:\n";
my $all_footballers
= $self->session->search('MyApp::Domain::Footballer')->execute;
while ( my $footballer = $all_footballers->next ) {
printf(
"%s,%s,%s\n",
$footballer->id,
$footballer->name,
$footballer->club,
);
}
print "\n";
return;
}
sub show_cricketers {
my $self = shift;
print "Cricketers:\n";
my $all_cricketers
= $self->session->search('MyApp::Domain::Cricketer')->execute;
while ( my $cricketer = $all_cricketers->next ) {
printf(
"%s,%s,%0.3f\n",
$cricketer->id,
$cricketer->name,
$cricketer->batting_average,
);
}
print "\n";
return;
}
sub show_bowlers {
my $self = shift;
print "Bowlers:\n";
my $all_bowlers
= $self->session->search('MyApp::Domain::Bowler')->execute;
while ( my $bowler = $all_bowlers->next ) {
printf(
"%s,%s,%0.3f,%0.3f\n",
$bowler->id,
$bowler->name,
$bowler->batting_average,
$bowler->bowling_average,
);
}
print "\n";
return;
}
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=encoding utf-8
=head1 NAME
MyApp::Example - 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.008_001;
use strict;
use warnings;
use utf8;
use FindBin;
use lib "$FindBin::Bin/../lib";
use MyApp::Mapper;
use MyApp::Service;
my $service = MyApp::Service->new(
mapper => MyApp::Mapper->new_with_config(
configfile => "$FindBin::Bin/../etc/single_table_inheritance.yml",
)->mapper,
);
$service->add_footballer;
$service->add_cricketer;
$service->add_bowler;
$service->session->commit;
$service->show_players;
$service->show_footballers;
$service->show_cricketers;
$service->show_bowlers;
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:
99C898EC-D8F4-1014-A583-871D3669C63C,Foo Bar the Kicker
9A053225-D8F4-1014-A8A0-F71AD1968877,Foo Bar the Batter
9A3B69CC-D8F4-1014-90DE-9299C16E7BB1,Foo Bar the Bowler
Footballers:
99C898EC-D8F4-1014-A583-871D3669C63C,Foo Bar the Kicker,Baz F.C.
Cricketers:
9A053225-D8F4-1014-A8A0-F71AD1968877,Foo Bar the Batter,0.345
9A3B69CC-D8F4-1014-90DE-9299C16E7BB1,Foo Bar the Bowler,0.234
Bowlers:
9A3B69CC-D8F4-1014-90DE-9299C16E7BB1,Foo Bar the Bowler,0.234,0.123
=head1 DESCRIPTION
blah blah blah
=head2 Schema
See the L<single_table_inheritance.yml> file included with this distribution.
=head1 SEE ALSO
=over 4
=item *
L<http://www.martinfowler.com/eaaCatalog/singleTableInheritance.html>
=item *
L<http://capsctrl.que.jp/kdmsnr/wiki/PofEAA/?SingleTableInheritance>
=item *
L<DBIx::ObjectMapper|DBIx::ObjectMapper>
=item *
L<http://blog.eorzea.asia/2010/12/post_94.html>
=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
connection :
dsn : "dbi:SQLite:dbname=:memory:"
username : ~
password : ~
sqlite_unicode : 1
on_connect_do :
- |+
CREATE TABLE players (
id TEXT NOT NULL,
name TEXT NOT NULL,
club TEXT,
batting_average REAL,
bowling_average REAL,
type TEXT NOT NULL,
PRIMARY KEY (id)
)
- |+
CREATE UNIQUE INDEX players_name ON players (name)
session :
autocommit : 0
no_cache : 1
mapping :
- - players
- MyApp::Domain::Player
- attributes :
include :
- id
- name
polymorphic_on : type
- - players
- MyApp::Domain::Footballer
- attributes :
include :
- id
- name
- club
inherits : MyApp::Domain::Player
polymorphic_identity : footballer
- - players
- MyApp::Domain::Cricketer
- attributes :
include :
- id
- name
- batting_average
inherits : MyApp::Domain::Player
polymorphic_identity : cricketer
- - players
- MyApp::Domain::Bowler
- attributes :
include :
- id
- name
- batting_average
- bowling_average
inherits : MyApp::Domain::Cricketer
polymorphic_identity : bowler
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment