├── author ├── .gitignore ├── lib │ ├── SampleTeng │ │ ├── DB.pm │ │ └── DB │ │ │ └── Schema.pm │ ├── SampleAniki │ │ ├── DB.pm │ │ └── DB │ │ │ ├── Filter.pm │ │ │ └── Schema.pm │ └── SampleDbic │ │ ├── Schema.pm │ │ └── Schema │ │ ├── Module.pm │ │ └── Author.pm ├── README.md └── benchmark.pl ├── t ├── lib │ └── t │ │ ├── DB │ │ ├── Row.pm │ │ ├── Row │ │ │ └── Author.pm │ │ ├── Schema │ │ │ ├── MySQL.pm │ │ │ ├── SQLite.pm │ │ │ ├── PostgreSQL.pm │ │ │ └── Common.pm │ │ ├── Exception.pm │ │ └── Filter.pm │ │ ├── Util.pm │ │ └── DB.pm ├── 02_insert.t ├── 12_new_row_from_hashref.t ├── row │ ├── can.t │ └── joined │ │ └── can.t ├── schema │ ├── relationship │ │ ├── pluralize.t │ │ ├── basic.t │ │ └── name.t │ ├── 00_has_many.t │ └── relationships │ │ └── basic.t ├── plugin │ ├── weighted_round_robin │ │ └── weighted_round_robin.t │ ├── count │ │ └── count.t │ ├── range_condition_maker │ │ └── make_range_condition.t │ ├── pager_injector │ │ └── inject_pager_to_result.t │ ├── sql_pager │ │ ├── select_named_with_pager.t │ │ └── select_by_sql_with_pager.t │ ├── pager │ │ └── select_with_pager.t │ └── select_joined │ │ └── select_joined.t ├── 01_new.t ├── 04_insert_and_fetch_row.t ├── 00_compile.t ├── 03_insert_and_fetch_id.t ├── 13_new_collection_from_arrayref.t ├── 10_delete.t ├── 07_insert_on_duplicate.t ├── 08_select.t ├── 05_insert_and_emulate_row.t ├── 06_insert_multi.t ├── 09_update.t ├── filter │ ├── deflate_and_inflate.t │ ├── deflate │ │ ├── basic.t │ │ └── regex.t │ ├── inflate │ │ ├── basic.t │ │ └── regex.t │ ├── trigger │ │ └── basic.t │ └── declare │ │ └── basic.t ├── query_builder │ └── canonical.t ├── 14_update_and_fetch_row.t ├── 15_update_and_emulate_row.t ├── handler │ └── weighted_round_robin.t └── 11_relay.t ├── minil.toml ├── lib └── Aniki │ ├── QueryBuilder.pm │ ├── Result │ ├── Role │ │ └── Pager.pm │ ├── Collection.pm │ └── Collection │ │ └── Joined.pm │ ├── Schema │ ├── Table │ │ ├── PrimaryKey.pm │ │ └── Field.pm │ ├── Relationships.pm │ ├── Relationship │ │ ├── Declare.pm │ │ └── Fetcher.pm │ ├── Table.pm │ └── Relationship.pm │ ├── Row │ └── Joined.pm │ ├── Plugin │ ├── WeightedRoundRobin.pm │ ├── Count.pm │ ├── Pager.pm │ ├── SQLPager.pm │ ├── PagerInjector.pm │ ├── RangeConditionMaker.pm │ └── SelectJoined.pm │ ├── QueryBuilder │ └── Canonical.pm │ ├── Result.pm │ ├── Schema.pm │ ├── Filter │ └── Declare.pm │ ├── Handler │ └── WeightedRoundRobin.pm │ ├── Handler.pm │ ├── Filter.pm │ └── Row.pm ├── eg ├── lib │ └── MyProj │ │ ├── DB.pm │ │ └── DB │ │ ├── Schema.pm │ │ └── Filter.pm └── synopsis.pl ├── .gitignore ├── Build.PL ├── .circleci └── config.yml ├── cpanfile ├── script └── install-aniki ├── META.json ├── Changes └── README.md /author/.gitignore: -------------------------------------------------------------------------------- 1 | /nytprof.out 2 | /nytprof/ -------------------------------------------------------------------------------- /t/lib/t/DB/Row.pm: -------------------------------------------------------------------------------- 1 | package t::DB::Row; 2 | use Mouse v2.4.5; 3 | extends qw/Aniki::Row/; 4 | 5 | 1; 6 | __END__ 7 | -------------------------------------------------------------------------------- /t/lib/t/DB/Row/Author.pm: -------------------------------------------------------------------------------- 1 | package t::DB::Row::Author; 2 | use Mouse v2.4.5; 3 | extends qw/t::DB::Row/; 4 | 5 | 1; 6 | __END__ 7 | -------------------------------------------------------------------------------- /author/lib/SampleTeng/DB.pm: -------------------------------------------------------------------------------- 1 | package SampleTeng::DB; 2 | use strict; 3 | use warnings; 4 | use utf8; 5 | use parent qw/Teng/; 6 | 7 | 1; 8 | __END__ 9 | -------------------------------------------------------------------------------- /minil.toml: -------------------------------------------------------------------------------- 1 | name = "Aniki" 2 | badges = ["circleci", "codecov", "metacpan"] 3 | authority="cpan:KARUPA" 4 | module_maker="ModuleBuildTiny" 5 | markdown_maker = "Pod::Markdown::Github" 6 | 7 | [Metadata] 8 | x_static_install = 1 -------------------------------------------------------------------------------- /author/lib/SampleAniki/DB.pm: -------------------------------------------------------------------------------- 1 | use 5.014002; 2 | package SampleAniki::DB { 3 | use Mouse v2.4.5; 4 | extends qw/Aniki/; 5 | 6 | __PACKAGE__->setup( 7 | schema => 'SampleAniki::DB::Schema', 8 | filter => 'SampleAniki::DB::Filter', 9 | ); 10 | 11 | }; 12 | 13 | 1; 14 | -------------------------------------------------------------------------------- /lib/Aniki/QueryBuilder.pm: -------------------------------------------------------------------------------- 1 | package Aniki::QueryBuilder; 2 | use 5.014002; 3 | 4 | use strict; 5 | use warnings; 6 | 7 | use SQL::Maker 1.19; 8 | use parent qw/SQL::Maker/; 9 | 10 | __PACKAGE__->load_plugin('InsertMulti'); 11 | __PACKAGE__->load_plugin('InsertOnDuplicate'); 12 | 13 | 1; 14 | __END__ 15 | -------------------------------------------------------------------------------- /eg/lib/MyProj/DB.pm: -------------------------------------------------------------------------------- 1 | use 5.014002; 2 | package MyProj::DB { 3 | use Mouse; 4 | extends qw/Aniki/; 5 | 6 | __PACKAGE__->setup( 7 | schema => 'MyProj::DB::Schema', 8 | filter => 'MyProj::DB::Filter', 9 | ); 10 | 11 | __PACKAGE__->meta->make_immutable(); 12 | }; 13 | 14 | 1; 15 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /.build/ 2 | /_build/ 3 | /Build 4 | /Build.bat 5 | /blib 6 | /Makefile 7 | 8 | /carton.lock 9 | /.carton/ 10 | /local/ 11 | 12 | nytprof.out 13 | nytprof/ 14 | 15 | cover_db/ 16 | 17 | *.bak 18 | *.old 19 | *~ 20 | *.swp 21 | *.o 22 | *.obj 23 | 24 | !LICENSE 25 | 26 | /_build_params 27 | 28 | MYMETA.* 29 | 30 | /Aniki-* 31 | -------------------------------------------------------------------------------- /Build.PL: -------------------------------------------------------------------------------- 1 | # ========================================================================= 2 | # THIS FILE IS AUTOMATICALLY GENERATED BY MINILLA. 3 | # DO NOT EDIT DIRECTLY. 4 | # ========================================================================= 5 | 6 | use 5.008_001; 7 | use strict; 8 | 9 | use Module::Build::Tiny 0.035; 10 | 11 | Build_PL(); 12 | 13 | -------------------------------------------------------------------------------- /lib/Aniki/Result/Role/Pager.pm: -------------------------------------------------------------------------------- 1 | package Aniki::Result::Role::Pager; 2 | use 5.014002; 3 | 4 | use namespace::autoclean; 5 | use Mouse::Role; 6 | use Mouse::Util::TypeConstraints qw/duck_type/; 7 | 8 | has pager => ( 9 | is => 'rw', 10 | isa => duck_type(qw/entries_per_page current_page entries_on_this_page/), 11 | ); 12 | 13 | 1; 14 | __END__ 15 | -------------------------------------------------------------------------------- /t/02_insert.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | 7 | use File::Spec; 8 | use lib File::Spec->catfile('t', 'lib'); 9 | use t::Util; 10 | 11 | run_on_database { 12 | db->insert(author => { name => 'MOZNION' }); 13 | is db->select(author => {}, { limit => 1 })->count, 1, 'created.'; 14 | }; 15 | 16 | done_testing(); 17 | -------------------------------------------------------------------------------- /t/lib/t/DB/Schema/MySQL.pm: -------------------------------------------------------------------------------- 1 | package t::DB::Schema::MySQL; 2 | use strict; 3 | use warnings; 4 | 5 | use DBIx::Schema::DSL; 6 | 7 | use t::DB::Schema::Common (); 8 | our $CONTEXT = t::DB::Schema::Common->context->clone; 9 | __PACKAGE__->context->schema->database(database 'MySQL'); 10 | 11 | sub relationship_rules { t::DB::Schema::Common->relationship_rules } 12 | 13 | 1; 14 | -------------------------------------------------------------------------------- /t/lib/t/DB/Schema/SQLite.pm: -------------------------------------------------------------------------------- 1 | package t::DB::Schema::SQLite; 2 | use strict; 3 | use warnings; 4 | 5 | use DBIx::Schema::DSL; 6 | 7 | use t::DB::Schema::Common (); 8 | our $CONTEXT = t::DB::Schema::Common->context->clone; 9 | __PACKAGE__->context->schema->database(database 'SQLite'); 10 | 11 | sub relationship_rules { t::DB::Schema::Common->relationship_rules } 12 | 13 | 1; 14 | -------------------------------------------------------------------------------- /author/lib/SampleDbic/Schema.pm: -------------------------------------------------------------------------------- 1 | package SampleDbic::Schema; 2 | use strict; 3 | use warnings; 4 | use utf8; 5 | 6 | use parent qw/DBIx::Class::Schema/; 7 | use SampleDbic::Schema::Author; 8 | use SampleDbic::Schema::Module; 9 | 10 | __PACKAGE__->register_class('Author', 'SampleDbic::Schema::Author'); 11 | __PACKAGE__->register_class('Module', 'SampleDbic::Schema::Module'); 12 | 13 | 1; 14 | -------------------------------------------------------------------------------- /t/lib/t/DB/Schema/PostgreSQL.pm: -------------------------------------------------------------------------------- 1 | package t::DB::Schema::PostgreSQL; 2 | use strict; 3 | use warnings; 4 | 5 | use DBIx::Schema::DSL; 6 | 7 | use t::DB::Schema::Common (); 8 | our $CONTEXT = t::DB::Schema::Common->context->clone; 9 | __PACKAGE__->context->schema->database(database 'PostgreSQL'); 10 | 11 | sub relationship_rules { t::DB::Schema::Common->relationship_rules } 12 | 13 | 1; 14 | -------------------------------------------------------------------------------- /t/12_new_row_from_hashref.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | 7 | use File::Spec; 8 | use lib File::Spec->catfile('t', 'lib'); 9 | use t::Util; 10 | 11 | run_on_database { 12 | my $karupa = db->new_row_from_hashref(author => { name => 'KARUPA' }); 13 | isa_ok $karupa, 't::DB::Row::Author'; 14 | is $karupa->name, 'KARUPA'; 15 | }; 16 | 17 | done_testing(); 18 | -------------------------------------------------------------------------------- /t/row/can.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | 7 | use File::Spec; 8 | use lib File::Spec->catfile('t', 'lib'); 9 | use t::Util; 10 | 11 | run_on_database { 12 | my $moznion = db->insert_and_fetch_row(author => { name => 'MOZNION' }); 13 | can_ok $moznion, qw/relay get_column name modules/; 14 | can_ok 't::DB::Row::Author', qw/relay get_column/; 15 | }; 16 | 17 | done_testing(); 18 | -------------------------------------------------------------------------------- /t/lib/t/DB/Exception.pm: -------------------------------------------------------------------------------- 1 | package t::DB::Exception; 2 | use strict; 3 | use warnings; 4 | 5 | use Scalar::Util qw/blessed/; 6 | 7 | sub new { 8 | my $class = shift; 9 | return bless {@_} => $class; 10 | } 11 | 12 | sub message { shift->{message} } 13 | 14 | sub throw { die shift->new(@_) } 15 | 16 | sub caught { 17 | my ($class, $e) = @_; 18 | return blessed $e && $e->isa($class); 19 | } 20 | 21 | 1; 22 | __END__ 23 | -------------------------------------------------------------------------------- /t/lib/t/DB/Filter.pm: -------------------------------------------------------------------------------- 1 | package t::DB::Filter; 2 | use strict; 3 | use warnings; 4 | use utf8; 5 | 6 | use Aniki::Filter::Declare; 7 | 8 | table author => sub { 9 | inflate 'inflate_message' => sub { 10 | my $value = shift; 11 | return "inflate $value"; 12 | }; 13 | deflate 'deflate_message' => sub { 14 | my $value = shift; 15 | return "deflate $value"; 16 | }; 17 | }; 18 | 19 | 1; 20 | __END__ 21 | -------------------------------------------------------------------------------- /t/schema/relationship/pluralize.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | 7 | use Aniki::Schema::Relationship; 8 | 9 | is Aniki::Schema::Relationship::_to_plural("hero"), "heroes"; 10 | is Aniki::Schema::Relationship::_to_plural("child"), "children"; 11 | is Aniki::Schema::Relationship::_to_plural("my_news"), "my_news"; 12 | is Aniki::Schema::Relationship::_to_plural("my child"), "my children"; 13 | 14 | done_testing(); 15 | -------------------------------------------------------------------------------- /t/plugin/weighted_round_robin/weighted_round_robin.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | use Test::Requires qw(Data::WeightedRoundRobin); 7 | 8 | use File::Spec; 9 | use lib File::Spec->catfile('t', 'lib'); 10 | use Mouse::Util; 11 | use t::Util; 12 | 13 | run_on_database { 14 | Mouse::Util::apply_all_roles(db, 'Aniki::Plugin::WeightedRoundRobin'); 15 | is db->handler_class, 'Aniki::Handler::WeightedRoundRobin'; 16 | }; 17 | 18 | done_testing(); 19 | -------------------------------------------------------------------------------- /t/01_new.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | 7 | use File::Spec; 8 | use lib File::Spec->catfile('t', 'lib'); 9 | use t::DB; 10 | 11 | t::DB->run_on_all_databases(sub { 12 | my $class = shift; 13 | 14 | my $db = $class->new(); 15 | isa_ok $db, 'Aniki'; 16 | }); 17 | 18 | subtest 'no connect info' => sub { 19 | my $db = eval { t::DB->new() }; 20 | ok not defined $db; 21 | like $@, qr/\A\QAttribute (connect_info) is required/m; 22 | }; 23 | 24 | done_testing(); 25 | -------------------------------------------------------------------------------- /author/lib/SampleAniki/DB/Filter.pm: -------------------------------------------------------------------------------- 1 | package SampleAniki::DB::Filter { 2 | use Aniki::Filter::Declare; 3 | use Scalar::Util qw/blessed/; 4 | use Time::Moment; 5 | 6 | # define inflate/deflate filters in table context. 7 | table author => sub { 8 | inflate name => sub { 9 | my $name = shift; 10 | return uc $name; 11 | }; 12 | 13 | deflate name => sub { 14 | my $name = shift; 15 | return lc $name; 16 | }; 17 | }; 18 | }; 19 | 20 | 1; 21 | __END__ 22 | -------------------------------------------------------------------------------- /t/schema/00_has_many.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | 7 | use File::Spec; 8 | use lib File::Spec->catfile('t', 'lib'); 9 | use t::Util; 10 | use t::DB; 11 | 12 | t::DB->run_on_each_databases([target_databases()] => sub { 13 | my $class = shift; 14 | 15 | ok !$class->schema->has_many(author => [qw/id/]), 'primary key'; 16 | ok !$class->schema->has_many(author => [qw/name/]), 'unique key'; 17 | ok +$class->schema->has_many(author => [qw/message/]), 'normal'; 18 | }); 19 | 20 | done_testing(); 21 | -------------------------------------------------------------------------------- /t/plugin/count/count.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | 7 | use File::Spec; 8 | use lib File::Spec->catfile('t', 'lib'); 9 | use Mouse::Util; 10 | use Aniki::Plugin::Count; 11 | use t::Util; 12 | 13 | run_on_database { 14 | Mouse::Util::apply_all_roles(db, 'Aniki::Plugin::Count'); 15 | 16 | db->insert_multi(author => [map { 17 | +{ name => $_ } 18 | } qw/MOZNION KARUPA PAPIX/]); 19 | 20 | my $count = db->count('author'); 21 | is $count, 3; 22 | 23 | $count = db->count('author', '*', { name => 'MOZNION' }); 24 | is $count, 1; 25 | }; 26 | 27 | done_testing(); 28 | -------------------------------------------------------------------------------- /t/04_insert_and_fetch_row.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | 7 | use File::Spec; 8 | use lib File::Spec->catfile('t', 'lib'); 9 | use t::Util; 10 | 11 | run_on_database { 12 | my $row = db->insert_and_fetch_row(author => { name => 'MOZNION' }); 13 | ok defined $row, 'row is defined.'; 14 | ok $row->is_new, 'new row.'; 15 | 16 | is_deeply $row->get_columns, { 17 | id => $row->id, 18 | name => 'MOZNION', 19 | message => 'hello', 20 | inflate_message => 'hello', 21 | deflate_message => 'hello', 22 | }, 'Data is valid.'; 23 | }; 24 | 25 | done_testing(); 26 | -------------------------------------------------------------------------------- /t/00_compile.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use Test::More 0.98; 3 | 4 | for () { 5 | chomp; 6 | use_ok $_; 7 | } 8 | 9 | done_testing; 10 | 11 | __DATA__ 12 | Aniki 13 | Aniki::Filter 14 | Aniki::Filter::Declare 15 | Aniki::QueryBuilder 16 | Aniki::QueryBuilder::Canonical 17 | Aniki::Result 18 | Aniki::Result::Collection 19 | Aniki::Result::Collection::Joined 20 | Aniki::Result::Role::Pager 21 | Aniki::Row 22 | Aniki::Row::Joined 23 | Aniki::Schema 24 | Aniki::Schema::Relationship 25 | Aniki::Schema::Relationship::Declare 26 | Aniki::Schema::Relationship::Fetcher 27 | Aniki::Schema::Relationships 28 | Aniki::Schema::Table 29 | Aniki::Schema::Table::Field 30 | Aniki::Schema::Table::PrimaryKey 31 | -------------------------------------------------------------------------------- /t/03_insert_and_fetch_id.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | 7 | use File::Spec; 8 | use lib File::Spec->catfile('t', 'lib'); 9 | use t::Util; 10 | 11 | run_on_database { 12 | my $id = db->insert_and_fetch_id(author => { name => 'MOZNION' }); 13 | ok defined $id, 'id is defined.'; 14 | 15 | my $row = db->select(author => { id => $id }, { limit => 1 })->first; 16 | is_deeply $row->get_columns, { 17 | id => $id, 18 | name => 'MOZNION', 19 | message => 'hello', 20 | inflate_message => 'hello', 21 | deflate_message => 'hello', 22 | }, 'Data is valid.'; 23 | }; 24 | 25 | done_testing(); 26 | -------------------------------------------------------------------------------- /t/row/joined/can.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | 7 | use File::Spec; 8 | use lib File::Spec->catfile('t', 'lib'); 9 | use t::Util; 10 | 11 | use Aniki::Row::Joined; 12 | 13 | run_on_database { 14 | my $author = db->insert_and_fetch_row(author => { name => 'MOZNION' }); 15 | my $module = db->insert_and_fetch_row(module => { name => 'Perl::Lint', author_id => $author->id }); 16 | 17 | my $row = Aniki::Row::Joined->new($author, $module); 18 | can_ok +$row, qw/author module/; 19 | is +$row->author->table_name, 'author'; 20 | is +$row->module->table_name, 'module'; 21 | 22 | eval { $row->version }; 23 | ok $@, 'should not have version'; 24 | }; 25 | 26 | done_testing(); 27 | -------------------------------------------------------------------------------- /eg/lib/MyProj/DB/Schema.pm: -------------------------------------------------------------------------------- 1 | use 5.014002; 2 | package MyProj::DB::Schema { 3 | use DBIx::Schema::DSL; 4 | use Aniki::Schema::Relationship::Declare; 5 | 6 | database 'SQLite'; 7 | 8 | create_table 'author' => columns { 9 | integer 'id', primary_key, auto_increment, extra => { auto_increment_type => 'monotonic' }; 10 | varchar 'name', unique; 11 | relay_by 'module', has_many => 1; 12 | }; 13 | 14 | create_table 'module' => columns { 15 | integer 'id', primary_key, auto_increment, extra => { auto_increment_type => 'monotonic' }; 16 | varchar 'name'; 17 | integer 'author_id'; 18 | 19 | add_index 'author_id_idx' => ['author_id']; 20 | 21 | relay_to 'author'; 22 | }; 23 | }; 24 | 25 | 1; 26 | -------------------------------------------------------------------------------- /t/13_new_collection_from_arrayref.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | 7 | use File::Spec; 8 | use lib File::Spec->catfile('t', 'lib'); 9 | use t::Util; 10 | 11 | run_on_database { 12 | subtest 'non empty' => sub { 13 | my $authors = db->new_collection_from_arrayref(author => [{ name => 'KARUPA' }, { name => 'PAPIX' }]); 14 | isa_ok $authors, 'Aniki::Result::Collection'; 15 | is $authors->count, 2; 16 | isa_ok $authors->first, 't::DB::Row::Author'; 17 | is $authors->first->name, 'KARUPA'; 18 | }; 19 | 20 | subtest 'empty' => sub { 21 | my $authors = db->new_collection_from_arrayref(author => []); 22 | isa_ok $authors, 'Aniki::Result::Collection'; 23 | is $authors->count, 0; 24 | }; 25 | }; 26 | 27 | done_testing(); 28 | -------------------------------------------------------------------------------- /author/lib/SampleAniki/DB/Schema.pm: -------------------------------------------------------------------------------- 1 | use 5.014002; 2 | package SampleAniki::DB::Schema { 3 | use DBIx::Schema::DSL; 4 | use Aniki::Schema::Relationship::Declare; 5 | 6 | database 'SQLite'; 7 | 8 | create_table 'author' => columns { 9 | integer 'id', primary_key, auto_increment, extra => { auto_increment_type => 'monotonic' }; 10 | varchar 'name', unique; 11 | varchar 'message', default => 'hello'; 12 | relay_by 'module', has_many => 1; 13 | }; 14 | 15 | create_table 'module' => columns { 16 | integer 'id', primary_key, auto_increment, extra => { auto_increment_type => 'monotonic' }; 17 | varchar 'name'; 18 | integer 'author_id'; 19 | 20 | add_index 'author_id_idx' => ['author_id']; 21 | 22 | relay_to 'author'; 23 | }; 24 | }; 25 | 26 | 1; 27 | -------------------------------------------------------------------------------- /t/10_delete.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | 7 | use File::Spec; 8 | use lib File::Spec->catfile('t', 'lib'); 9 | use t::Util; 10 | 11 | run_on_database { 12 | db->insert(author => { name => 'MOZNION' }); 13 | db->insert(author => { name => 'MOZNION2' }); 14 | 15 | is db->select(author => {})->count, 2; 16 | 17 | db->delete(author => { name => 'MOZNION' }); 18 | 19 | my $rows = db->select(author => {}); 20 | is $rows->count, 1; 21 | 22 | my $row = $rows->first; 23 | is $row->name, 'MOZNION2'; 24 | 25 | db->delete($row); 26 | 27 | is db->select(author => {})->count, 0; 28 | 29 | my ($line, $file); 30 | eval { db->delete(author => 'id = 1') }; ($line, $file) = (__LINE__, __FILE__); 31 | like $@, qr/^\Q(Aniki#delete) `where` condition must be a reference at $file line $line/, 'croak with no set parameters'; 32 | }; 33 | 34 | done_testing(); 35 | -------------------------------------------------------------------------------- /author/lib/SampleTeng/DB/Schema.pm: -------------------------------------------------------------------------------- 1 | package SampleTeng::DB::Schema; 2 | use strict; 3 | use warnings; 4 | use DBI qw/:sql_types/; 5 | use Teng::Schema::Declare; 6 | 7 | table { 8 | name 'author'; 9 | pk qw/id/; 10 | columns 11 | { name => 'id', type => SQL_INTEGER }, # INTEGER 12 | { name => 'name', type => SQL_VARCHAR }, # VARCHAR 13 | { name => 'message', type => SQL_VARCHAR }, # VARCHAR 14 | ; 15 | 16 | inflate name => sub { 17 | my $name = shift; 18 | return uc $name; 19 | }; 20 | 21 | deflate name => sub { 22 | my $name = shift; 23 | return lc $name; 24 | }; 25 | }; 26 | 27 | table { 28 | name 'module'; 29 | pk qw/id/; 30 | columns 31 | { name => 'id', type => SQL_INTEGER }, # INTEGER 32 | { name => 'name', type => SQL_VARCHAR }, # VARCHAR 33 | { name => 'author_id', type => SQL_INTEGER }, # INTEGER 34 | ; 35 | }; 36 | 37 | 1; 38 | -------------------------------------------------------------------------------- /eg/lib/MyProj/DB/Filter.pm: -------------------------------------------------------------------------------- 1 | package MyProj::DB::Filter { 2 | use Aniki::Filter::Declare; 3 | use Scalar::Util qw/blessed/; 4 | use Time::Moment; 5 | 6 | # define inflate/deflate filters in table context. 7 | table author => sub { 8 | inflate name => sub { 9 | my $name = shift; 10 | return uc $name; 11 | }; 12 | 13 | deflate name => sub { 14 | my $name = shift; 15 | return lc $name; 16 | }; 17 | }; 18 | 19 | inflate qr/_at$/ => sub { 20 | my $datetime = shift; 21 | $datetime =~ tr/ /T/; 22 | $datetime .= 'Z'; 23 | return Time::Moment->from_string($datetime); 24 | }; 25 | 26 | deflate qr/_at$/ => sub { 27 | my $datetime = shift; 28 | return $datetime->at_utc->strftime('%F %T') if blessed $datetime and $datetime->isa('Time::Moment'); 29 | return $datetime; 30 | }; 31 | }; 32 | 33 | 1; 34 | __END__ 35 | -------------------------------------------------------------------------------- /.circleci/config.yml: -------------------------------------------------------------------------------- 1 | version: 2 2 | jobs: 3 | build: 4 | docker: 5 | - image: karupanerura/perl-rdbms:latest 6 | environments: 7 | AUTHOR_TESTING: 1 8 | steps: 9 | - checkout 10 | - run: echo 'export PATH="$PWD/local/bin:$PATH"' >> $BASH_ENV 11 | - run: perl -Mlib=$PWD/local/lib/perl5 -E 'say "export PERL5LIB=", join ":", grep /^\E$ENV{PWD}/, @INC' >> $BASH_ENV 12 | - restore_cache: 13 | keys: 14 | - perl-modules-{{ checksum "cpanfile" }} 15 | - run: cpanm -Llocal --quiet --notest --skip-satisfied Devel::Cover Devel::Cover::Report::Codecov 16 | - run: cpanm -Llocal --quiet --notest --skip-satisfied --installdeps --with-recommend . 17 | - save_cache: 18 | key: perl-modules-{{ checksum "cpanfile" }} 19 | paths: 20 | - "local" 21 | - run: perl Build.PL 22 | - run: ./Build build 23 | - run: cover -test +ignore '^local/lib/perl5' 24 | - run: cover -report codecov 25 | -------------------------------------------------------------------------------- /t/07_insert_on_duplicate.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | 7 | use File::Spec; 8 | use lib File::Spec->catfile('t', 'lib'); 9 | use t::Util; 10 | 11 | use SQL::QueryMaker qw/sql_raw/; 12 | 13 | run_on_each_databases [qw/MySQL/] => sub { 14 | db->insert_on_duplicate(author => { 15 | name => 'PAPIX', 16 | message => 'hoge', 17 | }, { 18 | message => sql_raw('VALUES(message)'), 19 | }); 20 | is db->select(author => {}, {})->count, 1, 'created.'; 21 | is db->select(author => { name => 'PAPIX' }, { limit => 1 })->first->message, 'hoge'; 22 | 23 | db->insert_on_duplicate(author => { 24 | name => 'PAPIX', 25 | message => 'fuga', 26 | }, { 27 | message => sql_raw('VALUES(message)'), 28 | }); 29 | is db->select(author => {}, {})->count, 1, 'updated.'; 30 | is db->select(author => { name => 'PAPIX' }, { limit => 1 })->first->message, 'fuga'; 31 | }; 32 | 33 | done_testing(); 34 | -------------------------------------------------------------------------------- /lib/Aniki/Schema/Table/PrimaryKey.pm: -------------------------------------------------------------------------------- 1 | package Aniki::Schema::Table::PrimaryKey; 2 | use 5.014002; 3 | 4 | use namespace::autoclean; 5 | use Mouse v2.4.5; 6 | use Aniki::Schema::Table::Field; 7 | use Carp qw/croak/; 8 | 9 | has _primary_key => ( 10 | is => 'ro', 11 | required => 1, 12 | ); 13 | 14 | has _fields => ( 15 | is => 'ro', 16 | default => sub { 17 | my $self = shift; 18 | return [ 19 | map { Aniki::Schema::Table::Field->new($_) } $self->_primary_key->fields 20 | ]; 21 | }, 22 | ); 23 | 24 | sub BUILDARGS { 25 | my ($class, $primary_key) = @_; 26 | return $class->SUPER::BUILDARGS(_primary_key => $primary_key); 27 | } 28 | 29 | sub fields { @{ shift->_fields } } 30 | 31 | our $AUTOLOAD; 32 | sub AUTOLOAD { 33 | my $self = shift; 34 | my $method = $AUTOLOAD =~ s/^.*://r; 35 | if ($self->_primary_key->can($method)) { 36 | return $self->_primary_key->$method(@_); 37 | } 38 | 39 | my $class = ref $self; 40 | croak qq{Can't locate object method "$method" via package "$class"}; 41 | } 42 | 43 | __PACKAGE__->meta->make_immutable; 44 | __END__ 45 | -------------------------------------------------------------------------------- /lib/Aniki/Row/Joined.pm: -------------------------------------------------------------------------------- 1 | package Aniki::Row::Joined; 2 | use 5.014002; 3 | 4 | use strict; 5 | use warnings; 6 | 7 | use Carp qw/croak/; 8 | 9 | sub new { 10 | my ($class, @rows) = @_; 11 | my %rows = map { $_->table_name => $_ } @rows; 12 | return bless \%rows => $class; 13 | } 14 | 15 | sub can { 16 | my ($invocant, $method) = @_; 17 | my $code = $invocant->SUPER::can($method); 18 | return $code if defined $code; 19 | 20 | if (ref $invocant) { 21 | my $self = $invocant; 22 | my $table_name = $method; 23 | return sub { shift->{$table_name} } if exists $self->{$table_name}; 24 | } 25 | 26 | return undef; ## no critic 27 | } 28 | 29 | our $AUTOLOAD; 30 | sub AUTOLOAD { 31 | my $invocant = shift; 32 | my $table_name = $AUTOLOAD =~ s/^.+://r; 33 | 34 | if (ref $invocant) { 35 | my $self = $invocant; 36 | return $self->{$table_name} if exists $self->{$table_name}; 37 | } 38 | 39 | my $msg = sprintf q{Can't locate object method "%s" via package "%s"}, $table_name, ref $invocant || $invocant; 40 | croak $msg; 41 | } 42 | 43 | sub DESTROY {} # no autoload 44 | 45 | 1; 46 | __END__ 47 | -------------------------------------------------------------------------------- /t/08_select.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | 7 | use File::Spec; 8 | use lib File::Spec->catfile('t', 'lib'); 9 | use t::Util; 10 | 11 | run_on_database { 12 | db->insert(author => { name => 'MOZNION' }); 13 | 14 | my $rows = db->select(author => {}); 15 | isa_ok $rows, 'Aniki::Result::Collection'; 16 | is $rows->count, 1; 17 | isa_ok $rows->first, 'Aniki::Row'; 18 | 19 | $rows = db->select(author => { 20 | name => 'OBAKE' 21 | }); 22 | isa_ok $rows, 'Aniki::Result::Collection'; 23 | is $rows->count, 0; 24 | 25 | $rows = db->select(author => {}, { suppress_row_objects => 1 }); 26 | isa_ok $rows, 'Aniki::Result::Collection'; 27 | is $rows->count, 1; 28 | isa_ok $rows->first, 'HASH'; 29 | 30 | $rows = db->select(author => {}, { suppress_result_objects => 1 }); 31 | isa_ok $rows, 'ARRAY'; 32 | is @$rows, 1; 33 | isa_ok $rows->[0], 'Aniki::Row'; 34 | 35 | $rows = db->select(author => {}, { suppress_result_objects => 1, suppress_row_objects => 1 }); 36 | isa_ok $rows, 'ARRAY'; 37 | is @$rows, 1; 38 | isa_ok $rows->[0], 'HASH'; 39 | }; 40 | 41 | done_testing(); 42 | -------------------------------------------------------------------------------- /t/05_insert_and_emulate_row.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | 7 | use File::Spec; 8 | use lib File::Spec->catfile('t', 'lib'); 9 | use t::Util; 10 | 11 | run_on_database { 12 | my $row = db->insert_and_emulate_row(author => { name => 'MOZNION' }); 13 | ok defined $row, 'row is defined.'; 14 | ok $row->is_new, 'new row.'; 15 | 16 | is_deeply $row->get_columns, { 17 | id => $row->id, 18 | name => 'MOZNION', 19 | message => 'hello', 20 | inflate_message => 'hello', 21 | deflate_message => 'hello', 22 | }, 'Data is valid.'; 23 | 24 | subtest 'inflate deflate' => sub { 25 | 26 | is $row->inflate_message, 'inflate hello'; 27 | is $row->deflate_message, 'hello'; 28 | 29 | my $new_row = db->insert_and_emulate_row(author => +{ name => 'KARUPA', inflate_message => 'hello Aniki', deflate_message => 'hello Aniki' }); 30 | isa_ok $new_row, 'Aniki::Row'; 31 | is $new_row->name, 'KARUPA'; 32 | is $new_row->inflate_message, 'inflate hello Aniki'; 33 | is $new_row->deflate_message, 'deflate hello Aniki'; 34 | }; 35 | }; 36 | 37 | done_testing(); 38 | -------------------------------------------------------------------------------- /author/lib/SampleDbic/Schema/Module.pm: -------------------------------------------------------------------------------- 1 | package SampleDbic::Schema::Module; 2 | use strict; 3 | use warnings; 4 | use utf8; 5 | 6 | use parent qw/DBIx::Class::Core/; 7 | 8 | __PACKAGE__->table('module'); 9 | __PACKAGE__->add_columns( 10 | 'id' => { 11 | 'is_auto_increment' => 1, 12 | 'data_type' => 'INTEGER', 13 | 'size' => '0', 14 | 'name' => 'id', 15 | 'is_foreign_key' => 0, 16 | 'default_value' => undef, 17 | 'is_nullable' => 0 18 | }, 19 | 'name' => { 20 | 'is_foreign_key' => 0, 21 | 'name' => 'name', 22 | 'is_nullable' => 1, 23 | 'default_value' => undef, 24 | 'data_type' => 'VARCHAR', 25 | 'is_auto_increment' => 0, 26 | 'size' => '255' 27 | }, 28 | 'author_id' => { 29 | 'name' => 'author_id', 30 | 'is_foreign_key' => 0, 31 | 'default_value' => undef, 32 | 'is_nullable' => 1, 33 | 'is_auto_increment' => 0, 34 | 'data_type' => 'INTEGER', 35 | 'size' => '0' 36 | }, 37 | ); 38 | __PACKAGE__->set_primary_key('id'); 39 | 40 | __PACKAGE__->belongs_to('author' => 'SampleDbic::Schema::Author', { 'foreign.id' => 'self.author_id' }); 41 | 42 | 1; 43 | -------------------------------------------------------------------------------- /eg/synopsis.pl: -------------------------------------------------------------------------------- 1 | use 5.014002; 2 | use File::Basename qw/dirname/; 3 | use File::Spec; 4 | use lib File::Spec->catdir(dirname(__FILE__), 'lib'); 5 | use MyProj::DB; 6 | use MyProj::DB::Schema; 7 | #use DBIx::QueryLog; 8 | 9 | my $db = MyProj::DB->new(connect_info => ["dbi:SQLite:dbname=:memory:", "", ""]); 10 | $db->execute($_) for split /;/, MyProj::DB::Schema->output; 11 | 12 | my $author_id = $db->insert_and_fetch_id(author => { name => 'songmu' }); 13 | 14 | $db->insert(module => { 15 | name => 'DBIx::Schema::DSL', 16 | author_id => $author_id, 17 | }); 18 | $db->insert(module => { 19 | name => 'Riji', 20 | author_id => $author_id, 21 | }); 22 | 23 | my $module = $db->select(module => { 24 | name => 'Riji', 25 | }, { 26 | limit => 1, 27 | })->first; 28 | say '$module->name: ', $module->name; ## Riji 29 | say '$module->author->name: ', $module->author->name; ## SONGMU 30 | 31 | my $author = $db->select(author => { 32 | name => 'songmu', 33 | }, { 34 | limit => 1, 35 | prefetch => [qw/modules/], 36 | })->first; 37 | 38 | say '$author->name: ', $author->name; ## SONGMU 39 | say 'modules[]->name: ', $_->name for $author->modules; ## DBIx::Schema::DSL, Riji 40 | -------------------------------------------------------------------------------- /t/06_insert_multi.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | 7 | use File::Spec; 8 | use lib File::Spec->catfile('t', 'lib'); 9 | use t::Util; 10 | 11 | use SQL::QueryMaker qw/sql_raw/; 12 | 13 | run_on_database { 14 | is query_count { 15 | db->insert_multi(author => []); 16 | }, 0, 'nothing to do if empty values'; 17 | 18 | db->insert_multi(author => [ 19 | { name => 'MOZNION', message => 'hoge' }, 20 | { name => 'PAPIX', message => 'fuga' }, 21 | ]); 22 | is db->select(author => {}, {})->count, 2, 'created.'; 23 | is db->select(author => { name => 'PAPIX' }, { limit => 1 })->first->message, 'fuga'; 24 | 25 | if (db->query_builder->driver eq 'mysql') { 26 | db->insert_multi(author => [ 27 | { name => 'PAPIX', message => 'hoge' }, 28 | { name => 'KARUPA', message => 'fuga' }, 29 | ], { 30 | update => { 31 | message => sql_raw('VALUES(message)'), 32 | } 33 | }); 34 | is db->select(author => {}, {})->count, 3, 'created.'; 35 | is db->select(author => { name => 'PAPIX' }, { limit => 1 })->first->message, 'hoge'; 36 | }; 37 | }; 38 | 39 | done_testing(); 40 | -------------------------------------------------------------------------------- /lib/Aniki/Schema/Table/Field.pm: -------------------------------------------------------------------------------- 1 | package Aniki::Schema::Table::Field; 2 | use 5.014002; 3 | 4 | use namespace::autoclean; 5 | use Mouse v2.4.5; 6 | use Carp qw/croak/; 7 | 8 | has _field => ( 9 | is => 'ro', 10 | required => 1, 11 | ); 12 | 13 | has name => ( 14 | is => 'ro', 15 | default => sub { shift->_field->name }, 16 | ); 17 | 18 | has is_auto_increment => ( 19 | is => 'ro', 20 | default => sub { shift->_field->is_auto_increment }, 21 | ); 22 | 23 | has default_value => ( 24 | is => 'ro', 25 | default => sub { shift->_field->default_value }, 26 | ); 27 | 28 | has sql_data_type => ( 29 | is => 'ro', 30 | default => sub { shift->_field->sql_data_type }, 31 | ); 32 | 33 | sub BUILDARGS { 34 | my ($class, $field) = @_; 35 | return $class->SUPER::BUILDARGS(_field => $field); 36 | } 37 | 38 | our $AUTOLOAD; 39 | sub AUTOLOAD { 40 | my $self = shift; 41 | my $method = $AUTOLOAD =~ s/^.*://r; 42 | if ($self->_field->can($method)) { 43 | return $self->_field->$method(@_); 44 | } 45 | 46 | my $class = ref $self; 47 | croak qq{Can't locate object method "$method" via package "$class"}; 48 | } 49 | 50 | __PACKAGE__->meta->make_immutable; 51 | __END__ 52 | -------------------------------------------------------------------------------- /lib/Aniki/Plugin/WeightedRoundRobin.pm: -------------------------------------------------------------------------------- 1 | package Aniki::Plugin::WeightedRoundRobin; 2 | use 5.014002; 3 | 4 | use namespace::autoclean; 5 | use Mouse::Role; 6 | 7 | use Aniki::Handler::WeightedRoundRobin; 8 | 9 | sub handler_class { 'Aniki::Handler::WeightedRoundRobin' } 10 | 11 | 1; 12 | __END__ 13 | 14 | =pod 15 | 16 | =encoding utf-8 17 | 18 | =head1 NAME 19 | 20 | Aniki::Plugin::WeightedRoundRobin - Connect to database in a Weighted RoundRobin manner 21 | 22 | =head1 SYNOPSIS 23 | 24 | package MyDB; 25 | use Mouse v2.4.5; 26 | extends qw/Aniki/; 27 | with qw/Aniki::Plugin::WeightedRoundRobin/; 28 | 29 | my $db = MyDB->new(connect_info => [ 30 | { 31 | value => [...], # Auguments for DBI's connect method. 32 | weight => 10, 33 | }, 34 | { 35 | value => [...], # Auguments for DBI's connect method. 36 | weight => 10, 37 | }, 38 | ]); 39 | 40 | =head1 SEE ALSO 41 | 42 | L 43 | L 44 | 45 | =head1 LICENSE 46 | 47 | Copyright (C) karupanerura. 48 | 49 | This library is free software; you can redistribute it and/or modify 50 | it under the same terms as Perl itself. 51 | 52 | =head1 AUTHOR 53 | 54 | karupanerura Ekarupa@cpan.orgE 55 | 56 | =cut 57 | -------------------------------------------------------------------------------- /t/lib/t/DB/Schema/Common.pm: -------------------------------------------------------------------------------- 1 | package t::DB::Schema::Common; 2 | use strict; 3 | use warnings; 4 | 5 | use DBIx::Schema::DSL; 6 | use Aniki::Schema::Relationship::Declare; 7 | 8 | create_table 'author' => columns { 9 | integer 'id', primary_key, auto_increment, extra => { auto_increment_type => 'monotonic' }; 10 | varchar 'name'; 11 | varchar 'message', default => 'hello'; 12 | varchar 'inflate_message', default => 'hello'; 13 | varchar 'deflate_message', default => 'hello'; 14 | 15 | add_unique_index 'name_uniq_in_author' => ['name']; 16 | 17 | relay_by 'module', has_many => 1; 18 | }; 19 | 20 | create_table 'module' => columns { 21 | integer 'id', primary_key, auto_increment, extra => { auto_increment_type => 'monotonic' }; 22 | varchar 'name'; 23 | integer 'author_id'; 24 | 25 | add_index 'author_id_idx' => ['author_id']; 26 | add_unique_index 'name_uniq_in_module' => ['name']; 27 | 28 | relay_to 'author'; 29 | relay_by 'version', has_many => 1; 30 | }; 31 | 32 | create_table 'version' => columns { 33 | integer 'id', primary_key, auto_increment, extra => { auto_increment_type => 'monotonic' }; 34 | varchar 'name'; 35 | integer 'module_id'; 36 | 37 | add_unique_index 'module_name_uniq_in_version' => ['module_id', 'name']; 38 | 39 | relay_to 'module'; 40 | }; 41 | 42 | 1; 43 | __END__ 44 | -------------------------------------------------------------------------------- /author/lib/SampleDbic/Schema/Author.pm: -------------------------------------------------------------------------------- 1 | package SampleDbic::Schema::Author; 2 | use strict; 3 | use warnings; 4 | use utf8; 5 | 6 | use parent qw/DBIx::Class::Core/; 7 | 8 | __PACKAGE__->table('author'); 9 | __PACKAGE__->add_columns( 10 | 'id' => { 11 | 'is_auto_increment' => 1, 12 | 'is_nullable' => 0, 13 | 'data_type' => 'INTEGER', 14 | 'default_value' => undef, 15 | 'is_foreign_key' => 0, 16 | 'size' => '0', 17 | 'name' => 'id' 18 | }, 19 | 'name' => { 20 | 'default_value' => undef, 21 | 'is_foreign_key' => 0, 22 | 'size' => '255', 23 | 'name' => 'name', 24 | 'is_auto_increment' => 0, 25 | 'is_nullable' => 1, 26 | 'data_type' => 'VARCHAR' 27 | }, 28 | 'message' => { 29 | 'is_auto_increment' => 0, 30 | 'data_type' => 'VARCHAR', 31 | 'is_nullable' => 1, 32 | 'default_value' => 'hello', 33 | 'is_foreign_key' => 0, 34 | 'name' => 'message', 35 | 'size' => '255' 36 | }, 37 | ); 38 | __PACKAGE__->set_primary_key('id'); 39 | 40 | __PACKAGE__->has_many('modules' => 'SampleDbic::Schema::Module', { 'foreign.author_id' => 'self.id' }); 41 | 42 | __PACKAGE__->inflate_column(name => { 43 | inflate => sub { 44 | my $name = shift; 45 | return uc $name; 46 | }, 47 | deflate => sub { 48 | my $name = shift; 49 | return lc $name; 50 | }, 51 | }); 52 | 53 | 1; 54 | -------------------------------------------------------------------------------- /lib/Aniki/QueryBuilder/Canonical.pm: -------------------------------------------------------------------------------- 1 | package Aniki::QueryBuilder::Canonical; 2 | use 5.014002; 3 | 4 | use strict; 5 | use warnings; 6 | 7 | use parent qw/Aniki::QueryBuilder/; 8 | 9 | sub insert { 10 | my ($self, $table, $values, $opt) = @_; 11 | if (ref $values eq 'HASH') { 12 | $values = [ 13 | map { $_ => $values->{$_} } sort keys %$values 14 | ]; 15 | } 16 | return $self->SUPER::insert($table, $values, $opt); 17 | } 18 | 19 | sub update { 20 | my ($self, $table, $args, $where) = @_; 21 | if (ref $args eq 'HASH') { 22 | $args = [ 23 | map { $_ => $args->{$_} } sort keys %$args 24 | ]; 25 | } 26 | if (ref $where eq 'HASH') { 27 | $where = [ 28 | map { $_ => $where->{$_} } sort keys %$where 29 | ]; 30 | } 31 | return $self->SUPER::update($table, $args, $where); 32 | } 33 | 34 | sub delete :method { 35 | my ($self, $table, $where, $opt) = @_; 36 | if (ref $where eq 'HASH') { 37 | $where = [ 38 | map { $_ => $where->{$_} } sort keys %$where 39 | ]; 40 | } 41 | return $self->SUPER::delete($table, $where, $opt); 42 | } 43 | 44 | sub select_query { 45 | my ($self, $table, $fields, $where, $opt) = @_; 46 | if (ref $where eq 'HASH') { 47 | $where = [ 48 | map { $_ => $where->{$_} } sort keys %$where 49 | ]; 50 | } 51 | return $self->SUPER::select_query($table, $fields, $where, $opt); 52 | } 53 | 54 | 1; 55 | __END__ 56 | -------------------------------------------------------------------------------- /t/09_update.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | 7 | use File::Spec; 8 | use lib File::Spec->catfile('t', 'lib'); 9 | use t::Util; 10 | 11 | run_on_database { 12 | db->insert(author => { name => 'MOZNION' }); 13 | db->update(author => { name => 'MOZNION2' }, { name => 'MOZNION' }); 14 | 15 | my $rows = db->select(author => {}); 16 | isa_ok $rows, 'Aniki::Result::Collection'; 17 | is $rows->count, 1; 18 | is $rows->first->name, 'MOZNION2', 'updated'; 19 | 20 | my $row = $rows->first; 21 | my $cnt = db->update($row => { name => 'MOZNION' }); 22 | is $row->name, 'MOZNION2', 'old value'; 23 | is $cnt, 1, 'a row is changed'; 24 | 25 | my $new_row = $row->refetch; 26 | isnt $new_row, $row; 27 | is $new_row->name, 'MOZNION', 'new value'; 28 | 29 | my ($line, $file); 30 | eval { db->update($row) }; ($line, $file) = (__LINE__, __FILE__); 31 | like $@, qr/^\Q(Aniki#update) `set` is required for update ("SET" parameter) at $file line $line/, 'croak with no set parameters'; 32 | 33 | eval { db->update($row => {}) }; ($line, $file) = (__LINE__, __FILE__); 34 | like $@, qr/^\Q(Aniki#update) `set` is required for update ("SET" parameter) at $file line $line/, 'croak with empty set parameters'; 35 | 36 | eval { db->update(author => { name => 'MOZNION3' }, 'id = 1') }; ($line, $file) = (__LINE__, __FILE__); 37 | like $@, qr/^\Q(Aniki#update) `where` condition must be a reference at $file line $line/, 'croak with invalid where parameters'; 38 | }; 39 | 40 | done_testing(); 41 | -------------------------------------------------------------------------------- /lib/Aniki/Plugin/Count.pm: -------------------------------------------------------------------------------- 1 | package Aniki::Plugin::Count; 2 | use 5.014002; 3 | 4 | use namespace::autoclean; 5 | use Mouse::Role; 6 | 7 | use Carp qw/croak/; 8 | 9 | requires qw/query_builder dbh/; 10 | 11 | sub count { 12 | my ($self, $table, $column, $where, $opt) = @_; 13 | $where //= {}; 14 | $column //= '*'; 15 | 16 | croak '(Aniki::Plugin::Count#count) `where` condition must be a reference.' unless ref $where; 17 | 18 | if (ref $column) { 19 | croak 'Do not pass HashRef/ArrayRef to second argument. Usage: $db->count($table[, $column[, $where[, $opt]]])'; 20 | } 21 | 22 | my ($sql, @binds) = $self->query_builder->select($table, [\"COUNT($column)"], $where, $opt); 23 | my ($count) = $self->dbh->selectrow_array($sql, undef, @binds); 24 | return $count; 25 | } 26 | 27 | 1; 28 | __END__ 29 | 30 | =pod 31 | 32 | =encoding utf-8 33 | 34 | =head1 NAME 35 | 36 | Aniki::Plugin::Count - Count rows in database. 37 | 38 | =head1 SYNOPSIS 39 | 40 | package MyDB; 41 | use Mouse v2.4.5; 42 | extends qw/Aniki/; 43 | with qw/Aniki::Plugin::Count/; 44 | 45 | package main; 46 | my $db = MyDB->new(...); 47 | $db->count('user'); # => The number of rows in 'user' table. 48 | $db->count('user', '*', {type => 2}); # => SELECT COUNT(*) FROM user WHERE type=2 49 | 50 | =head1 SEE ALSO 51 | 52 | L 53 | 54 | =head1 LICENSE 55 | 56 | Copyright (C) karupanerura. 57 | 58 | This library is free software; you can redistribute it and/or modify 59 | it under the same terms as Perl itself. 60 | 61 | =head1 AUTHOR 62 | 63 | karupanerura Ekarupa@cpan.orgE 64 | 65 | =cut 66 | -------------------------------------------------------------------------------- /t/plugin/range_condition_maker/make_range_condition.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | 7 | use File::Spec; 8 | use lib File::Spec->catfile('t', 'lib'); 9 | use Mouse::Util; 10 | use t::Util; 11 | 12 | run_on_database { 13 | Mouse::Util::apply_all_roles(db, 'Aniki::Plugin::RangeConditionMaker'); 14 | 15 | db->insert_multi(author => [map { 16 | +{ name => $_ } 17 | } qw/MOZNION KARUPA PAPIX MACKEE/]); 18 | 19 | my ($where, $result); 20 | 21 | for my $type (qw/lower gt/) { 22 | $where = db->make_range_condition({ $type => { id => 2 } }); 23 | $result = db->select('author', $where); 24 | is scalar (map { $_->{id} > 2 } @{ $result->row_datas }), 2; 25 | } 26 | 27 | for my $type (qw/upper lt/) { 28 | $where = db->make_range_condition({ $type => { id => 4 } }); 29 | $result = db->select('author', $where); 30 | is scalar (map { $_->{id} < 4 } @{ $result->row_datas }), 3; 31 | } 32 | 33 | $where = db->make_range_condition({ ge => { id => 2 } }); 34 | $result = db->select('author', $where); 35 | is scalar (map { $_->{id} >= 2 } @{ $result->row_datas }), 3; 36 | 37 | $where = db->make_range_condition({ le => { id => 4 } }); 38 | $result = db->select('author', $where); 39 | is scalar (map { $_->{id} <= 4 } @{ $result->row_datas }), 4; 40 | 41 | $where = db->make_range_condition({ lower => { id => 1 }, upper => { id => 3 } }); 42 | $result = db->select('author', $where); 43 | is scalar @{$result->row_datas}, 1; 44 | is $result->row_datas->[0]->{id}, 2; 45 | }; 46 | 47 | done_testing(); 48 | -------------------------------------------------------------------------------- /t/plugin/pager_injector/inject_pager_to_result.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | 7 | use File::Spec; 8 | use lib File::Spec->catfile('t', 'lib'); 9 | use Mouse::Util; 10 | use Aniki::Plugin::PagerInjector; 11 | use t::Util; 12 | 13 | run_on_database { 14 | Mouse::Util::apply_all_roles(db, 'Aniki::Plugin::PagerInjector'); 15 | 16 | db->insert_multi(author => [map { 17 | +{ name => $_ } 18 | } qw/MOZNION KARUPA PAPIX/]); 19 | 20 | my $rows = db->select(author => {}, { limit => 3, offset => 0 }); 21 | isa_ok $rows, 'Aniki::Result::Collection'; 22 | ok !$rows->meta->does_role('Aniki::Result::Role::Pager'); 23 | is $rows->count, 3; 24 | 25 | $rows = db->inject_pager_to_result($rows => { page => 1, rows => 2 }); 26 | isa_ok $rows, 'Aniki::Result::Collection'; 27 | ok $rows->meta->does_role('Aniki::Result::Role::Pager'); 28 | is $rows->count, 2; 29 | isa_ok $rows->pager, 'Data::Page::NoTotalEntries'; 30 | is $rows->pager->current_page, 1; 31 | ok $rows->pager->has_next; 32 | 33 | $rows = db->select(author => {}, { limit => 3, offset => 2 }); 34 | isa_ok $rows, 'Aniki::Result::Collection'; 35 | ok !$rows->meta->does_role('Aniki::Result::Role::Pager'); 36 | is $rows->count, 1; 37 | 38 | $rows = db->inject_pager_to_result($rows => { page => 2, rows => 2 }); 39 | isa_ok $rows, 'Aniki::Result::Collection'; 40 | ok $rows->meta->does_role('Aniki::Result::Role::Pager'); 41 | is $rows->count, 1; 42 | isa_ok $rows->pager, 'Data::Page::NoTotalEntries'; 43 | is $rows->pager->current_page, 2; 44 | ok !$rows->pager->has_next; 45 | }; 46 | 47 | done_testing(); 48 | -------------------------------------------------------------------------------- /t/plugin/sql_pager/select_named_with_pager.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | 7 | use File::Spec; 8 | use lib File::Spec->catfile('t', 'lib'); 9 | use Mouse::Util; 10 | use Aniki::Plugin::SQLPager; 11 | use t::Util; 12 | 13 | run_on_database { 14 | Mouse::Util::apply_all_roles(db, 'Aniki::Plugin::SQLPager'); 15 | 16 | db->insert_multi(author => [map { 17 | +{ name => $_ } 18 | } qw/MOZNION KARUPA PAPIX/]); 19 | 20 | my $rows = db->select_named_with_pager('SELECT * FROM author ORDER BY id', {}, { rows => 2, page => 1 }); 21 | isa_ok $rows, 'Aniki::Result::Collection'; 22 | ok $rows->meta->does_role('Aniki::Result::Role::Pager'); 23 | is $rows->count, 2; 24 | 25 | isa_ok $rows->pager, 'Data::Page::NoTotalEntries'; 26 | is $rows->pager->current_page, 1; 27 | ok $rows->pager->has_next; 28 | 29 | $rows = db->select_named_with_pager('SELECT * FROM author ORDER BY id', {}, { rows => 2, page => 2 }); 30 | isa_ok $rows, 'Aniki::Result::Collection'; 31 | ok $rows->meta->does_role('Aniki::Result::Role::Pager'); 32 | is $rows->count, 1; 33 | 34 | isa_ok $rows->pager, 'Data::Page::NoTotalEntries'; 35 | is $rows->pager->current_page, 2; 36 | ok !$rows->pager->has_next; 37 | 38 | $rows = db->select_named_with_pager('SELECT * FROM author WHERE id > :id ORDER BY id', { id => 2 }, { rows => 2, page => 2, no_offset => 1 }); 39 | isa_ok $rows, 'Aniki::Result::Collection'; 40 | ok $rows->meta->does_role('Aniki::Result::Role::Pager'); 41 | is $rows->count, 1; 42 | is $rows->first->id, 3; 43 | 44 | isa_ok $rows->pager, 'Data::Page::NoTotalEntries'; 45 | is $rows->pager->current_page, 2; 46 | ok !$rows->pager->has_next; 47 | }; 48 | 49 | done_testing(); 50 | -------------------------------------------------------------------------------- /cpanfile: -------------------------------------------------------------------------------- 1 | requires 'B::Hooks::EndOfScope'; 2 | requires 'Class::Inspector'; 3 | requires 'DBI'; 4 | requires 'DBIx::Handler', '0.12'; 5 | requires 'DBIx::Schema::DSL'; 6 | requires 'Data::Page::NoTotalEntries'; 7 | requires 'Data::Section::Simple'; 8 | requires 'File::Path'; 9 | requires 'Getopt::Long'; 10 | requires 'Hash::Util::FieldHash'; 11 | requires 'Lingua::EN::Inflect'; 12 | requires 'List::MoreUtils'; 13 | requires 'List::UtilsBy'; 14 | requires 'Module::Load'; 15 | requires 'Mouse', 'v2.4.5'; 16 | requires 'Mouse::Role'; 17 | requires 'Mouse::Util::TypeConstraints'; 18 | requires 'SQL::Maker', '1.19'; 19 | requires 'SQL::Maker::SQLType'; 20 | requires 'SQL::NamedPlaceholder'; 21 | requires 'SQL::QueryMaker'; 22 | requires 'SQL::Translator::Schema::Constants'; 23 | requires 'Scalar::Util'; 24 | requires 'String::CamelCase'; 25 | requires 'Try::Tiny'; 26 | requires 'namespace::autoclean'; 27 | requires 'parent'; 28 | requires 'perl', '5.014002'; 29 | 30 | recommends 'SQL::Maker::Plugin::JoinSelect'; 31 | recommends 'Data::WeightedRoundRobin'; 32 | 33 | on configure => sub { 34 | requires 'Module::Build::Tiny', '0.035'; 35 | }; 36 | 37 | on test => sub { 38 | requires 'DBD::SQLite'; 39 | requires 'List::Util'; 40 | requires 'Mouse::Util'; 41 | requires 'Test::Builder'; 42 | requires 'Test::Builder::Module'; 43 | requires 'Test::More', '0.98'; 44 | requires 'Test::Requires'; 45 | requires 'feature'; 46 | recommends 'DBD::mysql'; 47 | recommends 'Test::mysqld'; 48 | recommends 'DBD::Pg'; 49 | recommends 'Test::PostgreSQL'; 50 | }; 51 | 52 | on develop => sub { 53 | requires 'DBIx::Class::Core'; 54 | requires 'DBIx::Class::Schema'; 55 | requires 'Teng'; 56 | requires 'Teng::Schema::Declare'; 57 | requires 'Time::Moment'; 58 | }; 59 | -------------------------------------------------------------------------------- /t/plugin/sql_pager/select_by_sql_with_pager.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | 7 | use File::Spec; 8 | use lib File::Spec->catfile('t', 'lib'); 9 | use Mouse::Util; 10 | use Aniki::Plugin::SQLPager; 11 | use t::Util; 12 | 13 | run_on_database { 14 | Mouse::Util::apply_all_roles(db, 'Aniki::Plugin::SQLPager'); 15 | 16 | db->insert_multi(author => [map { 17 | +{ name => $_ } 18 | } qw/MOZNION KARUPA PAPIX/]); 19 | 20 | my $rows = db->select_by_sql_with_pager('SELECT * FROM author ORDER BY id', [], { rows => 2, page => 1 }); 21 | isa_ok $rows, 'Aniki::Result::Collection'; 22 | ok $rows->meta->does_role('Aniki::Result::Role::Pager'); 23 | is $rows->count, 2; 24 | is $rows->first->id, 1; 25 | 26 | isa_ok $rows->pager, 'Data::Page::NoTotalEntries'; 27 | is $rows->pager->current_page, 1; 28 | ok $rows->pager->has_next; 29 | 30 | $rows = db->select_by_sql_with_pager('SELECT * FROM author ORDER BY id', [], { rows => 2, page => 2 }); 31 | isa_ok $rows, 'Aniki::Result::Collection'; 32 | ok $rows->meta->does_role('Aniki::Result::Role::Pager'); 33 | is $rows->count, 1; 34 | is $rows->first->id, 3; 35 | 36 | isa_ok $rows->pager, 'Data::Page::NoTotalEntries'; 37 | is $rows->pager->current_page, 2; 38 | ok !$rows->pager->has_next; 39 | 40 | $rows = db->select_by_sql_with_pager('SELECT * FROM author WHERE id > ? ORDER BY id', [2], { rows => 2, page => 2, no_offset => 1 }); 41 | isa_ok $rows, 'Aniki::Result::Collection'; 42 | ok $rows->meta->does_role('Aniki::Result::Role::Pager'); 43 | is $rows->count, 1; 44 | is $rows->first->id, 3; 45 | 46 | isa_ok $rows->pager, 'Data::Page::NoTotalEntries'; 47 | is $rows->pager->current_page, 2; 48 | ok !$rows->pager->has_next; 49 | }; 50 | 51 | done_testing(); 52 | -------------------------------------------------------------------------------- /t/lib/t/Util.pm: -------------------------------------------------------------------------------- 1 | package t::Util; 2 | use strict; 3 | use warnings; 4 | use feature qw/state/; 5 | 6 | use parent qw/Test::Builder::Module/; 7 | our @EXPORT = qw/db target_databases run_on_database run_on_each_databases run_on_all_databases query_count/; 8 | 9 | use t::DB; 10 | 11 | our $DB; 12 | sub db () { $DB } ## no critic 13 | 14 | sub target_databases { $ENV{AUTHOR_TESTING} ? t::DB->all_databases : qw/SQLite/ } 15 | 16 | sub run_on_database (&) {## no critic 17 | my $code = shift; 18 | 19 | my @databases = target_databases(); 20 | t::DB->run_on_each_databases(\@databases => sub { 21 | my $class = shift; 22 | local $DB = $class->new(); 23 | $code->(); 24 | }); 25 | } 26 | 27 | sub run_on_each_databases ($&) {## no critic 28 | my ($databases, $code) = @_; 29 | t::DB->run_on_each_databases($databases => sub { 30 | my $class = shift; 31 | local $DB = $class->new(); 32 | $code->(); 33 | }); 34 | } 35 | 36 | sub run_on_all_databases (&) {## no critic 37 | my $code = shift; 38 | t::DB->run_on_all_databases(sub { 39 | my $class = shift; 40 | local $DB = $class->new(); 41 | $code->(); 42 | }); 43 | } 44 | 45 | sub query_count (&) {## no critic 46 | my $code = shift; 47 | 48 | my $count = 0; 49 | no warnings qw/once redefine/; 50 | local *Aniki::execute = do { 51 | use warnings qw/once redefine/; 52 | my $super = \&Aniki::execute; 53 | sub { 54 | my $self = shift; 55 | my $sql = shift; 56 | __PACKAGE__->builder->diag($sql) if $ENV{AUTHOR_TESTING}; 57 | $count++; 58 | return $self->$super($sql, @_); 59 | }; 60 | }; 61 | use warnings qw/once redefine/; 62 | 63 | $code->(); 64 | 65 | return $count; 66 | } 67 | 68 | 1; 69 | __END__ 70 | -------------------------------------------------------------------------------- /t/filter/deflate_and_inflate.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | use Aniki::Filter; 7 | 8 | my @PATTERN = ( 9 | [hoge => { foo => 'foo_value' }], 10 | [fuga => { foo => 'foo_value' }], 11 | [hoge => { foo2 => 'foo2_value' }], 12 | [fuga => { foo2 => 'foo2_value' }], 13 | ); 14 | 15 | subtest 'global' => sub { 16 | my $filter = Aniki::Filter->new(); 17 | $filter->add_global_inflator(foo => sub { 18 | my $value = shift; 19 | return "global_inflate_$value"; 20 | }); 21 | $filter->add_global_deflator(foo => sub { 22 | my $value = shift; 23 | return "global_deflate_$value"; 24 | }); 25 | 26 | for my $pattern (@PATTERN) { 27 | my ($table, $row) = @$pattern; 28 | my ($column) = keys %$row; 29 | is $filter->deflate_row($table, $row)->{$column}, $column eq 'foo' ? 'global_deflate_foo_value' : $row->{$column}; 30 | is $filter->inflate_row($table, $row)->{$column}, $column eq 'foo' ? 'global_inflate_foo_value' : $row->{$column}; 31 | } 32 | }; 33 | 34 | subtest 'table' => sub { 35 | my $filter = Aniki::Filter->new(); 36 | $filter->add_table_inflator(hoge => foo => sub { 37 | my $value = shift; 38 | return "hoge_inflate_$value"; 39 | }); 40 | $filter->add_table_deflator(hoge => foo => sub { 41 | my $value = shift; 42 | return "hoge_deflate_$value"; 43 | }); 44 | for my $pattern (@PATTERN) { 45 | my ($table, $row) = @$pattern; 46 | my ($column) = keys %$row; 47 | is $filter->deflate_row($table, $row)->{$column}, $table eq 'hoge' && $column eq 'foo' ? 'hoge_deflate_foo_value' : $row->{$column}; 48 | is $filter->inflate_row($table, $row)->{$column}, $table eq 'hoge' && $column eq 'foo' ? 'hoge_inflate_foo_value' : $row->{$column}; 49 | } 50 | }; 51 | 52 | done_testing(); 53 | -------------------------------------------------------------------------------- /t/schema/relationship/basic.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | 7 | use Aniki::Schema; 8 | use Aniki::Schema::Relationship; 9 | 10 | package MyTest::Schema { 11 | use strict; 12 | use warnings; 13 | 14 | use DBIx::Schema::DSL; 15 | use Aniki::Schema::Relationship::Declare; 16 | 17 | database 'SQLite'; 18 | 19 | create_table 'author' => columns { 20 | integer 'id', primary_key, auto_increment; 21 | varchar 'name', unique; 22 | }; 23 | 24 | create_table 'module' => columns { 25 | integer 'id', primary_key, auto_increment; 26 | varchar 'name'; 27 | integer 'author_id'; 28 | 29 | add_index 'author_id_idx' => ['author_id']; 30 | }; 31 | }; 32 | 33 | my $schema = Aniki::Schema->new(schema_class => 'MyTest::Schema'); 34 | sub relationship { Aniki::Schema::Relationship->new(schema => $schema, @_) }; 35 | 36 | subtest 'has_many' => sub { 37 | ok !!relationship( 38 | src_table_name => 'author', 39 | src_columns => [qw/id/], 40 | dest_table_name => 'module', 41 | dest_columns => [qw/author_id/], 42 | )->has_many, 'author has many modules.'; 43 | ok !relationship( 44 | src_table_name => 'module', 45 | src_columns => [qw/author_id/], 46 | dest_table_name => 'author', 47 | dest_columns => [qw/id/], 48 | )->has_many, 'module has author.'; 49 | }; 50 | 51 | subtest 'name' => sub { 52 | is relationship( 53 | src_table_name => 'author', 54 | src_columns => [qw/id/], 55 | dest_table_name => 'module', 56 | dest_columns => [qw/author_id/], 57 | )->name, 'modules'; 58 | is relationship( 59 | src_table_name => 'module', 60 | src_columns => [qw/author_id/], 61 | dest_table_name => 'author', 62 | dest_columns => [qw/id/], 63 | )->name, 'author'; 64 | }; 65 | 66 | done_testing(); 67 | -------------------------------------------------------------------------------- /t/filter/deflate/basic.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | use Aniki::Filter; 7 | 8 | subtest 'global deflator only' => sub { 9 | my $filter = Aniki::Filter->new(); 10 | $filter->add_global_deflator(foo => sub { 11 | my $value = shift; 12 | return "global_$value"; 13 | }); 14 | is $filter->deflate_row(hoge => { foo => 'foo_value' })->{foo}, 'global_foo_value'; 15 | is $filter->deflate_row(fuga => { foo => 'foo_value' })->{foo}, 'global_foo_value'; 16 | is $filter->deflate_row(hoge => { foo2 => 'foo2_value' })->{foo2}, 'foo2_value'; 17 | is $filter->deflate_row(fuga => { foo2 => 'foo2_value' })->{foo2}, 'foo2_value'; 18 | }; 19 | 20 | subtest 'table deflator only' => sub { 21 | my $filter = Aniki::Filter->new(); 22 | $filter->add_table_deflator(hoge => foo => sub { 23 | my $value = shift; 24 | return "hoge_$value"; 25 | }); 26 | is $filter->deflate_row(hoge => { foo => 'foo_value' })->{foo}, 'hoge_foo_value'; 27 | is $filter->deflate_row(fuga => { foo => 'foo_value' })->{foo}, 'foo_value'; 28 | is $filter->deflate_row(hoge => { foo2 => 'foo2_value' })->{foo2}, 'foo2_value'; 29 | is $filter->deflate_row(fuga => { foo2 => 'foo2_value' })->{foo2}, 'foo2_value'; 30 | }; 31 | 32 | subtest 'table and global deflator' => sub { 33 | my $filter = Aniki::Filter->new(); 34 | $filter->add_global_deflator(foo => sub { 35 | my $value = shift; 36 | return "global_$value"; 37 | }); 38 | $filter->add_table_deflator(hoge => foo => sub { 39 | my $value = shift; 40 | return "hoge_$value"; 41 | }); 42 | is $filter->deflate_row(hoge => { foo => 'foo_value' })->{foo}, 'hoge_foo_value'; 43 | is $filter->deflate_row(fuga => { foo => 'foo_value' })->{foo}, 'global_foo_value'; 44 | is $filter->deflate_row(hoge => { foo2 => 'foo2_value' })->{foo2}, 'foo2_value'; 45 | is $filter->deflate_row(fuga => { foo2 => 'foo2_value' })->{foo2}, 'foo2_value'; 46 | }; 47 | 48 | done_testing(); 49 | -------------------------------------------------------------------------------- /t/filter/inflate/basic.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | use Aniki::Filter; 7 | 8 | subtest 'global inflator only' => sub { 9 | my $filter = Aniki::Filter->new(); 10 | $filter->add_global_inflator(foo => sub { 11 | my $value = shift; 12 | return "global_$value"; 13 | }); 14 | is $filter->inflate_row(hoge => { foo => 'foo_value' })->{foo}, 'global_foo_value'; 15 | is $filter->inflate_row(fuga => { foo => 'foo_value' })->{foo}, 'global_foo_value'; 16 | is $filter->inflate_row(hoge => { foo2 => 'foo2_value' })->{foo2}, 'foo2_value'; 17 | is $filter->inflate_row(fuga => { foo2 => 'foo2_value' })->{foo2}, 'foo2_value'; 18 | }; 19 | 20 | subtest 'table inflator only' => sub { 21 | my $filter = Aniki::Filter->new(); 22 | $filter->add_table_inflator(hoge => foo => sub { 23 | my $value = shift; 24 | return "hoge_$value"; 25 | }); 26 | is $filter->inflate_row(hoge => { foo => 'foo_value' })->{foo}, 'hoge_foo_value'; 27 | is $filter->inflate_row(fuga => { foo => 'foo_value' })->{foo}, 'foo_value'; 28 | is $filter->inflate_row(hoge => { foo2 => 'foo2_value' })->{foo2}, 'foo2_value'; 29 | is $filter->inflate_row(fuga => { foo2 => 'foo2_value' })->{foo2}, 'foo2_value'; 30 | }; 31 | 32 | subtest 'table and global inflator' => sub { 33 | my $filter = Aniki::Filter->new(); 34 | $filter->add_global_inflator(foo => sub { 35 | my $value = shift; 36 | return "global_$value"; 37 | }); 38 | $filter->add_table_inflator(hoge => foo => sub { 39 | my $value = shift; 40 | return "hoge_$value"; 41 | }); 42 | is $filter->inflate_row(hoge => { foo => 'foo_value' })->{foo}, 'hoge_foo_value'; 43 | is $filter->inflate_row(fuga => { foo => 'foo_value' })->{foo}, 'global_foo_value'; 44 | is $filter->inflate_row(hoge => { foo2 => 'foo2_value' })->{foo2}, 'foo2_value'; 45 | is $filter->inflate_row(fuga => { foo2 => 'foo2_value' })->{foo2}, 'foo2_value'; 46 | }; 47 | 48 | done_testing(); 49 | -------------------------------------------------------------------------------- /t/query_builder/canonical.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | use Aniki::QueryBuilder::Canonical; 7 | use List::Util qw/reduce/; 8 | 9 | my $query_builder = Aniki::QueryBuilder::Canonical->new(driver => 'mysql'); 10 | 11 | subtest select => sub { 12 | my $expect = <<'__QUERY__'; 13 | SELECT * 14 | FROM `foo` 15 | WHERE (`bar` = ?) AND (`baz` = ?) 16 | __QUERY__ 17 | chomp $expect; 18 | my @expect = (1, 2); 19 | 20 | my $ok = reduce { $a && $b } map { 21 | my ($stmt, @bind) = $query_builder->select(foo => ['*'], { bar => 1, baz => 2 }); 22 | $stmt eq $expect && eq_array(\@bind, \@expect); 23 | } 1..1000; 24 | ok $ok, 'can get the same statement always'; 25 | }; 26 | 27 | subtest insert => sub { 28 | my $expect = <<'__QUERY__'; 29 | INSERT INTO `foo` 30 | (`bar`, `baz`) 31 | VALUES (?, ?) 32 | __QUERY__ 33 | chomp $expect; 34 | my @expect = (1, 2); 35 | 36 | my $ok = reduce { $a && $b } map { 37 | my ($stmt, @bind) = $query_builder->insert(foo => { bar => 1, baz => 2 }); 38 | $stmt eq $expect && eq_array(\@bind, \@expect); 39 | } 1..1000; 40 | ok $ok, 'can get the same statement always'; 41 | }; 42 | 43 | subtest update => sub { 44 | my $expect = 'UPDATE `foo` SET `bar` = ?, `foo` = ? WHERE (`bar` = ?) AND (`baz` = ?)'; 45 | my @expect = (2, 1, 1, 2); 46 | 47 | my $ok = reduce { $a && $b } map { 48 | my ($stmt, @bind) = $query_builder->update(foo => { foo => 1, bar => 2 }, { bar => 1, baz => 2 }); 49 | $stmt eq $expect && eq_array(\@bind, \@expect); 50 | } 1..1000; 51 | ok $ok, 'can get the same statement always'; 52 | }; 53 | 54 | subtest delete => sub { 55 | my $expect = 'DELETE FROM `foo` WHERE (`bar` = ?) AND (`baz` = ?)'; 56 | my @expect = (1, 2); 57 | 58 | my $ok = reduce { $a && $b } map { 59 | my ($stmt, @bind) = $query_builder->delete(foo => { bar => 1, baz => 2 }); 60 | $stmt eq $expect && eq_array(\@bind, \@expect); 61 | } 1..1000; 62 | ok $ok, 'can get the same statement always'; 63 | }; 64 | 65 | done_testing(); 66 | -------------------------------------------------------------------------------- /t/filter/trigger/basic.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | use Aniki::Filter; 7 | 8 | subtest 'global trigger only' => sub { 9 | my $filter = Aniki::Filter->new(); 10 | $filter->add_global_trigger(insert => sub { 11 | my ($row, $next) = @_; 12 | $row->{baz}++; 13 | return $next->($row); 14 | }); 15 | is $filter->apply_trigger(insert => hoge => { foo => 'foo_value' })->{baz}, 1; 16 | is $filter->apply_trigger(insert => fuga => { foo => 'foo_value' })->{baz}, 1; 17 | is $filter->apply_trigger(insert => hoge => { foo2 => 'foo2_value' })->{baz}, 1; 18 | is $filter->apply_trigger(insert => fuga => { foo2 => 'foo2_value' })->{baz}, 1; 19 | }; 20 | 21 | subtest 'table trigger only' => sub { 22 | my $filter = Aniki::Filter->new(); 23 | $filter->add_table_trigger(hoge => insert => sub { 24 | my ($row, $next) = @_; 25 | $row->{baz}++; 26 | return $next->($row); 27 | }); 28 | is $filter->apply_trigger(insert => hoge => { foo => 'foo_value' })->{baz}, 1; 29 | is $filter->apply_trigger(insert => fuga => { foo => 'foo_value' })->{baz}, undef; 30 | is $filter->apply_trigger(insert => hoge => { foo2 => 'foo2_value' })->{baz}, 1; 31 | is $filter->apply_trigger(insert => fuga => { foo2 => 'foo2_value' })->{baz}, undef; 32 | }; 33 | 34 | subtest 'table and global trigger' => sub { 35 | my $filter = Aniki::Filter->new(); 36 | $filter->add_table_trigger(hoge => insert => sub { 37 | my ($row, $next) = @_; 38 | $row->{baz}++; 39 | return $next->($row); 40 | }); 41 | $filter->add_global_trigger(insert => sub { 42 | my ($row, $next) = @_; 43 | $row->{baz}++; 44 | return $next->($row); 45 | }); 46 | is $filter->apply_trigger(insert => hoge => { foo => 'foo_value' })->{baz}, 2; 47 | is $filter->apply_trigger(insert => fuga => { foo => 'foo_value' })->{baz}, 1; 48 | is $filter->apply_trigger(insert => hoge => { foo2 => 'foo2_value' })->{baz}, 2; 49 | is $filter->apply_trigger(insert => fuga => { foo2 => 'foo2_value' })->{baz}, 1; 50 | }; 51 | 52 | done_testing(); 53 | -------------------------------------------------------------------------------- /lib/Aniki/Result.pm: -------------------------------------------------------------------------------- 1 | package Aniki::Result; 2 | use 5.014002; 3 | 4 | use namespace::autoclean; 5 | use Mouse v2.4.5; 6 | 7 | has table_name => ( 8 | is => 'ro', 9 | required => 1, 10 | ); 11 | 12 | has suppress_row_objects => ( 13 | is => 'rw', 14 | lazy => 1, 15 | default => sub { shift->handler->suppress_row_objects }, 16 | ); 17 | 18 | has row_class => ( 19 | is => 'rw', 20 | lazy => 1, 21 | default => sub { 22 | my $self = shift; 23 | $self->handler->guess_row_class($self->table_name); 24 | }, 25 | ); 26 | 27 | my %handler; 28 | 29 | sub BUILD { 30 | my ($self, $args) = @_; 31 | $handler{0+$self} = delete $args->{handler}; 32 | } 33 | 34 | sub handler { $handler{0+shift} } 35 | 36 | sub DEMOLISH { 37 | my $self = shift; 38 | delete $handler{0+$self}; 39 | } 40 | 41 | __PACKAGE__->meta->make_immutable(); 42 | __END__ 43 | 44 | =pod 45 | 46 | =encoding utf-8 47 | 48 | =head1 NAME 49 | 50 | Aniki::Result - Result class 51 | 52 | =head1 SYNOPSIS 53 | 54 | my $result = $db->select(foo => { bar => 1 }); 55 | 56 | =head1 DESCRIPTION 57 | 58 | This is abstract result class. 59 | 60 | Aniki detect the collection class from root result class by table name. 61 | Default root result class is C. 62 | 63 | You can use original result class: 64 | 65 | package MyApp::DB; 66 | use Mouse; 67 | extends qw/Aniki/; 68 | 69 | __PACKAGE__->setup( 70 | schema => 'MyApp::DB::Schema', 71 | result => 'MyApp::DB::Collection', 72 | ); 73 | 74 | =head1 ACCESSORS 75 | 76 | =over 4 77 | 78 | =item C 79 | 80 | =item C 81 | 82 | =item C 83 | 84 | =item C 85 | 86 | =back 87 | 88 | =head1 LICENSE 89 | 90 | Copyright (C) karupanerura. 91 | 92 | This library is free software; you can redistribute it and/or modify 93 | it under the same terms as Perl itself. 94 | 95 | =head1 AUTHOR 96 | 97 | karupanerura Ekarupa@cpan.orgE 98 | 99 | =cut 100 | -------------------------------------------------------------------------------- /lib/Aniki/Schema/Relationships.pm: -------------------------------------------------------------------------------- 1 | package Aniki::Schema::Relationships; 2 | use 5.014002; 3 | 4 | use namespace::autoclean; 5 | use Mouse v2.4.5; 6 | use SQL::Translator::Schema::Constants; 7 | use Aniki::Schema::Relationship; 8 | 9 | has schema => ( 10 | is => 'ro', 11 | required => 1, 12 | weak_ref => 1, 13 | ); 14 | 15 | has table => ( 16 | is => 'ro', 17 | required => 1, 18 | ); 19 | 20 | has rule => ( 21 | is => 'rw', 22 | default => sub { +{} }, 23 | ); 24 | 25 | sub add { 26 | my $self = shift; 27 | my $relationship = Aniki::Schema::Relationship->new(schema => $self->schema, @_); 28 | 29 | my $name = $relationship->name; 30 | exists $self->rule->{$name} 31 | and die "already exists $name in rule. (table:@{[ $self->table->name ]})"; 32 | $self->rule->{$name} = $relationship; 33 | } 34 | 35 | sub add_by_constraint { 36 | my ($self, $constraint) = @_; 37 | die "Invalid constraint: @{[ $constraint->name ]}. (table:@{[ $self->table->name ]})" if $constraint->type ne FOREIGN_KEY; 38 | 39 | if ($constraint->table->name eq $self->table->name) { 40 | $self->add( 41 | src_table_name => $constraint->table->name, 42 | src_columns => [$constraint->field_names], 43 | dest_table_name => $constraint->reference_table, 44 | dest_columns => [$constraint->reference_fields], 45 | ); 46 | } 47 | elsif ($constraint->reference_table eq $self->table->name) { 48 | $self->add( 49 | src_table_name => $constraint->reference_table, 50 | src_columns => [$constraint->reference_fields], 51 | dest_table_name => $constraint->table->name, 52 | dest_columns => [$constraint->field_names], 53 | ); 54 | } 55 | else { 56 | die "Invalid constraint: @{[ $constraint->name ]}. (table:@{[ $self->table->name ]})"; 57 | } 58 | } 59 | 60 | sub names { 61 | my $self = shift; 62 | return keys %{ $self->rule }; 63 | } 64 | 65 | sub all { 66 | my $self = shift; 67 | return map { $self->get($_) } $self->names; 68 | } 69 | 70 | sub get { 71 | my ($self, $name) = @_; 72 | return unless exists $self->rule->{$name}; 73 | return $self->rule->{$name}; 74 | } 75 | 76 | __PACKAGE__->meta->make_immutable(); 77 | __END__ 78 | -------------------------------------------------------------------------------- /script/install-aniki: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings; 4 | use utf8; 5 | 6 | use Data::Section::Simple qw/get_data_section/; 7 | use File::Spec; 8 | use File::Path qw/make_path/; 9 | use Getopt::Long qw/:config posix_default no_ignore_case bundling auto_help/; 10 | 11 | GetOptions(\my %opt, qw/lib=s/) or die "Usage: $0 --lib=./lib MyApp::DB"; 12 | die "Usage: $0 --lib=./lib MyApp::DB" if grep { !exists $opt{$_}} qw/lib/; 13 | my $prefix = shift @ARGV or die "Usage: $0 --lib=./lib MyApp::DB"; 14 | 15 | my $basefile = File::Spec->catfile($opt{lib}, split /::/, $prefix).'.pm'; 16 | my $basedir = File::Spec->catdir($opt{lib}, split /::/, $prefix); 17 | make_path($basedir); 18 | 19 | print "Creating ${prefix} ... "; 20 | spew($basefile, render('DB')); 21 | print "done\n"; 22 | system $^X, '-wc', $basefile; 23 | 24 | for my $type (qw/Schema Filter Result Row/) { 25 | print "Creating ${prefix}::${type} ... "; 26 | my $file = File::Spec->catfile($basedir, split /::/, $type).'.pm'; 27 | my $code = render($type); 28 | spew($file, $code); 29 | print "done\n"; 30 | system $^X, '-wc', $file; 31 | } 32 | 33 | sub render { 34 | my $type = shift; 35 | my $code = get_data_section($type.'.pm'); 36 | $code =~ s/\$\{prefix\}/$prefix/mg; 37 | return $code; 38 | } 39 | 40 | sub spew { 41 | my ($file, $content) = @_; 42 | open my $fh, '>', $file or die $!; 43 | print {$fh} $content; 44 | } 45 | 46 | __DATA__ 47 | @@ DB.pm 48 | package ${prefix}; 49 | use 5.014002; 50 | use Mouse v2.4.5; 51 | extends qw/Aniki/; 52 | 53 | __PACKAGE__->setup( 54 | schema => '${prefix}::Schema', 55 | filter => '${prefix}::Filter', 56 | result => '${prefix}::Result', 57 | row => '${prefix}::Row', 58 | ); 59 | 60 | __PACKAGE__->meta->make_immutable(); 61 | 62 | @@ Schema.pm 63 | package ${prefix}::Schema; 64 | use 5.014002; 65 | 66 | use DBIx::Schema::DSL; 67 | use Aniki::Schema::Relationship::Declare; 68 | 69 | 1; 70 | 71 | @@ Filter.pm 72 | package ${prefix}::Filter; 73 | use 5.014002; 74 | 75 | use Aniki::Filter::Declare; 76 | 77 | 1; 78 | 79 | @@ Result.pm 80 | package ${prefix}::Result; 81 | use 5.014002; 82 | use Mouse v2.4.5; 83 | extends qw/Aniki::Result::Collection/; 84 | 85 | 1; 86 | 87 | @@ Row.pm 88 | package ${prefix}::Row; 89 | use 5.014002; 90 | use Mouse v2.4.5; 91 | extends qw/Aniki::Row/; 92 | 93 | 1; 94 | -------------------------------------------------------------------------------- /t/filter/declare/basic.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | 7 | package MyProj::DB::Filter { 8 | use Aniki::Filter::Declare; 9 | 10 | table hoge => sub { 11 | inflate foo => sub { 12 | my $value = shift; 13 | return "hoge_inflate_$value"; 14 | }; 15 | 16 | deflate foo => sub { 17 | my $value = shift; 18 | return "hoge_deflate_$value"; 19 | }; 20 | }; 21 | 22 | inflate bar => sub { 23 | my $value = shift; 24 | return "global_inflate_$value"; 25 | }; 26 | 27 | deflate bar => sub { 28 | my $value = shift; 29 | return "global_deflate_$value"; 30 | }; 31 | }; 32 | 33 | my $filter = MyProj::DB::Filter->instance; 34 | 35 | subtest table => sub { 36 | is $filter->inflate_row(hoge => { foo => 'foo_value' })->{foo}, 'hoge_inflate_foo_value'; 37 | is $filter->deflate_row(hoge => { foo => 'foo_value' })->{foo}, 'hoge_deflate_foo_value'; 38 | is $filter->inflate_row(hoge => { foo => 'foo_value' })->{foo}, 'hoge_inflate_foo_value'; 39 | is $filter->deflate_row(hoge => { foo => 'foo_value' })->{foo}, 'hoge_deflate_foo_value'; 40 | is $filter->inflate_row(fuga => { foo => 'foo_value' })->{foo}, 'foo_value'; 41 | is $filter->deflate_row(fuga => { foo => 'foo_value' })->{foo}, 'foo_value'; 42 | is $filter->inflate_row(fuga => { foo => 'foo_value' })->{foo}, 'foo_value'; 43 | is $filter->deflate_row(fuga => { foo => 'foo_value' })->{foo}, 'foo_value'; 44 | }; 45 | 46 | subtest global => sub { 47 | is $filter->inflate_row(hoge => { bar => 'bar_value' })->{bar}, 'global_inflate_bar_value'; 48 | is $filter->deflate_row(hoge => { bar => 'bar_value' })->{bar}, 'global_deflate_bar_value'; 49 | is $filter->inflate_row(hoge => { bar => 'bar_value' })->{bar}, 'global_inflate_bar_value'; 50 | is $filter->deflate_row(hoge => { bar => 'bar_value' })->{bar}, 'global_deflate_bar_value'; 51 | is $filter->inflate_row(fuga => { bar => 'bar_value' })->{bar}, 'global_inflate_bar_value'; 52 | is $filter->deflate_row(fuga => { bar => 'bar_value' })->{bar}, 'global_deflate_bar_value'; 53 | is $filter->inflate_row(fuga => { bar => 'bar_value' })->{bar}, 'global_inflate_bar_value'; 54 | is $filter->deflate_row(fuga => { bar => 'bar_value' })->{bar}, 'global_deflate_bar_value'; 55 | }; 56 | 57 | done_testing; 58 | -------------------------------------------------------------------------------- /t/schema/relationship/name.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | 7 | use Aniki::Schema::Relationship; 8 | 9 | my @keys = qw/has_many src_table_name src_columns dest_table_name dest_columns/; 10 | my @test_cases = ( 11 | 12 | [ 1, 'author', [qw/id/], 'module', [qw/author_id/] ] => 'modules', 13 | [ 1, 'author', [qw/id/], 'fish', [qw/author_id/] ] => 'fish', 14 | 15 | [ 1, 'author', [qw/foo_module/], 'module', [qw/author_bar/] ] => 'foo_modules', 16 | [ 1, 'author', [qw/foo/], 'module', [qw/bar_author/] ] => 'bar_modules', 17 | [ 1, 'author', [qw/foo_module/], 'module', [qw/author_bar foo/] ] => 'foo_modules', 18 | [ 1, 'author', [qw/foo_module foo/], 'module', [qw/author_bar/] ] => 'modules', 19 | [ 1, 'author', [qw/foo_module foo/], 'module', [qw/author_bar bar/] ] => 'modules', 20 | 21 | [ 1, 'author', [qw/id/], 'cpan_module', [qw/author_id/] ] => 'cpan_modules', 22 | [ 1, 'author', [qw/id/], 'cpan-module', [qw/author_id/] ] => 'cpan-modules', 23 | [ 1, 'author', [qw/id/], 'cpan module', [qw/author_id/] ] => 'cpan modules', 24 | [ 1, 'author', [qw/id/], 'cpan/module', [qw/author_id/] ] => 'cpan/modules', 25 | 26 | [ 0, 'module', [qw/author_id/], 'author', [qw/id/] ] => 'author', 27 | [ 0, 'module', [qw/author_id/], 'fish', [qw/id/] ] => 'fish', 28 | 29 | [ 0, 'module', [qw/author_bar/], 'author', [qw/foo_module/] ] => 'foo_author', 30 | [ 0, 'module', [qw/bar_author/], 'author', [qw/foo/] ] => 'bar_author', 31 | [ 0, 'module', [qw/author_bar foo/], 'author', [qw/foo_module/] ] => 'foo_author', 32 | [ 0, 'module', [qw/author_bar/], 'author', [qw/foo_module foo/] ] => 'author', 33 | [ 0, 'module', [qw/author_bar bar/], 'author', [qw/foo_module foo/] ] => 'author', 34 | ); 35 | 36 | while (@test_cases) { 37 | my ( $args, $name ) = splice @test_cases, 0, 2; 38 | is relationship($args)->name, $name, "relationship name is $name"; 39 | } 40 | 41 | my $schema = bless {}, 'MyTest::Schema'; 42 | sub relationship { 43 | my $args = shift; 44 | my %args; 45 | $args{$keys[$_]} = $args->[$_] for 0 .. $#keys; 46 | Aniki::Schema::Relationship->new( schema => $schema, %args ); 47 | } 48 | 49 | done_testing(); 50 | -------------------------------------------------------------------------------- /t/schema/relationships/basic.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | 7 | use Aniki::Schema; 8 | use Aniki::Schema::Relationships; 9 | use SQL::Translator::Schema::Constants; 10 | 11 | package MyTest::Schema { 12 | use strict; 13 | use warnings; 14 | 15 | use DBIx::Schema::DSL; 16 | 17 | database 'SQLite'; 18 | 19 | create_table 'author' => columns { 20 | integer 'id', primary_key, auto_increment; 21 | varchar 'name', unique; 22 | }; 23 | 24 | create_table 'module' => columns { 25 | integer 'id', primary_key, auto_increment; 26 | varchar 'name'; 27 | integer 'author_id'; 28 | 29 | add_index 'author_id_idx' => ['author_id']; 30 | belongs_to 'author'; 31 | }; 32 | 33 | create_table 'review' => columns { 34 | integer 'id', primary_key, auto_increment; 35 | integer 'module_id'; 36 | integer 'author_id'; 37 | varchar 'description'; 38 | 39 | add_index 'module_id_idx' => ['module_id']; 40 | add_index 'author_id_idx' => ['author_id']; 41 | 42 | belongs_to 'author'; 43 | belongs_to 'module'; 44 | }; 45 | }; 46 | 47 | my $schema = Aniki::Schema->new(schema_class => 'MyTest::Schema'); 48 | 49 | subtest 'add' => sub { 50 | my $relationships = Aniki::Schema::Relationships->new(schema => $schema, table => $schema->get_table('author')); 51 | $relationships->add( 52 | src_table_name => 'author', 53 | src_columns => [qw/id/], 54 | dest_table_name => 'module', 55 | dest_columns => [qw/author_id/], 56 | ); 57 | is_deeply [$relationships->names], [qw/modules/]; 58 | $relationships->add( 59 | src_table_name => 'author', 60 | src_columns => [qw/id/], 61 | dest_table_name => 'review', 62 | dest_columns => [qw/author_id/], 63 | ); 64 | is_deeply [sort $relationships->names], [qw/modules reviews/]; 65 | }; 66 | 67 | subtest 'add_by_constraint' => sub { 68 | my $table = $schema->get_table('module'); 69 | my $relationships = Aniki::Schema::Relationships->new(schema => $schema, table => $table); 70 | my ($belongs_to_author) = grep { $_->type eq FOREIGN_KEY } $table->get_constraints; 71 | $relationships->add_by_constraint($belongs_to_author); 72 | is_deeply [$relationships->names], [qw/author/]; 73 | }; 74 | 75 | done_testing(); 76 | -------------------------------------------------------------------------------- /lib/Aniki/Plugin/Pager.pm: -------------------------------------------------------------------------------- 1 | package Aniki::Plugin::Pager; 2 | use 5.014002; 3 | 4 | use namespace::autoclean; 5 | use Mouse::Role; 6 | 7 | use Carp qw/croak/; 8 | 9 | requires qw/select/; 10 | with qw/Aniki::Plugin::PagerInjector/; 11 | with qw/Aniki::Plugin::RangeConditionMaker/; 12 | 13 | sub select_with_pager { 14 | my ($self, $table_name, $where, $opt) = @_; 15 | $where //= {}; 16 | $opt //= {}; 17 | 18 | croak '(Aniki::Plugin::Pager#select_with_pager) `where` condition must be a reference.' unless ref $where; 19 | 20 | my $range_condition = $self->make_range_condition($opt); 21 | if ($range_condition) { 22 | ref $where eq 'HASH' 23 | or croak "where condition *MUST* be HashRef when using range codition."; 24 | 25 | for my $column (keys %$range_condition) { 26 | croak "Conflict range condition and where condition for $table_name.$column" 27 | if exists $where->{$column}; 28 | } 29 | 30 | $where = {%$where, %$range_condition}; 31 | } 32 | 33 | my $page = $opt->{page} or Carp::croak("required parameter: page"); 34 | my $rows = $opt->{rows} or Carp::croak("required parameter: rows"); 35 | my $result = $self->select($table_name => $where, { 36 | %$opt, 37 | limit => $rows + 1, 38 | !$range_condition ? ( 39 | offset => $rows * ($page - 1), 40 | ) : (), 41 | }); 42 | 43 | return $self->inject_pager_to_result($result => { 44 | rows => $rows, 45 | page => $page, 46 | }); 47 | } 48 | 49 | 50 | 1; 51 | __END__ 52 | 53 | =pod 54 | 55 | =encoding utf-8 56 | 57 | =head1 NAME 58 | 59 | Aniki::Plugin::Pager - SELECT with pager 60 | 61 | =head1 SYNOPSIS 62 | 63 | package MyDB; 64 | use Mouse v2.4.5; 65 | extends qw/Aniki/; 66 | with qw/Aniki::Plugin::Pager/; 67 | 68 | package main; 69 | my $db = MyDB->new(...); 70 | my $result = $db->select_with_pager('user', { type => 2 }, { page => 1, rows => 10 }); # => Aniki::Result::Collection(+Aniki::Result::Role::Pager) 71 | $result->pager; # => Data::Page::NoTotalEntries 72 | 73 | =head1 SEE ALSO 74 | 75 | L 76 | 77 | =head1 LICENSE 78 | 79 | Copyright (C) karupanerura. 80 | 81 | This library is free software; you can redistribute it and/or modify 82 | it under the same terms as Perl itself. 83 | 84 | =head1 AUTHOR 85 | 86 | karupanerura Ekarupa@cpan.orgE 87 | 88 | =cut 89 | -------------------------------------------------------------------------------- /lib/Aniki/Schema.pm: -------------------------------------------------------------------------------- 1 | package Aniki::Schema; 2 | use 5.014002; 3 | 4 | use namespace::autoclean; 5 | use Mouse v2.4.5; 6 | 7 | use SQL::Translator::Schema::Constants; 8 | use Carp qw/croak/; 9 | use Aniki::Schema::Table; 10 | 11 | has schema_class => ( 12 | is => 'ro', 13 | required => 1, 14 | ); 15 | 16 | has context => ( 17 | is => 'ro', 18 | default => sub { shift->schema_class->context } 19 | ); 20 | 21 | has _table_cache => ( 22 | is => 'ro', 23 | default => sub { 24 | my $self = shift; 25 | return { 26 | map { $_->name => Aniki::Schema::Table->new($_, $self) } $self->context->schema->get_tables() 27 | }; 28 | }, 29 | ); 30 | 31 | sub BUILD { 32 | my $self = shift; 33 | 34 | # for cache 35 | for my $table ($self->get_tables) { 36 | for my $relationship ($table->get_relationships->all) { 37 | $relationship->get_inverse_relationships(); 38 | } 39 | } 40 | } 41 | 42 | sub get_table { 43 | my ($self, $table_name) = @_; 44 | return unless exists $self->_table_cache->{$table_name}; 45 | return $self->_table_cache->{$table_name}; 46 | } 47 | 48 | sub get_tables { 49 | my $self = shift; 50 | return values %{ $self->_table_cache }; 51 | } 52 | 53 | sub has_many { 54 | my ($self, $table_name, $fields) = @_; 55 | my $table = $self->context->schema->get_table($table_name); 56 | return !!1 unless defined $table; 57 | 58 | my %field = map { $_ => 1 } @$fields; 59 | for my $unique (grep { $_->type eq UNIQUE || $_->type eq PRIMARY_KEY } $table->get_constraints) { 60 | my @field_names = $unique->field_names; 61 | my @related_fields = grep { $field{$_} } @field_names; 62 | return !!0 if @field_names == @related_fields; 63 | } 64 | for my $index (grep { $_->type eq UNIQUE } $table->get_indices) { 65 | my @field_names = $index->fields; 66 | my @related_fields = grep { $field{$_} } @field_names; 67 | return !!0 if @field_names == @related_fields; 68 | } 69 | return !!1; 70 | } 71 | 72 | our $AUTOLOAD; 73 | sub AUTOLOAD { 74 | my $self = shift; 75 | my $method = $AUTOLOAD =~ s/^.*://r; 76 | if ($self->context->schema->can($method)) { 77 | return $self->context->schema->$method(@_); 78 | } 79 | 80 | my $class = ref $self; 81 | croak qq{Can't locate object method "$method" via package "$class"}; 82 | } 83 | 84 | __PACKAGE__->meta->make_immutable(); 85 | __END__ 86 | -------------------------------------------------------------------------------- /t/filter/deflate/regex.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | use Aniki::Filter; 7 | 8 | subtest 'global deflator only' => sub { 9 | my $filter = Aniki::Filter->new(); 10 | $filter->add_global_deflator(qr/foo/ => sub { 11 | my $value = shift; 12 | return "global_$value"; 13 | }); 14 | is $filter->deflate_row(hoge => { foo => 'foo_value' })->{foo}, 'global_foo_value'; 15 | is $filter->deflate_row(fuga => { foo => 'foo_value' })->{foo}, 'global_foo_value'; 16 | is $filter->deflate_row(hoge => { foo2 => 'foo2_value' })->{foo2}, 'global_foo2_value'; 17 | is $filter->deflate_row(fuga => { foo2 => 'foo2_value' })->{foo2}, 'global_foo2_value'; 18 | is $filter->deflate_row(hoge => { bar => 'bar_value' })->{bar}, 'bar_value'; 19 | is $filter->deflate_row(fuga => { bar => 'bar_value' })->{bar}, 'bar_value'; 20 | }; 21 | 22 | subtest 'table deflator only' => sub { 23 | my $filter = Aniki::Filter->new(); 24 | $filter->add_table_deflator(hoge => qr/foo/ => sub { 25 | my $value = shift; 26 | return "hoge_$value"; 27 | }); 28 | is $filter->deflate_row(hoge => { foo => 'foo_value' })->{foo}, 'hoge_foo_value'; 29 | is $filter->deflate_row(fuga => { foo => 'foo_value' })->{foo}, 'foo_value'; 30 | is $filter->deflate_row(hoge => { foo2 => 'foo2_value' })->{foo2}, 'hoge_foo2_value'; 31 | is $filter->deflate_row(fuga => { foo2 => 'foo2_value' })->{foo2}, 'foo2_value'; 32 | is $filter->deflate_row(hoge => { bar => 'bar_value' })->{bar}, 'bar_value'; 33 | is $filter->deflate_row(fuga => { bar => 'bar_value' })->{bar}, 'bar_value'; 34 | }; 35 | 36 | subtest 'table and global deflator' => sub { 37 | my $filter = Aniki::Filter->new(); 38 | $filter->add_global_deflator(qr/foo/ => sub { 39 | my $value = shift; 40 | return "global_$value"; 41 | }); 42 | $filter->add_table_deflator(hoge => qr/foo/ => sub { 43 | my $value = shift; 44 | return "hoge_$value"; 45 | }); 46 | is $filter->deflate_row(hoge => { foo => 'foo_value' })->{foo}, 'hoge_foo_value'; 47 | is $filter->deflate_row(fuga => { foo => 'foo_value' })->{foo}, 'global_foo_value'; 48 | is $filter->deflate_row(hoge => { foo2 => 'foo2_value' })->{foo2}, 'hoge_foo2_value'; 49 | is $filter->deflate_row(fuga => { foo2 => 'foo2_value' })->{foo2}, 'global_foo2_value'; 50 | is $filter->deflate_row(hoge => { bar => 'bar_value' })->{bar}, 'bar_value'; 51 | is $filter->deflate_row(fuga => { bar => 'bar_value' })->{bar}, 'bar_value'; 52 | }; 53 | 54 | done_testing(); 55 | -------------------------------------------------------------------------------- /t/filter/inflate/regex.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | use Aniki::Filter; 7 | 8 | subtest 'global inflator only' => sub { 9 | my $filter = Aniki::Filter->new(); 10 | $filter->add_global_inflator(qr/foo/ => sub { 11 | my $value = shift; 12 | return "global_$value"; 13 | }); 14 | is $filter->inflate_row(hoge => { foo => 'foo_value' })->{foo}, 'global_foo_value'; 15 | is $filter->inflate_row(fuga => { foo => 'foo_value' })->{foo}, 'global_foo_value'; 16 | is $filter->inflate_row(hoge => { foo2 => 'foo2_value' })->{foo2}, 'global_foo2_value'; 17 | is $filter->inflate_row(fuga => { foo2 => 'foo2_value' })->{foo2}, 'global_foo2_value'; 18 | is $filter->inflate_row(hoge => { bar => 'bar_value' })->{bar}, 'bar_value'; 19 | is $filter->inflate_row(fuga => { bar => 'bar_value' })->{bar}, 'bar_value'; 20 | }; 21 | 22 | subtest 'table inflator only' => sub { 23 | my $filter = Aniki::Filter->new(); 24 | $filter->add_table_inflator(hoge => qr/foo/ => sub { 25 | my $value = shift; 26 | return "hoge_$value"; 27 | }); 28 | is $filter->inflate_row(hoge => { foo => 'foo_value' })->{foo}, 'hoge_foo_value'; 29 | is $filter->inflate_row(fuga => { foo => 'foo_value' })->{foo}, 'foo_value'; 30 | is $filter->inflate_row(hoge => { foo2 => 'foo2_value' })->{foo2}, 'hoge_foo2_value'; 31 | is $filter->inflate_row(fuga => { foo2 => 'foo2_value' })->{foo2}, 'foo2_value'; 32 | is $filter->inflate_row(hoge => { bar => 'bar_value' })->{bar}, 'bar_value'; 33 | is $filter->inflate_row(fuga => { bar => 'bar_value' })->{bar}, 'bar_value'; 34 | }; 35 | 36 | subtest 'table and global inflator' => sub { 37 | my $filter = Aniki::Filter->new(); 38 | $filter->add_global_inflator(qr/foo/ => sub { 39 | my $value = shift; 40 | return "global_$value"; 41 | }); 42 | $filter->add_table_inflator(hoge => qr/foo/ => sub { 43 | my $value = shift; 44 | return "hoge_$value"; 45 | }); 46 | is $filter->inflate_row(hoge => { foo => 'foo_value' })->{foo}, 'hoge_foo_value'; 47 | is $filter->inflate_row(fuga => { foo => 'foo_value' })->{foo}, 'global_foo_value'; 48 | is $filter->inflate_row(hoge => { foo2 => 'foo2_value' })->{foo2}, 'hoge_foo2_value'; 49 | is $filter->inflate_row(fuga => { foo2 => 'foo2_value' })->{foo2}, 'global_foo2_value'; 50 | is $filter->inflate_row(hoge => { bar => 'bar_value' })->{bar}, 'bar_value'; 51 | is $filter->inflate_row(fuga => { bar => 'bar_value' })->{bar}, 'bar_value'; 52 | }; 53 | 54 | done_testing(); 55 | -------------------------------------------------------------------------------- /lib/Aniki/Plugin/SQLPager.pm: -------------------------------------------------------------------------------- 1 | package Aniki::Plugin::SQLPager; 2 | use 5.014002; 3 | 4 | use namespace::autoclean; 5 | use Mouse::Role; 6 | 7 | requires qw/select_by_sql select_named/; 8 | with qw/Aniki::Plugin::PagerInjector/; 9 | 10 | sub select_by_sql_with_pager { 11 | my ($self, $sql, $bind, $opt) = @_; 12 | $opt //= {}; 13 | 14 | my $page = $opt->{page} or Carp::croak("required parameter: page"); 15 | my $rows = $opt->{rows} or Carp::croak("required parameter: rows"); 16 | 17 | my $limit = $rows + 1; 18 | my $offset = $rows * ($page - 1); 19 | if ($opt->{no_offset}) { 20 | $sql .= sprintf ' LIMIT %d', $limit; 21 | } 22 | else { 23 | $sql .= sprintf ' LIMIT %d OFFSET %d', $limit, $offset; 24 | } 25 | 26 | my $result = $self->select_by_sql($sql, $bind, $opt); 27 | return $self->inject_pager_to_result($result => $opt); 28 | } 29 | 30 | sub select_named_with_pager { 31 | my ($self, $sql, $bind, $opt) = @_; 32 | $opt //= {}; 33 | 34 | my $page = $opt->{page} or Carp::croak("required parameter: page"); 35 | my $rows = $opt->{rows} or Carp::croak("required parameter: rows"); 36 | 37 | my $limit = $rows + 1; 38 | my $offset = $rows * ($page - 1); 39 | if ($opt->{no_offset}) { 40 | $sql .= sprintf ' LIMIT %d', $limit; 41 | } 42 | else { 43 | $sql .= sprintf ' LIMIT %d OFFSET %d', $limit, $offset; 44 | } 45 | 46 | my $result = $self->select_named($sql, $bind, $opt); 47 | return $self->inject_pager_to_result($result => $opt); 48 | } 49 | 50 | 1; 51 | __END__ 52 | 53 | =pod 54 | 55 | =for stopwords sql 56 | 57 | =encoding utf-8 58 | 59 | =head1 NAME 60 | 61 | Aniki::Plugin::SQLPager - SELECT sql with pager 62 | 63 | =head1 SYNOPSIS 64 | 65 | package MyDB; 66 | use Mouse v2.4.5; 67 | extends qw/Aniki/; 68 | with qw/Aniki::Plugin::Pager/; 69 | 70 | package main; 71 | my $db = MyDB->new(...); 72 | my $result = $db->select_by_sql_with_pager('SELECT * FROM user WHERE type = ?', [ 2 ], { page => 1, rows => 10 }); # => Aniki::Result::Collection(+Aniki::Result::Role::Pager) 73 | # ALSO OK: my $result = $db->select_named_with_pager('SELECT * FROM user WHERE type = :type', { type => 2 }, { page => 1, rows => 10 }); # => Aniki::Result::Collection(+Aniki::Result::Role::Pager) 74 | $result->pager; # => Data::Page::NoTotalEntries 75 | 76 | =head1 SEE ALSO 77 | 78 | L 79 | 80 | =head1 LICENSE 81 | 82 | Copyright (C) karupanerura. 83 | 84 | This library is free software; you can redistribute it and/or modify 85 | it under the same terms as Perl itself. 86 | 87 | =head1 AUTHOR 88 | 89 | karupanerura Ekarupa@cpan.orgE 90 | 91 | =cut 92 | -------------------------------------------------------------------------------- /lib/Aniki/Result/Collection.pm: -------------------------------------------------------------------------------- 1 | package Aniki::Result::Collection; 2 | use 5.014002; 3 | 4 | use namespace::autoclean; 5 | use Mouse v2.4.5; 6 | extends qw/Aniki::Result/; 7 | 8 | use overload 9 | '@{}' => sub { shift->rows }, 10 | fallback => 1; 11 | 12 | has row_datas => ( 13 | is => 'ro', 14 | required => 1, 15 | ); 16 | 17 | has inflated_rows => ( 18 | is => 'ro', 19 | lazy => 1, 20 | builder => '_inflate', 21 | ); 22 | 23 | sub _inflate { 24 | my $self = shift; 25 | my $row_class = $self->row_class; 26 | my $table_name = $self->table_name; 27 | my $handler = $self->handler; 28 | return [ 29 | map { 30 | $row_class->new( 31 | table_name => $table_name, 32 | handler => $handler, 33 | row_data => $_ 34 | ) 35 | } @{ $self->row_datas } 36 | ]; 37 | } 38 | 39 | sub rows { 40 | my $self = shift; 41 | return $self->suppress_row_objects ? $self->row_datas : $self->inflated_rows; 42 | } 43 | 44 | sub count { scalar @{ shift->rows(@_) } } 45 | 46 | sub first { shift->rows(@_)->[0] } 47 | sub last :method { shift->rows(@_)->[-1] } 48 | sub all { @{ shift->rows(@_) } } 49 | 50 | __PACKAGE__->meta->make_immutable(); 51 | __END__ 52 | 53 | =pod 54 | 55 | =encoding utf-8 56 | 57 | =head1 NAME 58 | 59 | Aniki::Result::Collection - Rows as a collection 60 | 61 | =head1 SYNOPSIS 62 | 63 | my $result = $db->select(foo => { bar => 1 }); 64 | for my $row ($result->all) { 65 | print $row->id, "\n"; 66 | } 67 | 68 | =head1 DESCRIPTION 69 | 70 | This is collection result class. 71 | 72 | =head1 INSTANCE METHODS 73 | 74 | =head2 C 75 | 76 | Returns rows as array reference. 77 | 78 | =head2 C 79 | 80 | Returns rows count. 81 | 82 | =head2 C 83 | 84 | Returns first row. 85 | 86 | =head2 C 87 | 88 | Returns last row. 89 | 90 | =head2 C 91 | 92 | Returns rows as array. 93 | 94 | =head1 ACCESSORS 95 | 96 | =over 4 97 | 98 | =item C 99 | 100 | =item C 101 | 102 | =item C 103 | 104 | =item C 105 | 106 | =item C 107 | 108 | =item C 109 | 110 | =back 111 | 112 | =head1 LICENSE 113 | 114 | Copyright (C) karupanerura. 115 | 116 | This library is free software; you can redistribute it and/or modify 117 | it under the same terms as Perl itself. 118 | 119 | =head1 AUTHOR 120 | 121 | karupanerura Ekarupa@cpan.orgE 122 | 123 | =cut 124 | -------------------------------------------------------------------------------- /lib/Aniki/Plugin/PagerInjector.pm: -------------------------------------------------------------------------------- 1 | package Aniki::Plugin::PagerInjector; 2 | use 5.014002; 3 | 4 | use namespace::autoclean; 5 | use Mouse::Role; 6 | use Data::Page::NoTotalEntries; 7 | use Aniki::Result::Role::Pager; 8 | 9 | requires qw/guess_result_class/; 10 | 11 | sub inject_pager_to_result { 12 | my ($self, $result, $opt) = @_; 13 | my $table_name = $result->table_name; 14 | 15 | my $has_next = $opt->{rows} < $result->count; 16 | if ($has_next) { 17 | my $result_class = ref $result; 18 | $result = $result_class->new( 19 | table_name => $table_name, 20 | handler => $self, 21 | row_datas => [@{$result->row_datas}[0..$result->count-2]], 22 | !$result->suppress_row_objects ? ( 23 | inflated_rows => [@{$result->inflated_rows}[0..$result->count-2]], 24 | ) : (), 25 | suppress_row_objects => $result->suppress_row_objects, 26 | row_class => $result->row_class, 27 | ); 28 | } 29 | 30 | my $pager = Data::Page::NoTotalEntries->new( 31 | entries_per_page => $opt->{rows}, 32 | current_page => $opt->{page}, 33 | has_next => $has_next, 34 | entries_on_this_page => $result->count, 35 | ); 36 | $result->meta->does_role('Aniki::Result::Role::Pager') 37 | or Mouse::Util::apply_all_roles($result, 'Aniki::Result::Role::Pager'); 38 | $result->pager($pager); 39 | 40 | return $result; 41 | } 42 | 43 | 1; 44 | __END__ 45 | 46 | =pod 47 | 48 | =encoding utf-8 49 | 50 | =head1 NAME 51 | 52 | Aniki::Plugin::PagerInjector - plus one pager injector 53 | 54 | =head1 SYNOPSIS 55 | 56 | package MyDB; 57 | use Mouse v2.4.5; 58 | extends qw/Aniki/; 59 | with qw/Aniki::Plugin::PagerInjector/; 60 | 61 | package main; 62 | my $db = MyDB->new(...); 63 | 64 | my ($page, $rows) = (1, 10); 65 | my ($limit, $offset) = ($rows + 1, ($page - 1) * $rows); 66 | my $result = $db->select('user', { type => 2 }, { limit => $limit, offset => $offset }); # => Aniki::Result::Collection 67 | $result = $db->inject_pager_to_result($result => { # => inject Aniki::Result::Role::Pager 68 | table_name => 'user', 69 | rows => $rows, 70 | page => $page, 71 | }) 72 | $result->pager; # => Data::Page::NoTotalEntries 73 | 74 | =head1 SEE ALSO 75 | 76 | L 77 | L 78 | 79 | =head1 LICENSE 80 | 81 | Copyright (C) karupanerura. 82 | 83 | This library is free software; you can redistribute it and/or modify 84 | it under the same terms as Perl itself. 85 | 86 | =head1 AUTHOR 87 | 88 | karupanerura Ekarupa@cpan.orgE 89 | 90 | =cut 91 | -------------------------------------------------------------------------------- /t/14_update_and_fetch_row.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | 7 | use File::Spec; 8 | use lib File::Spec->catfile('t', 'lib'); 9 | use t::Util; 10 | 11 | run_on_database { 12 | my $row = db->insert_and_fetch_row(author => { name => 'MOZNION' }); 13 | subtest 'assert default (in|de)flate_message' => sub { 14 | is $row->inflate_message, 'inflate hello', 'inflated: inflate_message'; 15 | is $row->deflate_message, 'hello', 'inflated: deflate_message'; 16 | is $row->get_column('inflate_message'), 'hello', 'raw: inflate_message'; 17 | is $row->get_column('deflate_message'), 'hello', 'raw: deflate_message'; 18 | }; 19 | 20 | subtest 'croak' => sub { 21 | my ($line, $file); 22 | eval { 23 | ($line, $file) = (__LINE__, __FILE__); db->update_and_fetch_row(undef, +{ name => 'MACKEE' }); 24 | }; 25 | like $@, qr/^\Q(Aniki#update_and_fetch_row) condition must be a Aniki::Row object. at $file line $line/m, 'croak from update_and_fetch_row'; 26 | 27 | eval { 28 | ($line, $file) = (__LINE__, __FILE__); db->update_and_fetch_row($row, {}); 29 | }; 30 | like $@, qr/^\Q(Aniki#update) `set` is required for update ("SET" parameter) at $file line $line/m, 'croak from update'; 31 | }; 32 | 33 | subtest 'emulate new row' => sub { 34 | local db->{suppress_row_objects} = 1; 35 | my $new_row = db->update_and_fetch_row($row, +{ name => 'PAPIX' }); 36 | isa_ok $new_row, 'HASH'; 37 | is $new_row->{$_}, $row->get_column($_), "raw: $_" for grep { $_ ne 'name' } db->schema->get_table('author')->field_names; 38 | is $new_row->{name}, 'PAPIX', 'raw: name'; 39 | }; 40 | $row = $row->refetch; 41 | 42 | subtest 'emulate new row object' => sub { 43 | my $new_row = db->update_and_fetch_row($row, +{ name => 'KARUPA' }); 44 | isa_ok $new_row, 'Aniki::Row'; 45 | is_deeply $new_row->get_columns, { 46 | %{ $row->get_columns }, 47 | name => 'KARUPA', 48 | }, 'raw: @columuns'; 49 | is $new_row->$_, $row->$_, "inflated: $_" for grep { $_ ne 'name' } db->schema->get_table('author')->field_names; 50 | is $new_row->name, 'KARUPA', 'inflated: name'; 51 | $row = $new_row; 52 | }; 53 | 54 | subtest 'emulate inflate/deflate' => sub { 55 | my $new_row = db->update_and_fetch_row($row, +{ inflate_message => 'hello world', deflate_message => 'hello world' }); 56 | is $new_row->inflate_message, 'inflate hello world', 'inflated: inflate_message'; 57 | is $new_row->deflate_message, 'deflate hello world', 'inflated: deflate_message'; 58 | is $new_row->get_column('inflate_message'), 'hello world', 'raw: inflate_message'; 59 | is $new_row->get_column('deflate_message'), 'deflate hello world', 'raw: deflate_message'; 60 | }; 61 | }; 62 | 63 | done_testing(); 64 | -------------------------------------------------------------------------------- /lib/Aniki/Plugin/RangeConditionMaker.pm: -------------------------------------------------------------------------------- 1 | package Aniki::Plugin::RangeConditionMaker; 2 | use 5.014002; 3 | 4 | use namespace::autoclean; 5 | use Mouse::Role; 6 | 7 | use Carp qw/carp croak/; 8 | use SQL::QueryMaker qw/sql_gt sql_lt sql_ge sql_le sql_and/; 9 | 10 | sub make_range_condition { 11 | my ($self, $range) = @_; 12 | 13 | my %total_range_condition; 14 | for my $type (qw/lower upper gt lt ge le/) { 15 | next unless exists $range->{$type}; 16 | 17 | ref $range->{$type} eq 'HASH' 18 | or croak "$type condition *MUST* be HashRef."; 19 | 20 | my $func; 21 | if ($type eq 'lower' || $type eq 'gt') { 22 | $func = \&sql_gt; 23 | } 24 | elsif ($type eq 'upper' || $type eq 'lt') { 25 | $func = \&sql_lt; 26 | } 27 | elsif ($type eq 'ge') { 28 | $func = \&sql_ge; 29 | } 30 | elsif ($type eq 'le') { 31 | $func = \&sql_le; 32 | } 33 | 34 | die "Unknown type: $type" unless $func; 35 | 36 | my $range_condition = $range->{$type}; 37 | for my $column (keys %$range_condition) { 38 | croak "$column cannot be a reference value for range condition" 39 | if ref $range_condition->{$column}; 40 | 41 | my $condition = $func->($range_condition->{$column}); 42 | $total_range_condition{$column} = 43 | exists $total_range_condition{$column} ? sql_and([$total_range_condition{$column}, $condition]) 44 | : $condition; 45 | } 46 | } 47 | 48 | return %total_range_condition ? \%total_range_condition : undef; 49 | } 50 | 51 | 1; 52 | __END__ 53 | 54 | =pod 55 | 56 | =encoding utf-8 57 | 58 | =head1 NAME 59 | 60 | Aniki::Plugin::RangeConditionMaker - range condition maker 61 | 62 | =head1 SYNOPSIS 63 | 64 | package MyDB; 65 | use Mouse v2.4.5; 66 | extends qw/Aniki/; 67 | with qw/Aniki::Plugin::RangeConditionMaker/; 68 | 69 | package main; 70 | my $db = MyDB->new(...); 71 | 72 | my $where = $db->make_range_condition({ upper => { id => 10 } }); 73 | # => { id => { '<' => 10 } } 74 | $where = $db->make_range_condition({ lower => { id => 0 } }); 75 | # => { id => { '>' => 0 } } 76 | $where = $db->make_range_condition({ le => { id => 10 } }); 77 | # => { id => { '<=' => 10 } } 78 | $where = $db->make_range_condition({ ge => { id => 0 } }); 79 | # => { id => { '>=' => 0 } } 80 | $where = $db->make_range_condition({ upper => { id => 10 }, lower => { id => 0 } }); 81 | # => { id => [-and => { '>' => 0 }, { '<' => 10 }] } 82 | 83 | =head1 LICENSE 84 | 85 | Copyright (C) karupanerura. 86 | 87 | This library is free software; you can redistribute it and/or modify 88 | it under the same terms as Perl itself. 89 | 90 | =head1 AUTHOR 91 | 92 | karupanerura Ekarupa@cpan.orgE 93 | 94 | =cut 95 | -------------------------------------------------------------------------------- /t/15_update_and_emulate_row.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | 7 | use File::Spec; 8 | use lib File::Spec->catfile('t', 'lib'); 9 | use t::Util; 10 | 11 | run_on_database { 12 | my $row = db->insert_and_fetch_row(author => { name => 'MOZNION' }); 13 | subtest 'assert default (in|de)flate_message' => sub { 14 | is $row->inflate_message, 'inflate hello', 'inflated: inflate_message'; 15 | is $row->deflate_message, 'hello', 'inflated: deflate_message'; 16 | is $row->get_column('inflate_message'), 'hello', 'raw: inflate_message'; 17 | is $row->get_column('deflate_message'), 'hello', 'raw: deflate_message'; 18 | }; 19 | 20 | subtest 'croak' => sub { 21 | my ($line, $file); 22 | eval { 23 | ($line, $file) = (__LINE__, __FILE__); db->update_and_emulate_row(undef, +{ name => 'MACKEE' }); 24 | }; 25 | like $@, qr/^\Q(Aniki#update_and_emulate_row) condition must be a Aniki::Row object. at $file line $line/m, 'croak from update_and_emulate_row'; 26 | 27 | eval { 28 | ($line, $file) = (__LINE__, __FILE__); db->update_and_emulate_row($row, {}); 29 | }; 30 | like $@, qr/^\Q(Aniki#update) `set` is required for update ("SET" parameter) at $file line $line/m, 'croak from update'; 31 | }; 32 | 33 | subtest 'emulate new row' => sub { 34 | local db->{suppress_row_objects} = 1; 35 | my $new_row = db->update_and_emulate_row($row, +{ name => 'PAPIX' }); 36 | isa_ok $new_row, 'HASH'; 37 | is $new_row->{$_}, $row->get_column($_), "raw: $_" for grep { $_ ne 'name' } db->schema->get_table('author')->field_names; 38 | is $new_row->{name}, 'PAPIX', 'raw: name'; 39 | }; 40 | $row = $row->refetch; 41 | 42 | subtest 'emulate new row object' => sub { 43 | my $new_row = db->update_and_emulate_row($row, +{ name => 'KARUPA' }); 44 | isa_ok $new_row, 'Aniki::Row'; 45 | is_deeply $new_row->get_columns, { 46 | %{ $row->get_columns }, 47 | name => 'KARUPA', 48 | }, 'raw: @columuns'; 49 | is $new_row->$_, $row->$_, "inflated: $_" for grep { $_ ne 'name' } db->schema->get_table('author')->field_names; 50 | is $new_row->name, 'KARUPA', 'inflated: name'; 51 | $row = $new_row; 52 | }; 53 | 54 | subtest 'emulate inflate/deflate' => sub { 55 | my $new_row = db->update_and_emulate_row($row, +{ inflate_message => 'hello world', deflate_message => 'hello world' }); 56 | is $new_row->inflate_message, 'inflate hello world', 'inflated: inflate_message'; 57 | is $new_row->deflate_message, 'deflate hello world', 'inflated: deflate_message'; 58 | is $new_row->get_column('inflate_message'), 'hello world', 'raw: inflate_message'; 59 | is $new_row->get_column('deflate_message'), 'deflate hello world', 'raw: deflate_message'; 60 | }; 61 | }; 62 | 63 | done_testing(); 64 | -------------------------------------------------------------------------------- /t/plugin/pager/select_with_pager.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | 7 | use File::Spec; 8 | use lib File::Spec->catfile('t', 'lib'); 9 | use Mouse::Util; 10 | use Aniki::Plugin::Pager; 11 | use t::Util; 12 | 13 | run_on_database { 14 | Mouse::Util::apply_all_roles(db, 'Aniki::Plugin::Pager'); 15 | 16 | db->insert_multi(author => [map { 17 | +{ name => $_ } 18 | } qw/MOZNION KARUPA PAPIX/]); 19 | 20 | subtest 'ASC' => sub { 21 | my $rows = db->select_with_pager(author => {}, { rows => 2, page => 1, order_by => { id => 'ASC' } }); 22 | isa_ok $rows, 'Aniki::Result::Collection'; 23 | ok $rows->meta->does_role('Aniki::Result::Role::Pager'); 24 | is $rows->count, 2; 25 | 26 | isa_ok $rows->pager, 'Data::Page::NoTotalEntries'; 27 | is $rows->pager->current_page, 1; 28 | ok $rows->pager->has_next; 29 | 30 | $rows = db->select_with_pager(author => {}, { rows => 2, page => 2, order_by => { id => 'ASC' } }); 31 | isa_ok $rows, 'Aniki::Result::Collection'; 32 | ok $rows->meta->does_role('Aniki::Result::Role::Pager'); 33 | is $rows->count, 1; 34 | is $rows->first->id, 3; 35 | 36 | isa_ok $rows->pager, 'Data::Page::NoTotalEntries'; 37 | is $rows->pager->current_page, 2; 38 | ok !$rows->pager->has_next; 39 | 40 | $rows = db->select_with_pager(author => {}, { rows => 2, page => 2, order_by => { id => 'ASC' }, lower => { id => 2 } }); 41 | isa_ok $rows, 'Aniki::Result::Collection'; 42 | ok $rows->meta->does_role('Aniki::Result::Role::Pager'); 43 | is $rows->count, 1; 44 | is $rows->first->id, 3; 45 | 46 | isa_ok $rows->pager, 'Data::Page::NoTotalEntries'; 47 | is $rows->pager->current_page, 2; 48 | ok !$rows->pager->has_next; 49 | }; 50 | 51 | subtest 'DESC' => sub { 52 | my $rows = db->select_with_pager(author => {}, { rows => 2, page => 1, order_by => { id => 'DESC' } }); 53 | isa_ok $rows, 'Aniki::Result::Collection'; 54 | ok $rows->meta->does_role('Aniki::Result::Role::Pager'); 55 | is $rows->count, 2; 56 | is $rows->first->id, 3; 57 | 58 | isa_ok $rows->pager, 'Data::Page::NoTotalEntries'; 59 | is $rows->pager->current_page, 1; 60 | ok $rows->pager->has_next; 61 | 62 | $rows = db->select_with_pager(author => {}, { rows => 2, page => 2, order_by => { id => 'DESC' } }); 63 | isa_ok $rows, 'Aniki::Result::Collection'; 64 | ok $rows->meta->does_role('Aniki::Result::Role::Pager'); 65 | is $rows->count, 1; 66 | is $rows->first->id, 1; 67 | 68 | isa_ok $rows->pager, 'Data::Page::NoTotalEntries'; 69 | is $rows->pager->current_page, 2; 70 | ok !$rows->pager->has_next; 71 | 72 | $rows = db->select_with_pager(author => {}, { rows => 2, page => 2, order_by => { id => 'DESC' }, upper => { id => 2 } }); 73 | isa_ok $rows, 'Aniki::Result::Collection'; 74 | ok $rows->meta->does_role('Aniki::Result::Role::Pager'); 75 | is $rows->count, 1; 76 | is $rows->first->id, 1; 77 | 78 | isa_ok $rows->pager, 'Data::Page::NoTotalEntries'; 79 | is $rows->pager->current_page, 2; 80 | ok !$rows->pager->has_next; 81 | }; 82 | }; 83 | 84 | done_testing(); 85 | -------------------------------------------------------------------------------- /lib/Aniki/Schema/Relationship/Declare.pm: -------------------------------------------------------------------------------- 1 | package Aniki::Schema::Relationship::Declare; 2 | use 5.014002; 3 | 4 | use strict; 5 | use warnings; 6 | 7 | use B::Hooks::EndOfScope; 8 | use DBIx::Schema::DSL (); 9 | use Aniki::Schema::Relationship; 10 | 11 | my %RULES; 12 | 13 | sub import { 14 | my $caller = caller; 15 | { 16 | no strict qw/refs/; 17 | *{"${caller}::relationship_rules"} = sub { $RULES{$caller} }; 18 | *{"${caller}::relation"} = \&_relation; 19 | *{"${caller}::relay_to"} = \&_relay_to; 20 | *{"${caller}::relay_by"} = \&_relay_by; 21 | } 22 | on_scope_end { 23 | no strict qw/refs/; 24 | no warnings qw/redefine/; 25 | *{"${caller}::create_table"} = \&_create_table; 26 | }; 27 | } 28 | 29 | my %TABLE_NAME; 30 | 31 | sub _create_table ($$) {## no critic 32 | my ($table_name, $code) = @_; 33 | my $caller = caller; 34 | $TABLE_NAME{$caller} = $table_name; 35 | goto \&DBIx::Schema::DSL::create_table; 36 | } 37 | 38 | sub _relation { 39 | my ($src_columns, $dest_table_name, $dest_columns, %opt) = @_; 40 | my $caller = caller; 41 | my $src_table_name = $TABLE_NAME{$caller}; 42 | push @{ $RULES{$caller} } => { 43 | src_table_name => $src_table_name, 44 | src_columns => $src_columns, 45 | dest_table_name => $dest_table_name, 46 | dest_columns => $dest_columns, 47 | %opt, 48 | }; 49 | } 50 | 51 | sub _relay_to { 52 | my $dest_table_name = shift; 53 | my $caller = caller; 54 | my $src_columns = ["${dest_table_name}_id"]; 55 | my $dest_columns = ['id']; 56 | @_ = ($src_columns, $dest_table_name, $dest_columns, @_); 57 | goto \&_relation; 58 | } 59 | 60 | sub _relay_by { 61 | my $dest_table_name = shift; 62 | my $caller = caller; 63 | my $src_table_name = $TABLE_NAME{$caller}; 64 | my $src_columns = ['id']; 65 | my $dest_columns = ["${src_table_name}_id"]; 66 | @_ = ($src_columns, $dest_table_name, $dest_columns, @_); 67 | goto \&_relation; 68 | } 69 | 70 | 1; 71 | __END__ 72 | 73 | =pod 74 | 75 | =encoding utf-8 76 | 77 | =head1 NAME 78 | 79 | Aniki::Schema::Relationship::Declare - DSL for declaring relationship rules 80 | 81 | =head1 SYNOPSIS 82 | 83 | use 5.014002; 84 | package MyProj::DB::Schema { 85 | use DBIx::Schema::DSL; 86 | use Aniki::Schema::Relationship::Declare; 87 | 88 | create_table 'module' => columns { 89 | integer 'id', primary_key, auto_increment; 90 | varchar 'name'; 91 | integer 'author_id'; 92 | 93 | add_index 'author_id_idx' => ['author_id']; 94 | 95 | relay_to 'author', name => ''; 96 | }; 97 | 98 | create_table 'author' => columns { 99 | integer 'id', primary_key, auto_increment; 100 | varchar 'name', unique; 101 | 102 | relay_by 'module'; 103 | }; 104 | }; 105 | 106 | 1; 107 | 108 | =head1 FUNCTIONS 109 | 110 | =over 4 111 | 112 | =item C 113 | 114 | =item C 115 | 116 | =item C 117 | 118 | =back 119 | 120 | =head1 SEE ALSO 121 | 122 | L 123 | 124 | =head1 LICENSE 125 | 126 | Copyright (C) karupanerura. 127 | 128 | This library is free software; you can redistribute it and/or modify 129 | it under the same terms as Perl itself. 130 | 131 | =head1 AUTHOR 132 | 133 | karupanerura Ekarupa@cpan.orgE 134 | 135 | =cut 136 | -------------------------------------------------------------------------------- /lib/Aniki/Schema/Table.pm: -------------------------------------------------------------------------------- 1 | package Aniki::Schema::Table; 2 | use 5.014002; 3 | 4 | use namespace::autoclean; 5 | use Mouse v2.4.5; 6 | use Carp qw/croak/; 7 | use Aniki::Schema::Relationships; 8 | use Aniki::Schema::Table::Field; 9 | use Aniki::Schema::Table::PrimaryKey; 10 | use SQL::Translator::Schema::Constants; 11 | 12 | has _schema => ( 13 | is => 'ro', 14 | required => 1, 15 | weak_ref => 1, 16 | ); 17 | 18 | has _table => ( 19 | is => 'ro', 20 | required => 1, 21 | ); 22 | 23 | has name => ( 24 | is => 'ro', 25 | default => sub { shift->_table->name }, 26 | ); 27 | 28 | has relationships => ( 29 | is => 'ro', 30 | default => \&_setup_relationships, 31 | ); 32 | 33 | has primary_key => ( 34 | is => 'ro', 35 | default => sub { 36 | my $self = shift; 37 | if (my $primary_key = $self->_table->primary_key) { 38 | return Aniki::Schema::Table::PrimaryKey->new($primary_key); 39 | } 40 | return undef; 41 | }, 42 | ); 43 | 44 | has _fields_cache => ( 45 | is => 'ro', 46 | default => sub { 47 | my $self = shift; 48 | return [ 49 | map { Aniki::Schema::Table::Field->new($_) } $self->_table->get_fields 50 | ] 51 | }, 52 | ); 53 | 54 | has _field_names => ( 55 | is => 'ro', 56 | default => sub { 57 | my $self = shift; 58 | return [map { $_->name } @{ $self->_fields_cache }]; 59 | }, 60 | ); 61 | 62 | has _fields_map_cache => ( 63 | is => 'ro', 64 | default => sub { 65 | my $self = shift; 66 | return { 67 | map { $_->name => $_ } @{ $self->_fields_cache } 68 | } 69 | }, 70 | ); 71 | 72 | sub BUILDARGS { 73 | my ($class, $table, $schema) = @_; 74 | return $class->SUPER::BUILDARGS(_table => $table, _schema => $schema); 75 | } 76 | 77 | sub get_fields { @{ shift->_fields_cache } } 78 | 79 | sub field_names { wantarray ? @{ shift->_field_names } : [@{ shift->_field_names }] } 80 | 81 | sub get_field { 82 | my ($self, $name) = @_; 83 | return unless exists $self->_fields_map_cache->{$name}; 84 | return $self->_fields_map_cache->{$name} 85 | } 86 | 87 | sub get_relationships { shift->relationships } 88 | 89 | sub _setup_relationships { 90 | my $self = shift; 91 | 92 | my @constraints = grep { $_->type eq FOREIGN_KEY } $self->get_constraints; 93 | for my $table ($self->_schema->context->schema->get_tables) { 94 | for my $constraint ($table->get_constraints) { 95 | next if $constraint->type ne FOREIGN_KEY; 96 | next if $constraint->reference_table ne $self->name; 97 | push @constraints => $constraint; 98 | } 99 | } 100 | 101 | my $relationships = Aniki::Schema::Relationships->new(schema => $self->_schema, table => $self); 102 | for my $constraint (@constraints) { 103 | $relationships->add_by_constraint($constraint); 104 | } 105 | 106 | if ($self->_schema->schema_class->can('relationship_rules')) { 107 | my $rules = $self->_schema->schema_class->relationship_rules; 108 | for my $rule (@$rules) { 109 | next if $rule->{src_table_name} ne $self->_table->name; 110 | $relationships->add(%$rule); 111 | } 112 | } 113 | 114 | return $relationships; 115 | } 116 | 117 | our $AUTOLOAD; 118 | sub AUTOLOAD { 119 | my $self = shift; 120 | my $method = $AUTOLOAD =~ s/^.*://r; 121 | if ($self->_table->can($method)) { 122 | return $self->_table->$method(@_); 123 | } 124 | 125 | my $class = ref $self; 126 | croak qq{Can't locate object method "$method" via package "$class"}; 127 | } 128 | 129 | __PACKAGE__->meta->make_immutable(); 130 | __END__ 131 | -------------------------------------------------------------------------------- /lib/Aniki/Schema/Relationship.pm: -------------------------------------------------------------------------------- 1 | package Aniki::Schema::Relationship; 2 | use 5.014002; 3 | 4 | use namespace::autoclean; 5 | use Mouse v2.4.5; 6 | use Aniki::Schema::Relationship::Fetcher; 7 | use Lingua::EN::Inflect qw/PL/; 8 | use Hash::Util::FieldHash qw/fieldhash/; 9 | 10 | our @WORD_SEPARATORS = ('-', '_', ' '); 11 | 12 | has schema => ( 13 | is => 'ro', 14 | required => 1, 15 | weak_ref => 1, 16 | ); 17 | 18 | has src_table_name => ( 19 | is => 'ro', 20 | required => 1, 21 | ); 22 | 23 | has src_columns => ( 24 | is => 'ro', 25 | required => 1, 26 | ); 27 | 28 | has dest_table_name => ( 29 | is => 'ro', 30 | required => 1, 31 | ); 32 | 33 | has dest_columns => ( 34 | is => 'ro', 35 | required => 1, 36 | ); 37 | 38 | has has_many => ( 39 | is => 'ro', 40 | default => sub { 41 | my $self = shift; 42 | return $self->schema->has_many($self->dest_table_name, $self->dest_columns); 43 | }, 44 | ); 45 | 46 | has name => ( 47 | is => 'ro', 48 | default => \&_guess_name, 49 | ); 50 | 51 | has fetcher => ( 52 | is => 'ro', 53 | default => sub { Aniki::Schema::Relationship::Fetcher->new(relationship => $_[0]) }, 54 | ); 55 | 56 | sub _guess_name { 57 | my $self = shift; 58 | 59 | my @src_columns = @{ $self->src_columns }; 60 | my @dest_columns = @{ $self->dest_columns }; 61 | my $src_table_name = $self->src_table_name; 62 | my $dest_table_name = $self->dest_table_name; 63 | 64 | my $prefix = (@src_columns == 1 && $src_columns[0] =~ /^(.+)_\Q$dest_table_name/) ? $1.'_' : 65 | (@dest_columns == 1 && $dest_columns[0] =~ /^(.+)_\Q$src_table_name/) ? $1.'_' : 66 | ''; 67 | 68 | my $name = $self->has_many ? _to_plural($dest_table_name) : $dest_table_name; 69 | return $prefix . $name; 70 | } 71 | 72 | sub _to_plural { 73 | my $words = shift; 74 | my $sep = join '|', map quotemeta, @WORD_SEPARATORS; 75 | return $words =~ s/(?<=$sep)(.+?)$/PL($1)/er if $words =~ /$sep/; 76 | return PL($words); 77 | } 78 | 79 | sub get_inverse_relationships { 80 | my $self = shift; 81 | return @{ $self->{__inverse_relationships} } if exists $self->{__inverse_relationships}; 82 | 83 | my @inverse_relationships = $self->_get_inverse_relationships; 84 | $self->{__inverse_relationships} = \@inverse_relationships; 85 | return @inverse_relationships; 86 | } 87 | 88 | sub _get_inverse_relationships { 89 | my $self = shift; 90 | 91 | my @relationships; 92 | for my $dest ($self->schema->get_table($self->dest_table_name)->get_relationships->all) { 93 | next if $dest->dest_table_name ne $self->src_table_name; 94 | next if not _cmp_deeply($dest->dest_columns, $self->src_columns); 95 | next if not _cmp_deeply($dest->src_columns, $self->dest_columns); 96 | push @relationships => $dest; 97 | } 98 | 99 | return @relationships; 100 | } 101 | 102 | sub _cmp_deeply { 103 | my ($l, $r) = @_; 104 | return $l eq $r if not ref $l or not ref $r; 105 | return !!0 if ref $l ne ref $r; 106 | 107 | if (ref $l eq 'HASH') { 108 | for my $k (keys %$l) { 109 | return !!0 if not exists $r->{$k}; 110 | return !!0 if not _cmp_deeply($l->{$k}, $r->{$k}); 111 | } 112 | for my $k (keys %$r) { 113 | return !!0 if not exists $l->{$k}; 114 | } 115 | return !!1; 116 | } 117 | elsif (ref $l eq 'ARRAY') { 118 | return !!0 if @$l != @$r; 119 | for my $i (0..$#{$l}) { 120 | return !!0 if not _cmp_deeply($l->[$i], $r->[$i]); 121 | } 122 | return !!1; 123 | } 124 | 125 | die "Unknwon case: $l cmp $r"; 126 | } 127 | 128 | __PACKAGE__->meta->make_immutable(); 129 | __END__ 130 | -------------------------------------------------------------------------------- /lib/Aniki/Filter/Declare.pm: -------------------------------------------------------------------------------- 1 | package Aniki::Filter::Declare; 2 | use 5.014002; 3 | 4 | use strict; 5 | use warnings; 6 | 7 | use Aniki::Filter; 8 | 9 | sub import { 10 | my $class = shift; 11 | my $caller = caller; 12 | 13 | my $filter = Aniki::Filter->new; 14 | 15 | no strict qw/refs/; ## no critic 16 | *{"${caller}::table"} = \&_table; 17 | *{"${caller}::inflate"} = _inflate($filter); 18 | *{"${caller}::deflate"} = _deflate($filter); 19 | *{"${caller}::trigger"} = _trigger($filter); 20 | *{"${caller}::instance"} = _instance($filter); 21 | } 22 | 23 | our $TARGET_TABLE; 24 | 25 | sub _table ($&) {## no critic 26 | my ($table, $code) = @_; 27 | local $TARGET_TABLE = $table; 28 | $code->(); 29 | } 30 | 31 | sub _inflate { 32 | my $filter = shift; 33 | return sub ($&) {## no critic 34 | my ($column, $code) = @_; 35 | if (defined $TARGET_TABLE) { 36 | $filter->add_table_inflator($TARGET_TABLE, $column, $code); 37 | } 38 | else { 39 | $filter->add_global_inflator($column, $code); 40 | } 41 | }; 42 | } 43 | 44 | sub _deflate { 45 | my $filter = shift; 46 | sub ($&) {## no critic 47 | my ($column, $code) = @_; 48 | if (defined $TARGET_TABLE) { 49 | $filter->add_table_deflator($TARGET_TABLE, $column, $code); 50 | } 51 | else { 52 | $filter->add_global_deflator($column, $code); 53 | } 54 | }; 55 | } 56 | 57 | sub _trigger { 58 | my $filter = shift; 59 | sub ($&) {## no critic 60 | my ($event, $code) = @_; 61 | if (defined $TARGET_TABLE) { 62 | $filter->add_table_trigger($TARGET_TABLE, $event, $code); 63 | } 64 | else { 65 | $filter->add_global_trigger($event, $code); 66 | } 67 | }; 68 | } 69 | 70 | sub _instance { 71 | my $filter = shift; 72 | return sub { $filter }; 73 | } 74 | 75 | 1; 76 | __END__ 77 | 78 | =pod 79 | 80 | =encoding utf-8 81 | 82 | =head1 NAME 83 | 84 | Aniki::Filter::Declare - DSL for declaring actions on sometimes 85 | 86 | =head1 SYNOPSIS 87 | 88 | package MyApp::DB::Filter; 89 | use strict; 90 | use warnings; 91 | 92 | use Aniki::Filter::Declare; 93 | 94 | use Scalar::Util qw/blessed/; 95 | use Time::Moment; 96 | use Data::GUID::URLSafe; 97 | 98 | # apply callback to row before insert 99 | trigger insert => sub { 100 | my ($row, $next) = @_; 101 | $row->{created_at} = Time::Moment->now; 102 | return $next->($row); 103 | }; 104 | 105 | # define trigger/inflate/deflate filters in table context. 106 | table author => sub { 107 | trigger insert => sub { 108 | my ($row, $next) = @_; 109 | $row->{guid} = Data::GUID->new->as_base64_urlsafe; 110 | return $next->($row); 111 | }; 112 | 113 | inflate name => sub { 114 | my $name = shift; 115 | return uc $name; 116 | }; 117 | 118 | deflate name => sub { 119 | my $name = shift; 120 | return lc $name; 121 | }; 122 | }; 123 | 124 | # define inflate/deflate filters in global context. (apply to all tables) 125 | inflate qr/_at$/ => sub { 126 | my $datetime = shift; 127 | return Time::Moment->from_string($datetime.'Z', lenient => 1); 128 | }; 129 | 130 | deflate qr/_at$/ => sub { 131 | my $datetime = shift; 132 | return $datetime->at_utc->strftime('%F %T') if blessed $datetime and $datetime->isa('Time::Moment'); 133 | return $datetime; 134 | }; 135 | 136 | =head1 FUNCTIONS 137 | 138 | =over 4 139 | 140 | =item C 141 | 142 | =item C 143 | 144 | =item C 145 | 146 | =item C 147 | 148 | =back 149 | 150 | =head1 SEE ALSO 151 | 152 | L 153 | 154 | =head1 LICENSE 155 | 156 | Copyright (C) karupanerura. 157 | 158 | This library is free software; you can redistribute it and/or modify 159 | it under the same terms as Perl itself. 160 | 161 | =head1 AUTHOR 162 | 163 | karupanerura Ekarupa@cpan.orgE 164 | 165 | =cut 166 | -------------------------------------------------------------------------------- /lib/Aniki/Handler/WeightedRoundRobin.pm: -------------------------------------------------------------------------------- 1 | package Aniki::Handler::WeightedRoundRobin; 2 | use 5.014002; 3 | 4 | use namespace::autoclean; 5 | use Mouse; 6 | extends qw/Aniki::Handler/; 7 | 8 | use DBI (); 9 | use Data::WeightedRoundRobin; 10 | use Scalar::Util qw/refaddr/; 11 | 12 | around BUILDARGS => sub { 13 | my $orig = shift; 14 | my $self = shift; 15 | my %args = (@_ == 1 && ref $_[0] eq 'HASH') ? %{$_[0]} : @_; 16 | 17 | my $connect_info = delete $args{connect_info}; 18 | my $rr = Data::WeightedRoundRobin->new([ 19 | map { 20 | +{ 21 | %$_, 22 | key => refaddr($_->{value}), 23 | } 24 | } @$connect_info 25 | ]); 26 | return $self->$orig(rr => $rr); 27 | }; 28 | 29 | has rr => ( 30 | is => 'ro', 31 | required => 1, 32 | ); 33 | 34 | has '+connect_info' => ( 35 | is => 'rw', 36 | required => 0, 37 | lazy => 1, 38 | builder => sub { shift->rr->next }, 39 | clearer => '_reset_connect_info', 40 | ); 41 | 42 | sub is_connect_error { 43 | my ($self, $e) = @_; 44 | my ($dsn) = @{ $self->connect_info }; 45 | my (undef, $driver) = DBI->parse_dsn($dsn); 46 | 47 | if ($driver eq 'mysql') { 48 | return $e =~ /\Qfailed: Can't connect to MySQL server on/m; 49 | } 50 | elsif ($driver eq 'Pg') { 51 | return $e =~ /\Qfailed: could not connect to server: Connection refused/m; 52 | } 53 | elsif ($driver eq 'Oracle') { 54 | # TODO: patches wellcome :p 55 | } 56 | 57 | warn "Unsupported dirver: $driver"; 58 | return 0; 59 | } 60 | 61 | sub disconnect { 62 | my $self = shift; 63 | $self->_reset_connect_info(); 64 | $self->SUPER::disconnect(); 65 | } 66 | 67 | my %NO_OVERRIDE_PROXY_METHODS = ( 68 | trace_query_set_comment => 1, 69 | in_txn => 1, 70 | ); 71 | 72 | for my $name (grep { !$NO_OVERRIDE_PROXY_METHODS{$_} } __PACKAGE__->_proxy_methods) { 73 | # override 74 | __PACKAGE__->meta->add_method($name => sub { 75 | my $self = shift; 76 | my $wantarray = wantarray; 77 | 78 | # context proxy 79 | my @ret; 80 | my $e = do { 81 | local $@; 82 | 83 | if (not defined $wantarray) { 84 | eval { $self->handler->$name(@_) }; 85 | } 86 | elsif ($wantarray) { 87 | @ret = eval { $self->handler->$name(@_) }; 88 | } 89 | else { 90 | $ret[0] = eval { $self->handler->$name(@_) }; 91 | } 92 | 93 | $@; 94 | }; 95 | 96 | if ($e) { 97 | my $key = refaddr($self->connect_info); 98 | if ($self->is_connect_error($e) && !$self->handler->in_txn) { 99 | $self->disconnect; 100 | 101 | # retry 102 | my $guard = $self->rr->save; 103 | $self->rr->remove($key); 104 | if ($self->rr->next) { 105 | warn "RETRY: $e"; 106 | return $self->$name(@_); 107 | } 108 | } 109 | die $e; 110 | } 111 | 112 | return $wantarray ? @ret : $ret[0]; 113 | }); 114 | } 115 | 116 | __PACKAGE__->meta->make_immutable(); 117 | __END__ 118 | 119 | =pod 120 | 121 | =encoding utf-8 122 | 123 | =head1 NAME 124 | 125 | Aniki::Handler::RoundRobin - Round robin database handler manager 126 | 127 | =head1 METHODS 128 | 129 | =head2 CLASS METHODS 130 | 131 | =head3 C 132 | 133 | Create instance of Aniki::Handler. 134 | 135 | =head4 Arguments 136 | 137 | =over 4 138 | 139 | =item C 140 | 141 | Auguments for L's C method. 142 | 143 | Example: 144 | 145 | [ 146 | { 147 | value => [...], # Auguments for DBI's connect method. 148 | weight => 10, 149 | }, 150 | ] 151 | 152 | =item on_connect_do : CodeRef|ArrayRef[Str]|Str 153 | =item on_disconnect_do : CodeRef|ArrayRef[Str]|Str 154 | 155 | Execute SQL or CodeRef when connected/disconnected. 156 | 157 | =back 158 | -------------------------------------------------------------------------------- /META.json: -------------------------------------------------------------------------------- 1 | { 2 | "abstract" : "The ORM as our great brother.", 3 | "author" : [ 4 | "karupanerura " 5 | ], 6 | "dynamic_config" : 0, 7 | "generated_by" : "Minilla/v3.1.1, CPAN::Meta::Converter version 2.150010", 8 | "license" : [ 9 | "perl_5" 10 | ], 11 | "meta-spec" : { 12 | "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", 13 | "version" : 2 14 | }, 15 | "name" : "Aniki", 16 | "no_index" : { 17 | "directory" : [ 18 | "t", 19 | "xt", 20 | "inc", 21 | "share", 22 | "eg", 23 | "examples", 24 | "author", 25 | "builder" 26 | ] 27 | }, 28 | "prereqs" : { 29 | "configure" : { 30 | "requires" : { 31 | "Module::Build::Tiny" : "0.035" 32 | } 33 | }, 34 | "develop" : { 35 | "requires" : { 36 | "DBIx::Class::Core" : "0", 37 | "DBIx::Class::Schema" : "0", 38 | "Teng" : "0", 39 | "Teng::Schema::Declare" : "0", 40 | "Test::CPAN::Meta" : "0", 41 | "Test::MinimumVersion::Fast" : "0.04", 42 | "Test::PAUSE::Permissions" : "0.04", 43 | "Test::Pod" : "1.41", 44 | "Test::Spellunker" : "v0.2.7", 45 | "Time::Moment" : "0" 46 | } 47 | }, 48 | "runtime" : { 49 | "recommends" : { 50 | "Data::WeightedRoundRobin" : "0", 51 | "SQL::Maker::Plugin::JoinSelect" : "0" 52 | }, 53 | "requires" : { 54 | "B::Hooks::EndOfScope" : "0", 55 | "Class::Inspector" : "0", 56 | "DBI" : "0", 57 | "DBIx::Handler" : "0.12", 58 | "DBIx::Schema::DSL" : "0", 59 | "Data::Page::NoTotalEntries" : "0", 60 | "Data::Section::Simple" : "0", 61 | "File::Path" : "0", 62 | "Getopt::Long" : "0", 63 | "Hash::Util::FieldHash" : "0", 64 | "Lingua::EN::Inflect" : "0", 65 | "List::MoreUtils" : "0", 66 | "List::UtilsBy" : "0", 67 | "Module::Load" : "0", 68 | "Mouse" : "v2.4.5", 69 | "Mouse::Role" : "0", 70 | "Mouse::Util::TypeConstraints" : "0", 71 | "SQL::Maker" : "1.19", 72 | "SQL::Maker::SQLType" : "0", 73 | "SQL::NamedPlaceholder" : "0", 74 | "SQL::QueryMaker" : "0", 75 | "SQL::Translator::Schema::Constants" : "0", 76 | "Scalar::Util" : "0", 77 | "String::CamelCase" : "0", 78 | "Try::Tiny" : "0", 79 | "namespace::autoclean" : "0", 80 | "parent" : "0", 81 | "perl" : "5.014002" 82 | } 83 | }, 84 | "test" : { 85 | "recommends" : { 86 | "DBD::Pg" : "0", 87 | "DBD::mysql" : "0", 88 | "Test::PostgreSQL" : "0", 89 | "Test::mysqld" : "0" 90 | }, 91 | "requires" : { 92 | "DBD::SQLite" : "0", 93 | "List::Util" : "0", 94 | "Mouse::Util" : "0", 95 | "Test::Builder" : "0", 96 | "Test::Builder::Module" : "0", 97 | "Test::More" : "0.98", 98 | "Test::Requires" : "0", 99 | "feature" : "0" 100 | } 101 | } 102 | }, 103 | "release_status" : "unstable", 104 | "resources" : { 105 | "bugtracker" : { 106 | "web" : "https://github.com/karupanerura/Aniki/issues" 107 | }, 108 | "homepage" : "https://github.com/karupanerura/Aniki", 109 | "repository" : { 110 | "type" : "git", 111 | "url" : "git://github.com/karupanerura/Aniki.git", 112 | "web" : "https://github.com/karupanerura/Aniki" 113 | } 114 | }, 115 | "version" : "1.06", 116 | "x_authority" : "cpan:KARUPA", 117 | "x_contributors" : [ 118 | "Pine Mizune ", 119 | "Syohei YOSHIDA ", 120 | "mamimumemoomoo ", 121 | "watanabe-yocihi " 122 | ], 123 | "x_serialization_backend" : "JSON::PP version 2.97001", 124 | "x_static_install" : 1 125 | } 126 | -------------------------------------------------------------------------------- /lib/Aniki/Result/Collection/Joined.pm: -------------------------------------------------------------------------------- 1 | package Aniki::Result::Collection::Joined; 2 | use 5.014002; 3 | 4 | use namespace::autoclean; 5 | use Mouse v2.4.5; 6 | extends qw/Aniki::Result::Collection/; 7 | 8 | use Carp qw/croak/; 9 | use Aniki::Row::Joined; 10 | use List::MoreUtils qw/none/; 11 | use List::UtilsBy qw/uniq_by/; 12 | use Scalar::Util qw/refaddr/; 13 | 14 | has '+table_name' => ( 15 | required => 0, 16 | lazy => 1, 17 | default => sub { join ',', @{ $_[0]->table_names } } 18 | ); 19 | 20 | has '+row_class' => ( 21 | lazy => 1, 22 | default => sub { croak 'Cannot get row class of '.__PACKAGE__.'. Use row_classes instead of row_class.' }, 23 | ); 24 | 25 | has table_names => ( 26 | is => 'ro', 27 | required => 1, 28 | ); 29 | 30 | has _compact_row_datas => ( 31 | is => 'ro', 32 | lazy => 1, 33 | builder => '_compress', 34 | ); 35 | 36 | has _subresult_cache => ( 37 | is => 'ro', 38 | default => sub { 39 | my $self = shift; 40 | return +{ 41 | map { $_ => undef } @{ $self->table_names }, 42 | }; 43 | }, 44 | ); 45 | 46 | sub row_classes { 47 | my $self = shift; 48 | return map { $self->handler->guess_row_class($_) } @{ $self->table_names }; 49 | } 50 | 51 | sub rows { 52 | my $self = shift; 53 | if (@_ == 1) { 54 | my $table_name = shift; 55 | return $self->subresult($table_name)->rows(); 56 | } 57 | return $self->SUPER::rows(); 58 | } 59 | 60 | sub subresult { 61 | my ($self, $table_name) = @_; 62 | return $self->_subresult_cache->{$table_name} if $self->_subresult_cache->{$table_name}; 63 | 64 | my $result_class = $self->handler->guess_result_class($table_name); 65 | return $self->_subresult_cache->{$table_name} = $result_class->new( 66 | table_name => $table_name, 67 | handler => $self->handler, 68 | row_datas => [uniq_by { refaddr $_ } map { $_->{$table_name} } @{ $self->_compact_row_datas() }], 69 | !$self->suppress_row_objects ? ( 70 | inflated_rows => [uniq_by { refaddr $_ } map { $_->$table_name } @{ $self->inflated_rows() }], 71 | ) : (), 72 | suppress_row_objects => $self->suppress_row_objects, 73 | ); 74 | } 75 | 76 | sub _uniq_key { 77 | my ($row_data, $pk) = @_; 78 | return if none { defined $row_data->{$_} } @$pk; 79 | return join '|', map { quotemeta $row_data->{$_} } @$pk; 80 | } 81 | 82 | sub _compress { 83 | my $self = shift; 84 | my $handler = $self->handler; 85 | 86 | my @table_names = @{ $self->table_names }; 87 | my %pk = map { 88 | $_ => [map { $_->name } $handler->schema->get_table($_)->primary_key->fields] 89 | } @table_names; 90 | 91 | my @rows; 92 | my %cache; 93 | for my $row (@{ $self->row_datas }) { 94 | my %rows; 95 | 96 | for my $table_name (@table_names) { 97 | my $row_data = $row->{$table_name}; 98 | my $uniq_key = _uniq_key($row_data, $pk{$table_name}); 99 | $rows{$table_name} = defined $uniq_key ? ($cache{$table_name}{$uniq_key} //= $row_data) : $row_data; 100 | } 101 | 102 | push @rows => \%rows; 103 | } 104 | 105 | return \@rows; 106 | } 107 | 108 | sub _inflate { 109 | my $self = shift; 110 | my $handler = $self->handler; 111 | 112 | my @table_names = @{ $self->table_names }; 113 | my %row_class = map { $_ => $handler->guess_row_class($_) } @table_names; 114 | 115 | my @rows; 116 | my %cache; 117 | for my $row (@{ $self->_compact_row_datas }) { 118 | my %rows; 119 | 120 | # inflate to row class 121 | for my $table_name (@table_names) { 122 | my $row_data = $row->{$table_name}; 123 | $rows{$table_name} = $cache{$table_name}{refaddr $row_data} //= $row_class{$table_name}->new( 124 | table_name => $table_name, 125 | handler => $handler, 126 | row_data => $row_data, 127 | ); 128 | } 129 | 130 | push @rows => Aniki::Row::Joined->new(values %rows); 131 | } 132 | 133 | return \@rows; 134 | } 135 | 136 | __PACKAGE__->meta->make_immutable(); 137 | __END__ 138 | -------------------------------------------------------------------------------- /lib/Aniki/Handler.pm: -------------------------------------------------------------------------------- 1 | package Aniki::Handler; 2 | use 5.014002; 3 | 4 | use namespace::autoclean; 5 | use Mouse; 6 | 7 | use DBIx::Handler 0.12; 8 | 9 | has connect_info => ( 10 | is => 'ro', 11 | required => 1, 12 | ); 13 | 14 | has on_connect_do => ( 15 | is => 'ro', 16 | ); 17 | 18 | has on_disconnect_do => ( 19 | is => 'ro', 20 | ); 21 | 22 | has trace_query => ( 23 | is => 'ro', 24 | default => 0, 25 | ); 26 | 27 | has trace_ignore_if => ( 28 | is => 'ro', 29 | default => sub { \&_noop }, 30 | ); 31 | 32 | has handler => ( 33 | is => 'rw', 34 | lazy => 1, 35 | builder => 'connect', 36 | clearer => 'disconnect', 37 | ); 38 | 39 | sub _noop {} 40 | 41 | sub connect :method { 42 | my $self = shift; 43 | my ($dsn, $user, $pass, $attr) = @{ $self->connect_info }; 44 | my $trace_ignore_if = $self->trace_ignore_if; 45 | return $self->_handler_class->new($dsn, $user, $pass, $attr, { 46 | on_connect_do => $self->on_connect_do, 47 | on_disconnect_do => $self->on_disconnect_do, 48 | trace_query => $self->trace_query, 49 | trace_ignore_if => sub { $_[0]->isa('Aniki') || $_[0]->isa('Aniki::Handler') || $trace_ignore_if->(@_) }, 50 | }); 51 | } 52 | 53 | sub _handler_class { 'DBIx::Handler' } 54 | sub _proxy_methods { qw/dbh trace_query_set_comment run txn_manager txn in_txn txn_scope txn_begin txn_rollback txn_commit/ } 55 | 56 | for my $name (__PACKAGE__->_proxy_methods) { 57 | my $code = __PACKAGE__->_handler_class->can($name); 58 | __PACKAGE__->meta->add_method($name => sub { 59 | @_ = (shift->handler, @_); 60 | goto $code; 61 | }); 62 | } 63 | 64 | sub DEMOLISH { 65 | my $self = shift; 66 | $self->disconnect(); 67 | } 68 | 69 | __PACKAGE__->meta->make_immutable(); 70 | __END__ 71 | 72 | =pod 73 | 74 | =encoding utf-8 75 | 76 | =head1 NAME 77 | 78 | Aniki::Handler - Database handler manager 79 | 80 | =head1 SYNOPSIS 81 | 82 | # define custom database handler class 83 | pakcage MyApp::DB::Handler { 84 | use Mouse; 85 | extends qw/Aniki::Handler/; 86 | 87 | has '+connect_info' => ( 88 | is => 'rw', 89 | ); 90 | 91 | has servers => ( 92 | is => 'ro', 93 | isa => 'ArrayRef[Str]', 94 | ); 95 | 96 | sub _choice { @_[int rand scalar @_] } 97 | 98 | around connect => sub { 99 | my $self = shift; 100 | my ($dsn, $user, $pass, $attr) = @{ $self->connect_info }; 101 | $attr->{host} = _choice(@{ $self->servers }); 102 | $self->connect_info([$dsn, $user, $pass, $attr]); 103 | return DBIx::Handler->new($dsn, $user, $pass, $attr, { 104 | on_connect_do => $self->on_connect_do, 105 | on_disconnect_do => $self->on_disconnect_do, 106 | }); 107 | }; 108 | }; 109 | 110 | # and use it 111 | package MyApp::DB { 112 | use Mouse; 113 | extends qw/Aniki::Handler/; 114 | 115 | __PACKAGE__->setup( 116 | handler => 'MyApp::DB::Handler', 117 | ); 118 | } 119 | 120 | 1; 121 | 122 | =head1 DESCRIPTION 123 | 124 | This is database handler manager. 125 | 126 | =head1 METHODS 127 | 128 | =head2 CLASS METHODS 129 | 130 | =head3 C 131 | 132 | Create instance of Aniki::Handler. 133 | 134 | =head4 Arguments 135 | 136 | =over 4 137 | 138 | =item C 139 | 140 | Auguments for L's connect method. 141 | 142 | =item on_connect_do : CodeRef|ArrayRef[Str]|Str 143 | =item on_disconnect_do : CodeRef|ArrayRef[Str]|Str 144 | 145 | Execute SQL or CodeRef when connected/disconnected. 146 | 147 | =back 148 | 149 | =head2 INSTANCE METHODS 150 | 151 | =head3 C 152 | 153 | Create instance of DBIx::Handler. 154 | You can override it in your custom handler class. 155 | 156 | =head2 ACCESSORS 157 | 158 | =over 4 159 | 160 | =item C 161 | 162 | =item C 163 | 164 | =item C 165 | 166 | =item trace_query : Bool 167 | 168 | =item trace_ignore_if : CodeRef 169 | 170 | =item C 171 | 172 | =item C 173 | 174 | =item C 175 | 176 | =back 177 | -------------------------------------------------------------------------------- /author/README.md: -------------------------------------------------------------------------------- 1 | ## benchmark 2 | 3 | ``` 4 | =============== SCHEMA =============== 5 | 6 | BEGIN TRANSACTION; 7 | 8 | -- 9 | -- Table: author 10 | -- 11 | CREATE TABLE author ( 12 | id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, 13 | name VARCHAR(255), 14 | message VARCHAR(255) DEFAULT 'hello' 15 | ); 16 | 17 | CREATE UNIQUE INDEX name_uniq ON author (name); 18 | 19 | -- 20 | -- Table: module 21 | -- 22 | CREATE TABLE module ( 23 | id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, 24 | name VARCHAR(255), 25 | author_id INTEGER 26 | ); 27 | 28 | CREATE INDEX author_id_idx ON module (author_id); 29 | 30 | COMMIT; 31 | =============== INSERT (no fetch) =============== 32 | Benchmark: timing 100000 iterations of aniki... 33 | aniki: 7 wallclock secs ( 6.56 usr + 0.03 sys = 6.59 CPU) @ 15174.51/s (n=100000) 34 | =============== INSERT (fetch auto increment id only) =============== 35 | Benchmark: timing 100000 iterations of aniki, teng... 36 | aniki: 7 wallclock secs ( 7.37 usr + 0.03 sys = 7.40 CPU) @ 13513.51/s (n=100000) 37 | teng: 7 wallclock secs ( 8.90 usr + 0.04 sys = 8.94 CPU) @ 11185.68/s (n=100000) 38 | Rate teng aniki 39 | teng 11186/s -- -17% 40 | aniki 13514/s 21% -- 41 | =============== INSERT =============== 42 | Benchmark: timing 20000 iterations of aniki(emulate), dbic, teng... 43 | aniki(emulate): 1 wallclock secs ( 1.80 usr + 0.01 sys = 1.81 CPU) @ 11049.72/s (n=20000) 44 | dbic: 8 wallclock secs ( 7.83 usr + 0.03 sys = 7.86 CPU) @ 2544.53/s (n=20000) 45 | teng: 7 wallclock secs ( 6.61 usr + 0.02 sys = 6.63 CPU) @ 3016.59/s (n=20000) 46 | Benchmark: timing 20000 iterations of aniki(fetch)... 47 | aniki(fetch): 6 wallclock secs ( 5.58 usr + 0.02 sys = 5.60 CPU) @ 3571.43/s (n=20000) 48 | Rate dbic teng aniki(fetch) aniki(emulate) 49 | dbic 2545/s -- -16% -29% -77% 50 | teng 3017/s 19% -- -16% -73% 51 | aniki(fetch) 3571/s 40% 18% -- -68% 52 | aniki(emulate) 11050/s 334% 266% 209% -- 53 | =============== SELECT =============== 54 | Benchmark: timing 20000 iterations of aniki, dbic, teng... 55 | aniki: 5 wallclock secs ( 4.92 usr + 0.01 sys = 4.93 CPU) @ 4056.80/s (n=20000) 56 | dbic: 12 wallclock secs (12.17 usr + 0.04 sys = 12.21 CPU) @ 1638.00/s (n=20000) 57 | teng: 6 wallclock secs ( 5.86 usr + 0.01 sys = 5.87 CPU) @ 3407.16/s (n=20000) 58 | Rate dbic teng aniki 59 | dbic 1638/s -- -52% -60% 60 | teng 3407/s 108% -- -16% 61 | aniki 4057/s 148% 19% -- 62 | =============== UPDATE =============== 63 | Benchmark: timing 20000 iterations of aniki, aniki(row), dbic, teng, teng(row)... 64 | aniki: 1 wallclock secs ( 1.72 usr + 0.01 sys = 1.73 CPU) @ 11560.69/s (n=20000) 65 | aniki(row): 7 wallclock secs ( 6.38 usr + 0.01 sys = 6.39 CPU) @ 3129.89/s (n=20000) 66 | dbic: 9 wallclock secs ( 9.51 usr + 0.03 sys = 9.54 CPU) @ 2096.44/s (n=20000) 67 | teng: 2 wallclock secs ( 1.81 usr + 0.01 sys = 1.82 CPU) @ 10989.01/s (n=20000) 68 | teng(row): 5 wallclock secs ( 4.20 usr + 0.01 sys = 4.21 CPU) @ 4750.59/s (n=20000) 69 | Rate dbic aniki(row) teng(row) teng aniki 70 | dbic 2096/s -- -33% -56% -81% -82% 71 | aniki(row) 3130/s 49% -- -34% -72% -73% 72 | teng(row) 4751/s 127% 52% -- -57% -59% 73 | teng 10989/s 424% 251% 131% -- -5% 74 | aniki 11561/s 451% 269% 143% 5% -- 75 | =============== DELETE =============== 76 | Benchmark: timing 20000 iterations of aniki(row), dbic, teng(row)... 77 | aniki(row): 5 wallclock secs ( 5.71 usr + 0.01 sys = 5.72 CPU) @ 3496.50/s (n=20000) 78 | dbic: 30 wallclock secs (29.72 usr + 0.11 sys = 29.83 CPU) @ 670.47/s (n=20000) 79 | teng(row): 6 wallclock secs ( 5.61 usr + 0.01 sys = 5.62 CPU) @ 3558.72/s (n=20000) 80 | Benchmark: timing 20000 iterations of aniki, teng... 81 | aniki: 1 wallclock secs ( 1.19 usr + 0.00 sys = 1.19 CPU) @ 16806.72/s (n=20000) 82 | teng: 2 wallclock secs ( 1.25 usr + 0.00 sys = 1.25 CPU) @ 16000.00/s (n=20000) 83 | Rate dbic aniki(row) teng(row) teng aniki 84 | dbic 670/s -- -81% -81% -96% -96% 85 | aniki(row) 3497/s 422% -- -2% -78% -79% 86 | teng(row) 3559/s 431% 2% -- -78% -79% 87 | teng 16000/s 2286% 358% 350% -- -5% 88 | aniki 16807/s 2407% 381% 372% 5% -- 89 | ``` 90 | -------------------------------------------------------------------------------- /lib/Aniki/Schema/Relationship/Fetcher.pm: -------------------------------------------------------------------------------- 1 | package Aniki::Schema::Relationship::Fetcher; 2 | use 5.014002; 3 | 4 | use namespace::autoclean; 5 | use Mouse v2.4.5; 6 | 7 | has relationship => ( 8 | is => 'ro', 9 | weak_ref => 1, 10 | required => 1, 11 | ); 12 | 13 | use List::MoreUtils qw/pairwise notall uniq/; 14 | use List::UtilsBy qw/partition_by/; 15 | use Scalar::Util qw/weaken/; 16 | use SQL::QueryMaker; 17 | 18 | sub execute { 19 | my ($self, $handler, $rows, $prefetch) = @_; 20 | return unless @$rows; 21 | 22 | my %where; 23 | if (ref $prefetch eq 'HASH') { 24 | my %prefetch; 25 | for my $key (keys %$prefetch) { 26 | if ($key =~ /^\./) { 27 | my $column = $key =~ s/^\.//r; 28 | $where{$column} = $prefetch->{$key}; 29 | } 30 | else { 31 | $prefetch{$key} = $prefetch->{$key}; 32 | } 33 | } 34 | $prefetch = \%prefetch; 35 | } 36 | 37 | my $relationship = $self->relationship; 38 | my $name = $relationship->name; 39 | my $table_name = $relationship->dest_table_name; 40 | my $has_many = $relationship->has_many; 41 | my @src_columns = @{ $relationship->src_columns }; 42 | my @dest_columns = @{ $relationship->dest_columns }; 43 | 44 | if (@src_columns == 1 and @dest_columns == 1) { 45 | my $src_column = $src_columns[0]; 46 | my $dest_column = $dest_columns[0]; 47 | 48 | my @src_values = uniq grep defined, map { $_->get_column($src_column) } @$rows; 49 | unless (@src_values) { 50 | # set empty value 51 | for my $row (@$rows) { 52 | $row->relay_data->{$name} = $has_many ? [] : undef; 53 | } 54 | return; 55 | } 56 | 57 | my @related_rows = $handler->select($table_name => { 58 | %where, 59 | $dest_column => sql_in(\@src_values), 60 | }, { prefetch => $prefetch })->all; 61 | 62 | my %related_rows_map = partition_by { $_->get_column($dest_column) } @related_rows; 63 | for my $row (@$rows) { 64 | my $src_value = $row->get_column($src_column); 65 | unless (defined $src_value) { 66 | # set empty value 67 | $row->relay_data->{$name} = $has_many ? [] : undef; 68 | next; 69 | } 70 | 71 | my $related_rows = $related_rows_map{$src_value}; 72 | $row->relay_data->{$name} = $has_many ? $related_rows : $related_rows->[0]; 73 | } 74 | 75 | $self->_execute_inverse(\@related_rows => $rows); 76 | } 77 | else { 78 | # follow slow case... 79 | for my $row (@$rows) { 80 | next if notall { defined $row->get_column($_) } @src_columns; 81 | my @related_rows = $handler->select($table_name => { 82 | %where, 83 | pairwise { $a => $row->get_column($b) } @dest_columns, @src_columns 84 | }, { prefetch => $prefetch })->all; 85 | $row->relay_data->{$name} = $has_many ? \@related_rows : $related_rows[0]; 86 | } 87 | } 88 | } 89 | 90 | sub _execute_inverse { 91 | my ($self, $src_rows, $dest_rows) = @_; 92 | return unless @$src_rows; 93 | return unless @$dest_rows; 94 | 95 | for my $relationship ($self->relationship->get_inverse_relationships) { 96 | my $name = $relationship->name; 97 | my $has_many = $relationship->has_many; 98 | my @src_columns = @{ $relationship->src_columns }; 99 | my @dest_columns = @{ $relationship->dest_columns }; 100 | 101 | my $src_keygen = sub { 102 | my $src_row = shift; 103 | return join '|', map { defined $_ ? quotemeta $_ : '(NULL)' } map { $src_row->get_column($_) } @src_columns; 104 | }; 105 | my $dest_keygen = sub { 106 | my $dest_row = shift; 107 | return join '|', map { defined $_ ? quotemeta $_ : '(NULL)' } map { $dest_row->get_column($_) } @dest_columns; 108 | }; 109 | 110 | my %dest_rows_map = partition_by { $dest_keygen->($_) } @$dest_rows; 111 | for my $src_row (@$src_rows) { 112 | next if notall { defined $src_row->get_column($_) } @src_columns; 113 | my $dest_rows = $dest_rows_map{$src_keygen->($src_row)}; 114 | $src_row->relay_data->{$name} = $has_many ? $dest_rows : $dest_rows->[0]; 115 | weaken($src_row->relay_data->{$name}); 116 | } 117 | } 118 | } 119 | 120 | __PACKAGE__->meta->make_immutable(); 121 | __END__ 122 | -------------------------------------------------------------------------------- /lib/Aniki/Plugin/SelectJoined.pm: -------------------------------------------------------------------------------- 1 | package Aniki::Plugin::SelectJoined; 2 | use 5.014002; 3 | 4 | use namespace::autoclean; 5 | use Mouse::Role; 6 | use Aniki::QueryBuilder; 7 | use Aniki::Result::Collection::Joined; 8 | use Carp qw/croak/; 9 | 10 | requires qw/schema query_builder suppress_row_objects txn_manager execute/; 11 | 12 | Aniki::QueryBuilder->load_plugin('JoinSelect'); 13 | 14 | sub select_joined { 15 | my ($self, $base_table, $join_conditions, $where, $opt) = @_; 16 | croak '(Aniki::Plugin::SelectJoined#select_joined) `where` condition must be a reference.' unless ref $where; 17 | 18 | my @table_names = ($base_table); 19 | for (my $i = 0; my $table = $join_conditions->[$i]; $i += 2) { 20 | push @table_names => $table; 21 | } 22 | my @tables = map { $self->schema->get_table($_) } @table_names; 23 | 24 | my $name_sep = $self->query_builder->name_sep; 25 | my @columns; 26 | for my $table (@tables) { 27 | my $table_name = $table->name; 28 | push @columns => 29 | map { "$table_name$name_sep$_" } 30 | map { $_->name } $table->get_fields(); 31 | } 32 | 33 | my ($sql, @bind) = $self->query_builder->join_select($base_table, $join_conditions, \@columns, $where, $opt); 34 | return $self->select_joined_by_sql($sql, \@bind, { 35 | table_names => \@table_names, 36 | columns => \@columns, 37 | %$opt, 38 | }); 39 | } 40 | 41 | sub select_joined_by_sql { 42 | my ($self, $sql, $bind, $opt) = @_; 43 | $opt //= {}; 44 | 45 | my $table_names = $opt->{table_names} or croak 'table_names is required'; 46 | my $columns = $opt->{columns} or croak 'columns is required'; 47 | my $prefetch = exists $opt->{prefetch} ? $opt->{prefetch} : {}; 48 | 49 | my $prefetch_enabled_fg = %$prefetch && !$self->suppress_row_objects; 50 | if ($prefetch_enabled_fg) { 51 | my $txn; $txn = $self->txn_scope unless $self->txn_manager->in_transaction; 52 | 53 | my $sth = $self->execute($sql, @$bind); 54 | my $result = $self->_fetch_joined_by_sth($sth, $table_names, $columns); 55 | 56 | for my $table_name (@$table_names) { 57 | my $rows = $result->rows($table_name); 58 | my $prefetch = $prefetch->{$table_name}; 59 | $prefetch = [$prefetch] if ref $prefetch eq 'HASH'; 60 | $self->fetch_and_attach_relay_data($table_name, $prefetch, $rows); 61 | } 62 | 63 | $txn->rollback if defined $txn; ## for read only 64 | return $result; 65 | } 66 | else { 67 | my $sth = $self->execute($sql, @$bind); 68 | return $self->_fetch_joined_by_sth($sth, $table_names, $columns); 69 | } 70 | } 71 | 72 | sub _fetch_joined_by_sth { 73 | my ($self, $sth, $table_names, $columns) = @_; 74 | my @rows; 75 | 76 | my %row; 77 | $sth->bind_columns(\@row{@$columns}); 78 | push @rows => $self->_seperate_rows(\%row) while $sth->fetch; 79 | $sth->finish; 80 | 81 | return Aniki::Result::Collection::Joined->new( 82 | table_names => $table_names, 83 | handler => $self, 84 | row_datas => \@rows, 85 | ); 86 | } 87 | 88 | sub _seperate_rows { 89 | my ($self, $row) = @_; 90 | 91 | my $name_sep = quotemeta $self->query_builder->name_sep; 92 | 93 | my %rows; 94 | for my $full_named_column (keys %$row) { 95 | my ($table_name, $column) = split /$name_sep/, $full_named_column, 2; 96 | $rows{$table_name}{$column} = $row->{$full_named_column}; 97 | } 98 | 99 | return \%rows; 100 | } 101 | 102 | 1; 103 | __END__ 104 | 105 | =pod 106 | 107 | =encoding utf-8 108 | 109 | =head1 NAME 110 | 111 | Aniki::Plugin::SelectJoined - Support for Joined query 112 | 113 | =head1 SYNOPSIS 114 | 115 | package MyDB; 116 | use Mouse v2.4.5; 117 | extends qw/Aniki/; 118 | with qw/Aniki::Plugin::SelectJoined/; 119 | 120 | package main; 121 | my $db = MyDB->new(...); 122 | 123 | my $result = $db->select_joined(user_item => [ 124 | user => {'user_item.user_id' => 'user.id'}, 125 | item => {'user_item.item_id' => 'item.id'}, 126 | ], { 127 | 'user.id' => 2, 128 | }, { 129 | order_by => 'user_item.item_id', 130 | }); 131 | 132 | for my $row ($result->all) { 133 | my $user_item = $row->user_item; 134 | my $user = $row->user; 135 | my $item = $row->item; 136 | 137 | ... 138 | } 139 | 140 | =head1 SEE ALSO 141 | 142 | L 143 | 144 | L 145 | 146 | =head1 LICENSE 147 | 148 | Copyright (C) karupanerura. 149 | 150 | This library is free software; you can redistribute it and/or modify 151 | it under the same terms as Perl itself. 152 | 153 | =head1 AUTHOR 154 | 155 | karupanerura Ekarupa@cpan.orgE 156 | 157 | =cut 158 | -------------------------------------------------------------------------------- /t/lib/t/DB.pm: -------------------------------------------------------------------------------- 1 | package t::DB; 2 | use 5.014002; 3 | use Mouse v2.4.5; 4 | extends qw/Aniki/; 5 | 6 | use Test::Builder; 7 | use t::DB::Exception; 8 | use List::Util qw/shuffle/; 9 | 10 | my %CONFIG = ( 11 | schema => 't::DB::Schema::%s', 12 | filter => 't::DB::Filter', 13 | row => 't::DB::Row', 14 | ); 15 | 16 | sub all_databases { shuffle qw/SQLite MySQL PostgreSQL/ } 17 | 18 | sub run_on_all_databases { 19 | my $class = shift; 20 | $class->run_on_each_databases([$class->all_databases] => @_); 21 | } 22 | 23 | sub run_on_each_databases { 24 | my ($class, $databases, $code) = @_; 25 | for my $database (@$databases) { 26 | Test::Builder->new->subtest($database => sub { 27 | my $subclass = eval { $class->get_or_create_anon_class_by_database($database) }; 28 | if (my $reason = $@) { 29 | if (t::DB::Exception->caught($reason)) { 30 | Test::Builder->new->note($reason->message); 31 | Test::Builder->new->plan(skip_all => "Cannot use $database"); 32 | return; 33 | } 34 | die $reason; # rethrow 35 | } 36 | $subclass->$code($database); 37 | }); 38 | } 39 | } 40 | 41 | sub get_or_create_anon_class_by_database { 42 | my ($class, $database) = @_; 43 | state %class_cache; 44 | return $class_cache{$database} ||= $class->create_anon_class_by_database($database); 45 | } 46 | 47 | sub create_anon_class_by_database { 48 | my ($class, $database) = @_; 49 | state @heap; 50 | 51 | my $meta = Mouse::Meta::Class->create_anon_class(superclasses => [$class]); 52 | push @heap => $meta; 53 | 54 | my $subclass = $meta->name; 55 | 56 | my %config = %CONFIG; 57 | $config{schema} = sprintf $config{schema}, $database; 58 | $subclass->setup(%config); 59 | $subclass->prepare_testing($config{schema}); 60 | return $subclass; 61 | } 62 | 63 | sub prepare_testing { 64 | my ($class, $schema_class) = @_; 65 | my $ddl = $schema_class->output; 66 | if ($schema_class->context->db eq 'MySQL') { 67 | eval { 68 | require DBD::mysql; 69 | require Test::mysqld; 70 | }; 71 | t::DB::Exception->throw(message => $@) if $@; 72 | 73 | Test::Builder->new->note('launch mysqld ...'); 74 | my $mysqld = Test::mysqld->new( 75 | my_cnf => { 76 | 'skip-networking' => '', # no TCP socket 77 | } 78 | ); 79 | t::DB::Exception->throw(message => $Test::mysqld::errstr) unless $mysqld; 80 | 81 | my $dbh = DBI->connect($mysqld->dsn(dbname => 'test'), 'root', '', { 82 | AutoCommit => 1, 83 | PrintError => 0, 84 | RaiseError => 1, 85 | }); 86 | $dbh->do($_) for grep /\S/, split /;/, $ddl; 87 | 88 | $class->meta->add_around_method_modifier(BUILDARGS => sub { 89 | my $orig = shift; 90 | my $class = shift; 91 | my %args = @_ == 1 ? %{+shift} : @_; 92 | $args{connect_info} = [$mysqld->dsn(dbname => 'test'), 'root', '']; 93 | return $class->$orig(\%args); 94 | }); 95 | } 96 | elsif ($schema_class->context->db eq 'PostgreSQL') { 97 | eval { 98 | require DBD::Pg; 99 | require Test::PostgreSQL; 100 | }; 101 | t::DB::Exception->throw(message => $@) if $@; 102 | 103 | Test::Builder->new->note('launch postgresql ...'); 104 | my $pgsql = Test::PostgreSQL->new(); 105 | t::DB::Exception->throw(message => $Test::PostgreSQL::errstr) unless $pgsql; 106 | 107 | my $dbh = DBI->connect($pgsql->dsn, '', '', { 108 | AutoCommit => 1, 109 | PrintError => 0, 110 | RaiseError => 1, 111 | }); 112 | $dbh->do($_) for grep /\S/, split /;/, $ddl; 113 | 114 | $class->meta->add_around_method_modifier(BUILDARGS => sub { 115 | my $orig = shift; 116 | my $class = shift; 117 | my %args = @_ == 1 ? %{+shift} : @_; 118 | $args{connect_info} = [$pgsql->dsn]; 119 | return $class->$orig(\%args); 120 | }); 121 | } 122 | elsif ($schema_class->context->db eq 'SQLite') { 123 | require DBD::SQLite; 124 | 125 | Test::Builder->new->note('prepare sqlite ...'); 126 | $class->meta->add_around_method_modifier(BUILDARGS => sub { 127 | my $orig = shift; 128 | my $class = shift; 129 | my %args = @_ == 1 ? %{+shift} : @_; 130 | $args{connect_info} = ['dbi:SQLite:dbname=:memory:', '', '']; 131 | return $class->$orig(\%args); 132 | }); 133 | $class->meta->add_method(BUILD => sub { 134 | my $self = shift; 135 | $self->execute($_) for grep /\S/, split /;/, $ddl; 136 | }); 137 | } 138 | else { 139 | my $msg = sprintf 'Unknown database: %s', $schema_class->context->db; 140 | die $msg; 141 | } 142 | } 143 | 144 | 1; 145 | -------------------------------------------------------------------------------- /lib/Aniki/Filter.pm: -------------------------------------------------------------------------------- 1 | package Aniki::Filter; 2 | use 5.014002; 3 | 4 | use namespace::autoclean; 5 | use Mouse v2.4.5; 6 | 7 | has global_inflators => ( 8 | is => 'ro', 9 | default => sub { [] }, 10 | ); 11 | 12 | has global_deflators => ( 13 | is => 'ro', 14 | default => sub { [] }, 15 | ); 16 | 17 | has global_triggers => ( 18 | is => 'ro', 19 | default => sub { +{} }, 20 | ); 21 | 22 | has table_inflators => ( 23 | is => 'ro', 24 | default => sub { +{} }, 25 | ); 26 | 27 | has table_deflators => ( 28 | is => 'ro', 29 | default => sub { +{} }, 30 | ); 31 | 32 | has table_triggers => ( 33 | is => 'ro', 34 | default => sub { +{} }, 35 | ); 36 | 37 | sub _identity { $_[0] } 38 | sub _normalize_column2rx { ref $_[0] eq 'Regexp' ? $_[0] : qr/\A\Q$_[0]\E\z/m } 39 | 40 | sub add_global_inflator { 41 | my ($self, $column, $code) = @_; 42 | my $rx = _normalize_column2rx($column); 43 | push @{ $self->global_inflators } => [$rx, $code]; 44 | } 45 | 46 | sub add_global_deflator { 47 | my ($self, $column, $code) = @_; 48 | my $rx = _normalize_column2rx($column); 49 | push @{ $self->global_deflators } => [$rx, $code]; 50 | } 51 | 52 | sub add_global_trigger { 53 | my ($self, $event, $code) = @_; 54 | push @{ $self->global_triggers->{$event} } => $code; 55 | } 56 | 57 | sub add_table_inflator { 58 | my ($self, $table_name, $column, $code) = @_; 59 | my $rx = _normalize_column2rx($column); 60 | push @{ $self->table_inflators->{$table_name} } => [$rx, $code]; 61 | } 62 | 63 | sub add_table_deflator { 64 | my ($self, $table_name, $column, $code) = @_; 65 | my $rx = _normalize_column2rx($column); 66 | push @{ $self->table_deflators->{$table_name} } => [$rx, $code]; 67 | } 68 | 69 | sub add_table_trigger { 70 | my ($self, $table_name, $event, $code) = @_; 71 | push @{ $self->table_triggers->{$table_name}->{$event} } => $code; 72 | } 73 | 74 | sub inflate_column { 75 | my ($self, $table_name, $column, $data) = @_; 76 | my $code = $self->get_inflate_callback($table_name, $column); 77 | return $data unless defined $code; 78 | return $code->($data); 79 | } 80 | 81 | sub deflate_column { 82 | my ($self, $table_name, $column, $data) = @_; 83 | my $code = $self->get_deflate_callback($table_name, $column); 84 | return $data unless defined $code; 85 | return $code->($data); 86 | } 87 | 88 | sub inflate_row { 89 | my ($self, $table_name, $row) = @_; 90 | my %row = %$row; 91 | for my $column (keys %row) { 92 | $row{$column} = $self->inflate_column($table_name, $column, $row{$column}); 93 | } 94 | return \%row; 95 | } 96 | 97 | sub deflate_row { 98 | my ($self, $table_name, $row) = @_; 99 | my %row = %$row; 100 | for my $column (keys %row) { 101 | $row{$column} = $self->deflate_column($table_name, $column, $row{$column}); 102 | } 103 | return \%row; 104 | } 105 | 106 | sub apply_trigger { 107 | my ($self, $event, $table_name, $row) = @_; 108 | my %row = %$row; 109 | 110 | my $trigger = $self->get_trigger_callback($event, $table_name); 111 | return $trigger->(\%row); 112 | } 113 | 114 | sub get_inflate_callback { 115 | my ($self, $table_name, $column) = @_; 116 | unless (exists $self->{__inflate_callbacks_cache}->{$table_name}->{$column}) { 117 | my $callback; 118 | for my $pair (@{ $self->global_inflators }) { 119 | my ($rx, $code) = @$pair; 120 | $callback = $code if $column =~ $rx; 121 | } 122 | for my $pair (@{ $self->table_inflators->{$table_name} }) { 123 | my ($rx, $code) = @$pair; 124 | $callback = $code if $column =~ $rx; 125 | } 126 | $self->{__inflate_callbacks_cache}->{$table_name}->{$column} = $callback; 127 | } 128 | return $self->{__inflate_callbacks_cache}->{$table_name}->{$column}; 129 | } 130 | 131 | sub get_deflate_callback { 132 | my ($self, $table_name, $column) = @_; 133 | unless (exists $self->{__deflate_callbacks_cache}->{$table_name}->{$column}) { 134 | my $callback; 135 | for my $pair (@{ $self->global_deflators }) { 136 | my ($rx, $code) = @$pair; 137 | $callback = $code if $column =~ $rx; 138 | } 139 | for my $pair (@{ $self->table_deflators->{$table_name} }) { 140 | my ($rx, $code) = @$pair; 141 | $callback = $code if $column =~ $rx; 142 | } 143 | $self->{__deflate_callbacks_cache}->{$table_name}->{$column} = $callback; 144 | } 145 | return $self->{__deflate_callbacks_cache}->{$table_name}->{$column}; 146 | } 147 | 148 | sub get_trigger_callback { 149 | my ($self, $event, $table_name) = @_; 150 | 151 | unless (exists $self->{__trigger_callback_cache}->{$table_name}->{$event}) { 152 | my @triggers = ( 153 | @{ $self->table_triggers->{$table_name}->{$event} || [] }, 154 | @{ $self->global_triggers->{$event} || [] }, 155 | ); 156 | 157 | my $trigger = \&_identity; 158 | for my $cb (reverse @triggers) { 159 | my $next = $trigger; 160 | $trigger = sub { $cb->($_[0], $next) }; 161 | } 162 | $self->{__trigger_callback_cache}->{$table_name}->{$event} = $trigger; 163 | } 164 | 165 | return $self->{__trigger_callback_cache}->{$table_name}->{$event}; 166 | } 167 | 168 | __PACKAGE__->meta->make_immutable(); 169 | __END__ 170 | -------------------------------------------------------------------------------- /t/plugin/select_joined/select_joined.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | use Test::Requires qw(SQL::Maker::Plugin::JoinSelect); 7 | 8 | use File::Spec; 9 | use lib File::Spec->catfile('t', 'lib'); 10 | use Mouse::Util; 11 | use t::Util; 12 | 13 | run_on_database { 14 | Mouse::Util::apply_all_roles(db, 'Aniki::Plugin::SelectJoined'); 15 | 16 | my $moznion_id = db->insert_and_fetch_id(author => { name => 'MOZNION' }); 17 | my @moznion_module_ids = ( 18 | db->insert_and_fetch_id(module => { name => 'Perl::Lint', author_id => $moznion_id }), 19 | db->insert_and_fetch_id(module => { name => 'Regexp::Lexer', author_id => $moznion_id }), 20 | db->insert_and_fetch_id(module => { name => 'Test::JsonAPI::Autodoc', author_id => $moznion_id }), 21 | ); 22 | 23 | my $karupa_id = db->insert_and_fetch_id(author => { name => 'KARUPA' }); 24 | my @karupa_module_ids = ( 25 | db->insert_and_fetch_id(module => { name => 'TOML::Parser', author_id => $karupa_id }), 26 | db->insert_and_fetch_id(module => { name => 'Plack::App::Vhost', author_id => $karupa_id }), 27 | db->insert_and_fetch_id(module => { name => 'Test::SharedObject', author_id => $karupa_id }), 28 | ); 29 | 30 | my $obake1_id = db->insert_and_fetch_id(author => { name => 'OBAKE1' }); 31 | my $obake2_id = db->insert_and_fetch_id(author => { name => 'OBAKE2' }); 32 | my $obake3_id = db->insert_and_fetch_id(author => { name => 'OBAKE3' }); 33 | 34 | subtest normal => sub { 35 | my $result = db->select_joined(author => [ 36 | module => { 'module.author_id' => 'author.id' }, 37 | ], { 38 | 'author.id' => $moznion_id, 39 | }, { 40 | order_by => 'module.id', 41 | }); 42 | 43 | my @authors = $result->all('author'); 44 | my @modules = $result->all('module'); 45 | is scalar @authors, 1; 46 | is scalar @modules, 3; 47 | 48 | subtest all => sub { 49 | my @expected = qw/Perl::Lint Regexp::Lexer Test::JsonAPI::Autodoc/; 50 | 51 | my @rows = $result->all; 52 | is scalar @rows, 3; 53 | for my $row (@rows) { 54 | my $author = $row->author; 55 | my $module = $row->module; 56 | is $author->table_name, 'author'; 57 | is $module->table_name, 'module'; 58 | is $author->name, 'MOZNION'; 59 | 60 | is query_count { $module->versions }, 1; 61 | 62 | my $expected = shift @expected; 63 | is $module->name, $expected; 64 | } 65 | }; 66 | }; 67 | 68 | subtest outer => sub { 69 | my $result = db->select_joined(author => [ 70 | module => [LEFT => { 'module.author_id' => 'author.id' }], 71 | ], { 72 | # anywhere 73 | }, { 74 | order_by => ['author.id', 'module.id'], 75 | }); 76 | 77 | my @authors = $result->all('author'); 78 | my @modules = $result->all('module'); 79 | is scalar @authors, 5; 80 | is scalar @modules, 9; 81 | 82 | subtest all => sub { 83 | my @expected = ( 84 | { author => 'MOZNION', module => 'Perl::Lint' }, 85 | { author => 'MOZNION', module => 'Regexp::Lexer' }, 86 | { author => 'MOZNION', module => 'Test::JsonAPI::Autodoc' }, 87 | { author => 'KARUPA', module => 'TOML::Parser' }, 88 | { author => 'KARUPA', module => 'Plack::App::Vhost' }, 89 | { author => 'KARUPA', module => 'Test::SharedObject' }, 90 | { author => 'OBAKE1', module => undef }, 91 | { author => 'OBAKE2', module => undef }, 92 | { author => 'OBAKE3', module => undef }, 93 | ); 94 | 95 | my @rows = $result->all; 96 | is scalar @rows, 9; 97 | for my $row (@rows) { 98 | my $author = $row->author; 99 | my $module = $row->module; 100 | is $author->table_name, 'author'; 101 | is $module->table_name, 'module'; 102 | 103 | my $expected = shift @expected; 104 | is $author->name, $expected->{author}; 105 | is $module->name, $expected->{module}; 106 | } 107 | }; 108 | }; 109 | 110 | subtest prefetch => sub { 111 | my $result = db->select_joined(author => [ 112 | module => { 'module.author_id' => 'author.id' }, 113 | ], { 114 | 'author.id' => $moznion_id, 115 | }, { 116 | order_by => 'module.id', 117 | prefetch => { 118 | module => [qw/versions/], 119 | } 120 | }); 121 | 122 | my @authors = $result->all('author'); 123 | my @modules = $result->all('module'); 124 | is scalar @authors, 1; 125 | is scalar @modules, 3; 126 | 127 | subtest all => sub { 128 | my @expected = qw/Perl::Lint Regexp::Lexer Test::JsonAPI::Autodoc/; 129 | 130 | my @rows = $result->all; 131 | is scalar @rows, 3; 132 | for my $row (@rows) { 133 | my $author = $row->author; 134 | my $module = $row->module; 135 | is $author->table_name, 'author'; 136 | is $module->table_name, 'module'; 137 | is $author->name, 'MOZNION'; 138 | 139 | is query_count { $module->versions }, 0; 140 | 141 | my $expected = shift @expected; 142 | is $module->name, $expected; 143 | } 144 | }; 145 | }; 146 | }; 147 | 148 | done_testing(); 149 | -------------------------------------------------------------------------------- /t/handler/weighted_round_robin.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | use Test::Requires qw(Data::WeightedRoundRobin); 7 | 8 | use File::Spec; 9 | use lib File::Spec->catfile('t', 'lib'); 10 | 11 | use Aniki::Handler::WeightedRoundRobin; 12 | use List::Util qw/reduce/; 13 | use List::MoreUtils qw/apply/; 14 | 15 | srand 4649; 16 | 17 | my @connect_info = ( 18 | { 19 | value => ['dbi:mysql:dbname=test;host=db1.localhost;port='.int(rand 65535), 'foo'.int(rand 65535), 'bar'.int(rand 65535), { PrintError => 0, RaiseError => 1 }], 20 | weight => 10000000, 21 | }, 22 | { 23 | value => ['dbi:mysql:dbname=test;host=db2.localhost;port='.int(rand 65535), 'foo'.int(rand 65535), 'bar'.int(rand 65535), { PrintError => 0, RaiseError => 1 }], 24 | weight => 10000000, 25 | }, 26 | { 27 | value => ['dbi:mysql:dbname=test;host=db3.localhost;port='.int(rand 65535), 'foo'.int(rand 65535), 'bar'.int(rand 65535), { PrintError => 0, RaiseError => 1 }], 28 | weight => 10000000, 29 | }, 30 | ); 31 | 32 | my $handler = Aniki::Handler::WeightedRoundRobin->new(connect_info => \@connect_info); 33 | isa_ok $handler->handler, 'DBIx::Handler'; 34 | ok reduce { $a && $b } map { $handler->connect_info()->[0] eq $handler->connect_info()->[0] } 1..100; 35 | 36 | my %seen; 37 | for (1..100) { 38 | $seen{$handler->connect_info->[0]}++; 39 | $handler->disconnect(); 40 | } 41 | ok eq_set( 42 | [keys %seen], 43 | [map { $_->{value}->[0] } @connect_info], 44 | ); 45 | 46 | ok $handler->is_connect_error(q{DBI connect('dbname=test;host=127.0.0.1;port=34783','foo25622',...) failed: Can't connect to MySQL server on '127.0.0.1' (61)}); 47 | 48 | if (eval { require DBD::mysql; 1 }) { 49 | my $called = 0; 50 | no warnings qw/redefine once/; 51 | local *DBD::mysql::dr::connect = do { 52 | use warnings qw/redefine once/; 53 | my $orig = \&DBD::mysql::dr::connect; 54 | sub { 55 | $called++; 56 | goto $orig; 57 | }; 58 | }; 59 | use warnings qw/redefine once/; 60 | 61 | subtest 'retry connect' => sub { 62 | $called = 0; 63 | no warnings qw/redefine once/; 64 | local *DBIx::Handler::in_txn = do { 65 | use warnings qw/redefine once/; 66 | sub { 0 }; 67 | }; 68 | use warnings qw/redefine once/; 69 | 70 | no warnings qw/redefine once/; 71 | local *Aniki::Handler::WeightedRoundRobin::is_connect_error = do { 72 | use warnings qw/redefine once/; 73 | sub { 1 }; 74 | }; 75 | use warnings qw/redefine once/; 76 | 77 | my @warn; 78 | local $SIG{__WARN__} = sub { push @warn => @_ }; 79 | my $dbh = eval { $handler->dbh }; 80 | note $@; 81 | ok $@; 82 | is $dbh, undef; 83 | is $called, 3; 84 | is @warn, 2; 85 | }; 86 | 87 | subtest 'no retry connect when in txn' => sub { 88 | $called = 0; 89 | no warnings qw/redefine once/; 90 | local *DBIx::Handler::in_txn = do { 91 | use warnings qw/redefine once/; 92 | sub { 1 }; 93 | }; 94 | use warnings qw/redefine once/; 95 | 96 | no warnings qw/redefine once/; 97 | local *Aniki::Handler::WeightedRoundRobin::is_connect_error = do { 98 | use warnings qw/redefine once/; 99 | sub { 1 }; 100 | }; 101 | use warnings qw/redefine once/; 102 | 103 | my $dbh = eval { $handler->dbh }; 104 | note $@; 105 | ok $@; 106 | is $dbh, undef; 107 | is $called, 1; 108 | }; 109 | 110 | subtest 'no retry connect when not connect error' => sub { 111 | $called = 0; 112 | no warnings qw/redefine once/; 113 | local *DBIx::Handler::in_txn = do { 114 | use warnings qw/redefine once/; 115 | sub { 1 }; 116 | }; 117 | use warnings qw/redefine once/; 118 | 119 | no warnings qw/redefine once/; 120 | local *Aniki::Handler::WeightedRoundRobin::is_connect_error = do { 121 | use warnings qw/redefine once/; 122 | sub { 0 }; 123 | }; 124 | use warnings qw/redefine once/; 125 | 126 | my $dbh = eval { $handler->dbh }; 127 | note $@; 128 | ok $@; 129 | is $dbh, undef; 130 | is $called, 1; 131 | }; 132 | } 133 | 134 | if ($ENV{AUTHOR_TESTING}) { 135 | require DBD::mysql; 136 | require Test::mysqld; 137 | 138 | my $mysqld = Test::mysqld->new( 139 | my_cnf => { 140 | 'skip-networking' => '', # no TCP socket 141 | } 142 | ); 143 | { 144 | no warnings qw/once/; 145 | die $Test::mysqld::errstr unless $mysqld; 146 | } 147 | 148 | my @connect_info = apply { $_->{value}->[0] =~ s/db[1-3]\.localhost/127.0.0.1/ } @connect_info; 149 | my $handler = Aniki::Handler::WeightedRoundRobin->new(connect_info => [@connect_info, { weight => 1, value => [$mysqld->dsn] }]); 150 | 151 | my $called = 0; 152 | no warnings qw/redefine once/; 153 | local *Aniki::Handler::WeightedRoundRobin::dbh = do { 154 | use warnings qw/redefine once/; 155 | my $super = Aniki::Handler::WeightedRoundRobin->can('dbh'); 156 | sub { 157 | $called++; 158 | goto $super; 159 | }; 160 | }; 161 | use warnings qw/redefine once/; 162 | 163 | subtest 'success to retry connecting' => sub { 164 | $called = 0; 165 | 166 | my @warn; 167 | local $SIG{__WARN__} = sub { push @warn => @_ }; 168 | my $dbh = eval { $handler->dbh }; 169 | ok !$@ or diag $@; 170 | isa_ok $dbh, 'DBI::db'; 171 | is @warn, 3; 172 | is $called, 4; 173 | }; 174 | } 175 | 176 | done_testing(); 177 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Revision history for Perl extension Aniki 2 | 3 | {{$NEXT}} 4 | 5 | 1.06 2017-07-20T04:56:58Z 6 | 7 | - added Aniki::Row@is_prefetched method (mamimumemoomoo) 8 | - added option ue/le for RangeConditionMaker (mamimumemoomoo) 9 | 10 | 1.05 2017-07-14T06:10:50Z 11 | 12 | - makes 1.04_02 as normal(non-developer) release 13 | 14 | 1.04_02 2017-06-21T07:00:32Z 15 | 16 | - fixed packaging 17 | 18 | 1.04_01 2017-06-21T06:55:28Z 19 | 20 | - added update_and_(fetch|emulate)_row method (mamimumemoomoo) 21 | 22 | 1.04 2017-05-28T13:03:12Z 23 | 24 | - fixed range condition maker (thanks mamimumemoomoo) 25 | - namespace cleaner switched to namespace::autoclean (thanks karenetheridge) 26 | - throw more intelligibly error when calling update without data (thanks GeJ) 27 | - droped typoed (obsoluted) `make_range_condtion` method 28 | 29 | 1.03 2017-03-29T11:24:39Z 30 | 31 | - [EXPERIMENTAL] x_static_install=1 (no feature changes) 32 | 33 | 1.02 2017-02-10T06:14:56Z 34 | 35 | - added lt/gt alias option for lower/upper (watanabe-yoichi) 36 | 37 | 1.01 2016-12-10T07:07:27Z 38 | 39 | - added lower/upper option for Aniki::Plugin::Pager 40 | - added no_offset option for Aniki::Plugin::SQLPager 41 | 42 | 1.00 2016-05-24T05:10:36Z 43 | 44 | - no execute any query if empty values is passed to insert_multi 45 | 46 | 0.94 2016-05-16T09:22:14Z 47 | 48 | - fixed circular reference problem 49 | 50 | 0.93 2016-04-09T03:22:49Z 51 | 52 | - set empty value if not found reletad rows for preformance 53 | - [EXPERIMENTAL] allows extra where condition with prefetch 54 | 55 | 0.92 2016-03-02T03:29:01Z 56 | 57 | - follow the null values in relationship 58 | 59 | 0.91 2016-02-23T06:24:26Z 60 | 61 | - support `trace_query` option 62 | 63 | 0.90 2016-02-23T02:11:26Z 64 | 65 | - follow unique indices for `has_many` 66 | 67 | 0.89 2016-02-21T03:17:18Z 68 | 69 | - fixed pod syntax 70 | 71 | 0.88 2016-02-19T08:42:25Z 72 | 73 | - [BUGFIX] fixed `last_insert_id` on MySQL. (`DBIx::Handler#dbh` send a ping to mysql. But, It removes `$dbh->{mysql_insertid}`.) 74 | 75 | 0.87 2016-02-02T01:33:39Z 76 | 77 | - Allow to enable `suppress_(row|result)_objects` on select_by_sql and select_named. 78 | 79 | 0.86 2016-01-26T02:39:43Z 80 | 81 | - Split Aniki::Plugin::PagerInjector 82 | - Added Aniki::Plugin::SQLPager 83 | 84 | 0.85 2015-12-10T10:31:33Z 85 | 86 | - Fixed no disconnect if caught not a connect error at retring in Aniki::Handler::RoundRobin 87 | 88 | 0.84 2015-12-08T02:22:09Z 89 | 90 | - Fixed generated class name by install-aniki 91 | 92 | 0.83 2015-10-28T03:20:40Z 93 | 94 | - Follow `0` and NULL in default value on insert_and_emulate_row method. 95 | 96 | 0.82 2015-10-27T15:38:40Z 97 | 98 | - Use Test::Requires for checking the modules installed (syohex) 99 | 100 | 0.81 2015-10-27T03:20:57Z 101 | 102 | - switch to old style package declation syntax for some old static code analyzers 103 | 104 | 0.08 2015-10-26T12:39:36Z 105 | 106 | - Split handler class from main class. 107 | - Added WeightedRoundRobin plugin. 108 | 109 | 0.07 2015-10-13T07:59:29Z 110 | 111 | - Fixed broken suppress_row_objects option of select method. 112 | 113 | 0.06 2015-10-13T00:39:45Z 114 | 115 | - A little refactor. (no feature changes) 116 | 117 | 0.05 2015-10-12T18:17:51Z 118 | 119 | - Renamed some methods/classes 120 | - Performance improvements 121 | - Support custom result class 122 | - Added insert_and_emulate_row method 123 | - Use prepare_cached as default 124 | - Unsupport fields case for consistency 125 | - Added skeleton generator 126 | 127 | 0.04_03 2015-09-29T00:59:39Z 128 | 129 | - Keep inflated rows to keep relay cache 130 | 131 | 0.04_02 2015-09-28T08:26:21Z 132 | 133 | - Plugin::SelectJoined is broken when outer joined. 134 | 135 | 0.04_01 2015-09-28T07:00:10Z 136 | 137 | - Added Plugin::SelectJoined (inspired by Teng::Plugin::SearchJoined) 138 | - Support to select specified columns by table 139 | 140 | 0.03_01 2015-09-22T04:58:09Z 141 | 142 | - Support automatic pre-cache the inverse relational rows 143 | 144 | 0.02_09 2015-09-19T05:23:54Z 145 | 146 | - Support the canonicalize of the `SELECT` SQL statement 147 | - Support deep prefetch 148 | 149 | 0.02_08 2015-07-28T03:42:15Z 150 | 151 | - Fixed Aniki::Row#can. (It's broken when it's called as instance method.) 152 | 153 | 0.02_07 2015-07-28T02:40:43Z 154 | 155 | - Change pluralize logic. (now pluralize last word only. SEE ALSO: https://github.com/karupanerura/Aniki/commit/13998800dc48fbed7ca1ca3bae64935c4aad78f5) 156 | 157 | 0.02_06 2015-07-27T04:45:03Z 158 | 159 | - Added API `new_row_from_hashref` and `new_collection_from_arrayref`. 160 | 161 | 0.02_05 2015-07-24T03:32:03Z 162 | 163 | - Aniki::Row#can now returns AUTOLOADed methods. 164 | 165 | 0.02_04 2015-05-28T02:16:47Z 166 | 167 | - Fixed bulk_insert. (filterd value is not used.) 168 | - Improve error message when specified not defined column. 169 | 170 | 0.02_03 2015-05-22T11:06:35Z 171 | 172 | - Added testing for `Aniki::Plugin::Count`. 173 | - Something fixes. 174 | 175 | 0.02_02 2015-05-01T09:44:45Z 176 | 177 | - Added testing for `Aniki::Plugin::Pager`. 178 | - Something fixes. 179 | 180 | 0.02_01 2015-04-20T23:43:26Z 181 | 182 | - Use strict query builder mode by default. 183 | - Added support a named placeholder. 184 | - Added support to declaring relationship. 185 | - Added `count` to Collection. 186 | - Added `is_new` flag to Row class. 187 | - Added `refetch` method to Row class. 188 | - Added shortcut to `txn_manger`. 189 | - Added plugin for paging. 190 | - Added plugin for `SELECT COUNT(...)`. 191 | - Added some tests. 192 | 193 | 0.01_03 2015-02-09T00:14:31Z 194 | 195 | - Fixed guessing relationship name algorithm. (when defined multiple foreign key.) 196 | 197 | 0.01_02 2015-02-02T09:51:41Z 198 | 199 | - Fixed guessing relationship name algorithm. 200 | - Fixed dependencies 201 | 202 | 0.01_01 2015-01-22T10:30:31Z 203 | 204 | - original version 205 | 206 | -------------------------------------------------------------------------------- /lib/Aniki/Row.pm: -------------------------------------------------------------------------------- 1 | package Aniki::Row; 2 | use 5.014002; 3 | 4 | use namespace::autoclean; 5 | use Mouse v2.4.5; 6 | use Carp qw/croak/; 7 | 8 | has table_name => ( 9 | is => 'ro', 10 | required => 1, 11 | ); 12 | 13 | has row_data => ( 14 | is => 'ro', 15 | required => 1, 16 | ); 17 | 18 | has is_new => ( 19 | is => 'rw', 20 | default => 0, 21 | ); 22 | 23 | has relay_data => ( 24 | is => 'ro', 25 | default => sub { +{} }, 26 | ); 27 | 28 | my %handler; 29 | 30 | sub BUILD { 31 | my ($self, $args) = @_; 32 | $handler{0+$self} = delete $args->{handler}; 33 | } 34 | 35 | sub handler { $handler{0+shift} } 36 | sub schema { shift->handler->schema } 37 | sub filter { shift->handler->filter } 38 | 39 | sub table { 40 | my $self = shift; 41 | return $self->handler->schema->get_table($self->table_name); 42 | } 43 | 44 | sub get { 45 | my ($self, $column) = @_; 46 | return $self->{__instance_cache}{get}{$column} if exists $self->{__instance_cache}{get}{$column}; 47 | 48 | return undef unless exists $self->row_data->{$column}; ## no critic 49 | 50 | my $data = $self->get_column($column); 51 | return $self->{__instance_cache}{get}{$column} = $self->filter->inflate_column($self->table_name, $column, $data); 52 | } 53 | 54 | sub relay { 55 | my ($self, $key) = @_; 56 | unless (exists $self->relay_data->{$key}) { 57 | $self->relay_data->{$key} = $self->relay_fetch($key); 58 | } 59 | 60 | my $relay_data = $self->relay_data->{$key}; 61 | return unless defined $relay_data; 62 | return wantarray ? @$relay_data : $relay_data if ref $relay_data eq 'ARRAY'; 63 | return $relay_data; 64 | } 65 | 66 | sub relay_fetch { 67 | my ($self, $key) = @_; 68 | $self->handler->fetch_and_attach_relay_data($self->table_name, [$key], [$self]); 69 | return $self->relay_data->{$key}; 70 | } 71 | 72 | sub is_prefetched { 73 | my ($self, $key) = @_; 74 | return exists $self->relay_data->{$key}; 75 | } 76 | 77 | sub get_column { 78 | my ($self, $column) = @_; 79 | return undef unless exists $self->row_data->{$column}; ## no critic 80 | return $self->row_data->{$column}; 81 | } 82 | 83 | sub get_columns { 84 | my $self = shift; 85 | 86 | my %row; 87 | for my $column (keys %{ $self->row_data }) { 88 | $row{$column} = $self->row_data->{$column}; 89 | } 90 | return \%row; 91 | } 92 | 93 | sub refetch { 94 | my ($self, $opts) = @_; 95 | $opts //= +{}; 96 | $opts->{limit} = 1; 97 | 98 | my $where = $self->handler->_where_row_cond($self->table, $self->row_data); 99 | return $self->handler->select($self->table_name => $where, $opts)->first; 100 | } 101 | 102 | my %accessor_method_cache; 103 | sub _accessor_method_cache { 104 | my $self = shift; 105 | return $accessor_method_cache{$self->table_name} //= {}; 106 | } 107 | 108 | sub _guess_accessor_method { 109 | my ($invocant, $method) = @_; 110 | 111 | if (ref $invocant) { 112 | my $self = $invocant; 113 | my $column = $method; 114 | 115 | my $cache = $self->_accessor_method_cache(); 116 | return $cache->{$column} if exists $cache->{$column}; 117 | 118 | return $cache->{$column} = sub { shift->get($column) } if exists $self->row_data->{$column}; 119 | 120 | my $relationships = $self->table->get_relationships; 121 | return $cache->{$column} = sub { shift->relay($column) } if $relationships && $relationships->get($column); 122 | } 123 | 124 | return undef; ## no critic 125 | } 126 | 127 | sub can { 128 | my ($invocant, $method) = @_; 129 | my $code = $invocant->SUPER::can($method); 130 | return $code if defined $code; 131 | return $invocant->_guess_accessor_method($method); 132 | } 133 | 134 | our $AUTOLOAD; 135 | sub AUTOLOAD { 136 | my $invocant = shift; 137 | my $column = $AUTOLOAD =~ s/^.+://r; 138 | 139 | if (ref $invocant) { 140 | my $self = $invocant; 141 | my $method = $self->_guess_accessor_method($column); 142 | return $self->$method(@_) if defined $method; 143 | } 144 | 145 | my $msg = sprintf q{Can't locate object method "%s" via package "%s"}, $column, ref $invocant || $invocant; 146 | croak $msg; 147 | } 148 | 149 | sub DEMOLISH { 150 | my $self = shift; 151 | delete $handler{0+$self}; 152 | } 153 | 154 | __PACKAGE__->meta->make_immutable(); 155 | __END__ 156 | 157 | =pod 158 | 159 | =encoding utf-8 160 | 161 | =head1 NAME 162 | 163 | Aniki::Row - Row class 164 | 165 | =head1 SYNOPSIS 166 | 167 | my $result = $db->select(foo => { bar => 1 }); 168 | for my $row ($result->all) { 169 | print $row->id, "\n"; 170 | } 171 | 172 | =head1 DESCRIPTION 173 | 174 | This is row class. 175 | 176 | =head1 INSTANCE METHODS 177 | 178 | =head2 C<$column()> 179 | 180 | Autoload column name method to C<< $row->get($column) >>. 181 | 182 | =head2 C<$relay()> 183 | 184 | Autoload relationship name method to C<< $row->relay($column) >>. 185 | 186 | =head2 C 187 | 188 | Returns column data. 189 | 190 | =head2 C 191 | 192 | Returns related data. 193 | If not yet cached, call C. 194 | 195 | =head2 C 196 | 197 | Fetch related data, and returns related data. 198 | 199 | =head2 C 200 | 201 | If a pre-fetch has been executed, it return a true value. 202 | 203 | =head2 C 204 | 205 | Returns column data without inflate filters. 206 | 207 | =head2 C 208 | 209 | Returns columns data as hash reference. 210 | 211 | =head2 C 212 | 213 | =head1 ACCESSORS 214 | 215 | =over 4 216 | 217 | =item C 218 | 219 | =item C 220 | 221 | =item C
222 | 223 | =item C 224 | 225 | =item C 226 | 227 | =item C 228 | 229 | =item C 230 | 231 | =item C 232 | 233 | =back 234 | 235 | =head1 LICENSE 236 | 237 | Copyright (C) karupanerura. 238 | 239 | This library is free software; you can redistribute it and/or modify 240 | it under the same terms as Perl itself. 241 | 242 | =head1 AUTHOR 243 | 244 | karupanerura Ekarupa@cpan.orgE 245 | 246 | =cut 247 | -------------------------------------------------------------------------------- /author/benchmark.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | use feature qw/say/; 5 | 6 | use lib 'lib'; 7 | use SampleDbic::Schema; 8 | use SampleAniki::DB; 9 | use SampleAniki::DB::Schema; 10 | use SampleTeng::DB; 11 | use Benchmark qw/cmpthese timethese/; 12 | 13 | my $aniki = SampleAniki::DB->new(connect_info => ["dbi:SQLite:dbname=:memory:", "", "", { ShowErrorStatement => 1 }]); 14 | my $dbic = SampleDbic::Schema->connect('dbi:SQLite:dbname=:memory:'); 15 | my $teng = SampleTeng::DB->new({ connect_info => ["dbi:SQLite:dbname=:memory:", "", ""], sql_builder_args => { strict => 1 } }); 16 | 17 | $aniki->dbh->do($_) for split /;/, SampleAniki::DB::Schema->output; 18 | $teng->dbh->do($_) for split /;/, SampleAniki::DB::Schema->output; 19 | $dbic->storage->dbh->do($_) for split /;/, SampleAniki::DB::Schema->output; 20 | 21 | say '=============== SCHEMA ==============='; 22 | print SampleAniki::DB::Schema->output; 23 | 24 | say '=============== INSERT (no fetch) ==============='; 25 | my ($dbic_id, $teng_id, $aniki_id) = (0, 0, 0); 26 | timethese 100000 => { 27 | aniki => sub { 28 | $aniki->insert('author' => { 29 | name => "name:".$aniki_id++, 30 | }); 31 | }, 32 | }; 33 | 34 | $aniki->dbh->do('DELETE FROM author'); 35 | $aniki->dbh->do('DELETE FROM sqlite_sequence WHERE name = ?', undef, 'author'); 36 | 37 | say '=============== INSERT (fetch auto increment id only) ==============='; 38 | ($dbic_id, $teng_id, $aniki_id) = (0, 0, 0); 39 | cmpthese timethese 100000 => { 40 | teng => sub { 41 | my $id = $teng->fast_insert('author' => { 42 | name => "name:".$teng_id++, 43 | }); 44 | }, 45 | aniki => sub { 46 | my $id = $aniki->insert_and_fetch_id('author' => { 47 | name => "name:".$aniki_id++, 48 | }); 49 | }, 50 | }; 51 | 52 | $aniki->dbh->do('DELETE FROM author'); 53 | $aniki->dbh->do('DELETE FROM sqlite_sequence WHERE name = ?', undef, 'author'); 54 | $teng->dbh->do('DELETE FROM author'); 55 | $teng->dbh->do('DELETE FROM sqlite_sequence WHERE name = ?', undef, 'author'); 56 | 57 | say '=============== INSERT ==============='; 58 | ($dbic_id, $teng_id, $aniki_id) = (0, 0, 0); 59 | cmpthese { 60 | %{ 61 | timethese 20000 => { 62 | dbic => sub { 63 | my $row = $dbic->resultset('Author')->create({ 64 | name => "name:".$dbic_id++, 65 | }); 66 | }, 67 | teng => sub { 68 | my $row = $teng->insert('author' => { 69 | name => "name:".$teng_id++, 70 | }); 71 | }, 72 | 'aniki(emulate)' => sub { 73 | my $row = $aniki->insert_and_emulate_row('author' => { 74 | name => "name:".$aniki_id++, 75 | }); 76 | }, 77 | } 78 | }, 79 | do { 80 | $aniki->dbh->do('DELETE FROM author'); 81 | $aniki->dbh->do('DELETE FROM sqlite_sequence WHERE name = ?', undef, 'author'); 82 | (); 83 | }, 84 | %{ 85 | timethese 20000 => { 86 | 'aniki(fetch)' => sub { 87 | my $row = $aniki->insert_and_fetch_row('author' => { 88 | name => "name:".$aniki_id++, 89 | }); 90 | }, 91 | } 92 | }, 93 | }; 94 | 95 | 96 | say '=============== SELECT ==============='; 97 | cmpthese timethese 20000 => { 98 | dbic => sub { 99 | my @rows = $dbic->resultset('Author')->search({}, { rows => 10, order_by => { -asc => 'id' } })->all; 100 | }, 101 | teng => sub { 102 | my @rows = $teng->search('author' => {}, { limit => 10, order_by => { id => 'ASC' } })->all; 103 | }, 104 | aniki => sub { 105 | my @rows = $aniki->select('author' => {}, { limit => 10, order_by => { id => 'ASC' } })->all; 106 | }, 107 | }; 108 | 109 | say '=============== UPDATE ==============='; 110 | cmpthese timethese 20000 => { 111 | dbic => sub { 112 | my $row = $dbic->resultset('Author')->single({ id => 1 }); 113 | $row->update({ message => 'good morning' }); 114 | }, 115 | 'teng(row)' => sub { 116 | my $row = $teng->single('author' => { id => 1 }); 117 | $row->update({ message => 'good morning' }); 118 | }, 119 | teng => sub { 120 | $teng->update('author' => { message => 'good morning' }, { id => 1 }); 121 | }, 122 | 'aniki(row)' => sub { 123 | my $row = $aniki->select('author' => { id => 1 }, { limit => 1 })->first; 124 | $aniki->update($row => { message => 'good morning' }); 125 | }, 126 | aniki => sub { 127 | $aniki->update('author' => { message => 'good morning' }, { id => 1 }); 128 | }, 129 | }; 130 | 131 | say '=============== DELETE ==============='; 132 | my ($dbic_delete_id, $teng_delete_id, $aniki_delete_id) = (0, 0, 0); 133 | cmpthese { 134 | %{ 135 | timethese 20000 => { 136 | dbic => sub { 137 | my $row = $dbic->resultset('Author')->single({ id => ++$dbic_delete_id }); 138 | $row->delete; 139 | }, 140 | 'teng(row)' => sub { 141 | my $row = $teng->single('author' => { id => ++$teng_delete_id }); 142 | $row->delete; 143 | }, 144 | 'aniki(row)' => sub { 145 | my $row = $aniki->select('author' => { id => ++$aniki_delete_id }, { limit => 1 })->first; 146 | $aniki->delete($row); 147 | }, 148 | } 149 | }, 150 | do { 151 | ($teng_delete_id, $aniki_delete_id) = (0, 0); 152 | $aniki->dbh->do('DELETE FROM author'); 153 | $aniki->dbh->do('DELETE FROM sqlite_sequence WHERE name = ?', undef, 'author'); 154 | $teng->dbh->do('DELETE FROM author'); 155 | $teng->dbh->do('DELETE FROM sqlite_sequence WHERE name = ?', undef, 'author'); 156 | 157 | for my $i (1..20000) { 158 | $aniki->insert('author' => { name => "name:".$i }); 159 | $teng->fast_insert('author' => { name => "name:".$i }); 160 | } 161 | 162 | (); 163 | }, 164 | %{ 165 | timethese 20000 => { 166 | teng => sub { 167 | $teng->delete('author' => { id => ++$teng_delete_id }); 168 | }, 169 | aniki => sub { 170 | $aniki->delete('author' => { id => ++$aniki_delete_id }); 171 | }, 172 | } 173 | } 174 | }; 175 | -------------------------------------------------------------------------------- /t/11_relay.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | 7 | use File::Spec; 8 | use lib File::Spec->catfile('t', 'lib'); 9 | use t::Util; 10 | 11 | run_on_database { 12 | my $moznion_id = db->insert_and_fetch_id(author => { name => 'MOZNION' }); 13 | my @moznion_module_ids = ( 14 | db->insert_and_fetch_id(module => { name => 'Perl::Lint', author_id => $moznion_id }), 15 | db->insert_and_fetch_id(module => { name => 'Regexp::Lexer', author_id => $moznion_id }), 16 | db->insert_and_fetch_id(module => { name => 'Test::JsonAPI::Autodoc', author_id => $moznion_id }), 17 | ); 18 | 19 | my $karupa_id = db->insert_and_fetch_id(author => { name => 'KARUPA' }); 20 | my @karupa_module_ids = ( 21 | db->insert_and_fetch_id(module => { name => 'TOML::Parser', author_id => $karupa_id }), 22 | db->insert_and_fetch_id(module => { name => 'Plack::App::Vhost', author_id => $karupa_id }), 23 | db->insert_and_fetch_id(module => { name => 'Test::SharedObject', author_id => $karupa_id }), 24 | ); 25 | 26 | my $mamimu_id = db->insert_and_fetch_id(author => { name => 'MAMIMU' }); 27 | 28 | db->insert_multi(version => [map { 29 | +{ name => '0.01', module_id => $_ }, 30 | } @moznion_module_ids, @karupa_module_ids]); 31 | 32 | subtest 'shallow' => sub { 33 | subtest 'prefetch' => sub { 34 | my $queries = query_count { 35 | my $rows = db->select(author => {}, { prefetch => [qw/modules/] }); 36 | isa_ok $rows, 'Aniki::Result::Collection'; 37 | is $rows->count, 3; 38 | ok $_->is_prefetched('modules') for $rows->all; 39 | 40 | my %modules = map { $_->name => [sort map { $_->name } $_->modules] } $rows->all; 41 | is_deeply \%modules, { 42 | MOZNION => [qw/Perl::Lint Regexp::Lexer Test::JsonAPI::Autodoc/], 43 | KARUPA => [qw/Plack::App::Vhost TOML::Parser Test::SharedObject/], 44 | MAMIMU => [], 45 | }; 46 | }; 47 | is $queries, 2; 48 | }; 49 | 50 | subtest 'lazy' => sub { 51 | my $queries = query_count { 52 | my $rows = db->select(author => {}); 53 | isa_ok $rows, 'Aniki::Result::Collection'; 54 | is $rows->count, 3; 55 | ok !$_->is_prefetched('modules') for $rows->all; 56 | 57 | my %modules = map { $_->name => [sort map { $_->name } $_->modules] } $rows->all; 58 | is_deeply \%modules, { 59 | MOZNION => [qw/Perl::Lint Regexp::Lexer Test::JsonAPI::Autodoc/], 60 | KARUPA => [qw/Plack::App::Vhost TOML::Parser Test::SharedObject/], 61 | MAMIMU => [], 62 | }; 63 | }; 64 | is $queries, 4; 65 | }; 66 | }; 67 | 68 | subtest 'deep' => sub { 69 | subtest 'prefetch' => sub { 70 | my $queries = query_count { 71 | my $rows = db->select(author => {}, { prefetch => { modules => [qw/versions/] } }); 72 | isa_ok $rows, 'Aniki::Result::Collection'; 73 | is $rows->count, 3; 74 | for my $row ($rows->all) { 75 | ok $row->is_prefetched('modules'); 76 | ok $_->is_prefetched('versions') for $row->modules; 77 | } 78 | 79 | my %modules = map { 80 | $_->name => +{ 81 | map { 82 | $_->name => [map { $_->name } $_->versions], 83 | } $_->modules 84 | } 85 | } $rows->all; 86 | is_deeply \%modules, { 87 | MOZNION => +{ 88 | 'Perl::Lint' => ['0.01'], 89 | 'Regexp::Lexer' => ['0.01'], 90 | 'Test::JsonAPI::Autodoc' => ['0.01'], 91 | }, 92 | KARUPA => +{ 93 | 'Plack::App::Vhost' => ['0.01'], 94 | 'TOML::Parser' => ['0.01'], 95 | 'Test::SharedObject' => ['0.01'], 96 | }, 97 | MAMIMU => +{ 98 | }, 99 | }; 100 | }; 101 | is $queries, 3; 102 | }; 103 | 104 | subtest 'lazy' => sub { 105 | my $queries = query_count { 106 | my $rows = db->select(author => {}); 107 | isa_ok $rows, 'Aniki::Result::Collection'; 108 | is $rows->count, 3; 109 | for my $row ($rows->all) { 110 | ok !$row->is_prefetched('modules'); 111 | ok !$_->is_prefetched('versions') for $row->modules; 112 | } 113 | 114 | my %modules = map { 115 | $_->name => +{ 116 | map { 117 | $_->name => [map { $_->name } $_->versions], 118 | } $_->modules 119 | } 120 | } $rows->all; 121 | is_deeply \%modules, { 122 | MOZNION => +{ 123 | 'Perl::Lint' => ['0.01'], 124 | 'Regexp::Lexer' => ['0.01'], 125 | 'Test::JsonAPI::Autodoc' => ['0.01'], 126 | }, 127 | KARUPA => +{ 128 | 'Plack::App::Vhost' => ['0.01'], 129 | 'TOML::Parser' => ['0.01'], 130 | 'Test::SharedObject' => ['0.01'], 131 | }, 132 | MAMIMU => +{ 133 | }, 134 | }; 135 | }; 136 | is $queries, 10; 137 | }; 138 | }; 139 | 140 | subtest 'inverse' => sub { 141 | subtest 'prefetch' => sub { 142 | my $queries = query_count { 143 | my $rows = db->select(author => {}, { prefetch => { modules => [qw/versions/] } }); 144 | isa_ok $rows, 'Aniki::Result::Collection'; 145 | is $rows->count, 3; 146 | for my $row ($rows->all) { 147 | ok $row->is_prefetched('modules'); 148 | ok $_->is_prefetched('versions') for $row->modules; 149 | } 150 | 151 | my %modules = map { $_->versions->[0]->module->name => [$_->author->name, map { $_->name } @{ $_->versions }] } map { $_->modules } $rows->all; 152 | is_deeply \%modules, { 153 | 'Perl::Lint' => ['MOZNION', '0.01'], 154 | 'Regexp::Lexer' => ['MOZNION', '0.01'], 155 | 'Test::JsonAPI::Autodoc' => ['MOZNION', '0.01'], 156 | 'Plack::App::Vhost' => ['KARUPA', '0.01'], 157 | 'TOML::Parser' => ['KARUPA', '0.01'], 158 | 'Test::SharedObject' => ['KARUPA', '0.01'], 159 | } or diag explain \%modules; 160 | }; 161 | is $queries, 3; 162 | }; 163 | 164 | subtest 'lazy' => sub { 165 | my $queries = query_count { 166 | my $rows = db->select(author => {}); 167 | isa_ok $rows, 'Aniki::Result::Collection'; 168 | is $rows->count, 3; 169 | for my $row ($rows->all) { 170 | ok !$row->is_prefetched('modules'); 171 | ok !$_->is_prefetched('versions') for $row->modules; 172 | } 173 | 174 | my %modules = map { $_->versions->[0]->module->name => [$_->author->name, map { $_->name } @{ $_->versions }] } map { $_->modules } $rows->all; 175 | is_deeply \%modules, { 176 | 'Perl::Lint' => ['MOZNION', '0.01'], 177 | 'Regexp::Lexer' => ['MOZNION', '0.01'], 178 | 'Test::JsonAPI::Autodoc' => ['MOZNION', '0.01'], 179 | 'Plack::App::Vhost' => ['KARUPA', '0.01'], 180 | 'TOML::Parser' => ['KARUPA', '0.01'], 181 | 'Test::SharedObject' => ['KARUPA', '0.01'], 182 | } or diag explain \%modules; 183 | }; 184 | is $queries, 10; 185 | }; 186 | }; 187 | 188 | db->insert_multi(version => [map { 189 | +{ name => '0.02', module_id => $_ }, 190 | } @moznion_module_ids, @karupa_module_ids]); 191 | 192 | subtest 'extra where conditions' => sub { 193 | my $queries = query_count { 194 | my $rows = db->select(author => {}, { prefetch => { modules => { versions => { '.name' => '0.02' } } } }); 195 | isa_ok $rows, 'Aniki::Result::Collection'; 196 | is $rows->count, 3; 197 | for my $row ($rows->all) { 198 | ok $row->is_prefetched('modules'); 199 | ok $_->is_prefetched('versions') for $row->modules; 200 | } 201 | 202 | my %modules = map { 203 | $_->name => +{ 204 | map { 205 | $_->name => [map { $_->name } $_->versions], 206 | } $_->modules 207 | } 208 | } $rows->all; 209 | is_deeply \%modules, { 210 | MOZNION => +{ 211 | 'Perl::Lint' => ['0.02'], 212 | 'Regexp::Lexer' => ['0.02'], 213 | 'Test::JsonAPI::Autodoc' => ['0.02'], 214 | }, 215 | KARUPA => +{ 216 | 'Plack::App::Vhost' => ['0.02'], 217 | 'TOML::Parser' => ['0.02'], 218 | 'Test::SharedObject' => ['0.02'], 219 | }, 220 | MAMIMU => +{ 221 | }, 222 | } or diag explain \%modules; 223 | }; 224 | is $queries, 3; 225 | }; 226 | }; 227 | 228 | done_testing(); 229 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Build Status](https://circleci.com/gh/karupanerura/Aniki.svg)](https://circleci.com/gh/karupanerura/Aniki) [![Coverage Status](http://codecov.io/github/karupanerura/Aniki/coverage.svg?branch=master)](https://codecov.io/github/karupanerura/Aniki?branch=master) [![MetaCPAN Release](https://badge.fury.io/pl/Aniki.svg)](https://metacpan.org/release/Aniki) 2 | # NAME 3 | 4 | Aniki - The ORM as our great brother. 5 | 6 | # SYNOPSIS 7 | 8 | ```perl 9 | use 5.014002; 10 | package MyProj::DB::Schema { 11 | use DBIx::Schema::DSL; 12 | 13 | database 'SQLite'; 14 | 15 | create_table 'module' => columns { 16 | integer 'id', primary_key, auto_increment; 17 | varchar 'name'; 18 | integer 'author_id'; 19 | 20 | add_index 'author_id_idx' => ['author_id']; 21 | 22 | belongs_to 'author'; 23 | }; 24 | 25 | create_table 'author' => columns { 26 | integer 'id', primary_key, auto_increment; 27 | varchar 'name', unique; 28 | }; 29 | }; 30 | 31 | package MyProj::DB::Filter { 32 | use Aniki::Filter::Declare; 33 | use Scalar::Util qw/blessed/; 34 | use Time::Moment; 35 | 36 | # define inflate/deflate filters in table context. 37 | table author => sub { 38 | inflate name => sub { 39 | my $name = shift; 40 | return uc $name; 41 | }; 42 | 43 | deflate name => sub { 44 | my $name = shift; 45 | return lc $name; 46 | }; 47 | }; 48 | 49 | inflate qr/_at$/ => sub { 50 | my $datetime = shift; 51 | $datetime =~ tr/ /T/; 52 | $datetime .= 'Z'; 53 | return Time::Moment->from_string($datetime); 54 | }; 55 | 56 | deflate qr/_at$/ => sub { 57 | my $datetime = shift; 58 | return $datetime->at_utc->strftime('%F %T') if blessed $datetime and $datetime->isa('Time::Moment'); 59 | return $datetime; 60 | }; 61 | }; 62 | 63 | package MyProj::DB { 64 | use Mouse v2.4.5; 65 | extends qw/Aniki/; 66 | 67 | __PACKAGE__->setup( 68 | schema => 'MyProj::DB::Schema', 69 | filter => 'MyProj::DB::Filter', 70 | ); 71 | }; 72 | 73 | package main { 74 | my $db = MyProj::DB->new(connect_info => ["dbi:SQLite:dbname=:memory:", "", ""]); 75 | $db->execute($_) for split /;/, MyProj::DB::Schema->output; 76 | 77 | my $author_id = $db->insert_and_fetch_id(author => { name => 'songmu' }); 78 | 79 | $db->insert(module => { 80 | name => 'DBIx::Schema::DSL', 81 | author_id => $author_id, 82 | }); 83 | $db->insert(module => { 84 | name => 'Riji', 85 | author_id => $author_id, 86 | }); 87 | 88 | my $module = $db->select(module => { 89 | name => 'Riji', 90 | }, { 91 | limit => 1, 92 | })->first; 93 | say '$module->name: ', $module->name; ## Riji 94 | say '$module->author->name: ', $module->author->name; ## SONGMU 95 | 96 | my $author = $db->select(author => { 97 | name => 'songmu', 98 | }, { 99 | limit => 1, 100 | prefetch => [qw/modules/], 101 | })->first; 102 | 103 | say '$author->name: ', $author->name; ## SONGMU 104 | say 'modules[]->name: ', $_->name for $author->modules; ## DBIx::Schema::DSL, Riji 105 | }; 106 | 107 | 1; 108 | ``` 109 | 110 | # DESCRIPTION 111 | 112 | Aniki is ORM. 113 | Lite, but powerful. 114 | 115 | ## FEATURES 116 | 117 | - Small & Simple 118 | 119 | You can read codes easily. 120 | 121 | - Object mapping 122 | 123 | Inflates rows to [Aniki::Result::Collection](https://metacpan.org/pod/Aniki::Result::Collection) object. 124 | And inflates row to [Aniki::Row](https://metacpan.org/pod/Aniki::Row) object. 125 | 126 | You can change result class, also we can change row class. 127 | Aniki dispatches result/row class by table. (e.g. `foo` table to `MyDB::Row::Foo`) 128 | 129 | - Raw SQL support 130 | 131 | Supports to execute raw `SELECT` SQL and fetch rows of result. 132 | Of course, Aniki can inflate to result/row also. 133 | 134 | - Query builder 135 | 136 | Aniki includes query builder powered by [SQL::Maker](https://metacpan.org/pod/SQL::Maker). 137 | [SQL::Maker](https://metacpan.org/pod/SQL::Maker) is fast and secure SQL builder. 138 | 139 | - Fork safe & Transaction support 140 | 141 | Aniki includes [DBI](https://metacpan.org/pod/DBI) handler powered by [DBIx::Handler](https://metacpan.org/pod/DBIx::Handler). 142 | 143 | - Error handling 144 | 145 | Easy to handle execution errors by `handle_error` method. 146 | You can override it. 147 | 148 | - Extendable 149 | 150 | You can extend Aniki by [Mouse::Role](https://metacpan.org/pod/Mouse::Role). 151 | Aniki provides some default plugins as [Mouse::Role](https://metacpan.org/pod/Mouse::Role). 152 | 153 | ## RELATIONSHIP 154 | 155 | Aniki supports relationship. 156 | Extracts relationship from schema class. 157 | 158 | Example: 159 | 160 | ```perl 161 | use 5.014002; 162 | package MyProj::DB::Schema { 163 | use DBIx::Schema::DSL; 164 | 165 | create_table 'module' => columns { 166 | integer 'id', primary_key, auto_increment; 167 | varchar 'name'; 168 | integer 'author_id'; 169 | 170 | add_index 'author_id_idx' => ['author_id']; 171 | 172 | belongs_to 'author'; 173 | }; 174 | 175 | create_table 'author' => columns { 176 | integer 'id', primary_key, auto_increment; 177 | varchar 'name', unique; 178 | }; 179 | }; 180 | ``` 181 | 182 | A `author` has many `modules`. 183 | So you can access `author` row object to `modules`. 184 | 185 | ```perl 186 | my $author = $db->select(author => { name => 'songmu' })->first; 187 | say 'modules[]->name: ', $_->name for $author->modules; ## DBIx::Schema::DSL, Riji 188 | ``` 189 | 190 | Also `module` has a `author`. 191 | So you can access `module` row object to `author` also. 192 | 193 | ```perl 194 | my $module = $db->select(module => { name => 'Riji' })->first; 195 | say "Riji's author is ", $module->author->name; ## SONGMU 196 | ``` 197 | 198 | And you can pre-fetch related rows. 199 | 200 | ```perl 201 | my @modules = $db->select(module => {}, { prefetch => [qw/author/] }); 202 | say $_->name, "'s author is ", $_->author->name for @modules; 203 | ``` 204 | 205 | # SETUP 206 | 207 | Install Aniki from CPAN: 208 | 209 | ``` 210 | cpanm Aniki 211 | ``` 212 | 213 | And run `install-aniki` command. 214 | 215 | ``` 216 | install-aniki --lib=./lib MyApp::DB 217 | ``` 218 | 219 | `install-aniki` creates skeleton modules. 220 | 221 | # METHODS 222 | 223 | ## CLASS METHODS 224 | 225 | ### `setup(%args)` 226 | 227 | Initialize and customize Aniki class. 228 | `schema` is required. Others are optional. 229 | 230 | #### Arguments 231 | 232 | - schema : ClassName 233 | - handler : ClassName 234 | - filter : ClassName 235 | - row : ClassName 236 | - result : ClassName 237 | - query\_builder : ClassName 238 | 239 | ### `use_prepare_cached` 240 | 241 | If this method returns true value, Aniki uses `preare_cached`. 242 | This method returns true value default. 243 | So you don't need to use `preare_cached`, override it and return false value. 244 | 245 | ### `use_strict_query_builder` 246 | 247 | If this method returns true value, Aniki enables [SQL::Maker](https://metacpan.org/pod/SQL::Maker)'s strict mode. 248 | This method returns true value default. 249 | So you need to disable [SQL::Maker](https://metacpan.org/pod/SQL::Maker)'s strict mode, override it and return false value. 250 | 251 | SEE ALSO: [The JSON SQL Injection Vulnerability](http://blog.kazuhooku.com/2014/07/the-json-sql-injection-vulnerability.html) 252 | 253 | ### `preload_all_row_classes` 254 | 255 | Preload all row classes. 256 | 257 | ### `preload_all_result_classes` 258 | 259 | Preload all result classes. 260 | 261 | ### `guess_result_class($table_name) : ClassName` 262 | 263 | Guesses result class by table name. 264 | 265 | ### `guess_row_class($table_name) : ClassName` 266 | 267 | Guesses row class by table name. 268 | 269 | ### `new(%args) : Aniki` 270 | 271 | Create instance of Aniki. 272 | 273 | #### Arguments 274 | 275 | - `handler : Aniki::Handler` 276 | 277 | Instance of Aniki::Hanlder. 278 | If this argument is given, not required to give `connect_info` for arguments. 279 | 280 | - `connect_info : ArrayRef` 281 | 282 | Auguments for [DBI](https://metacpan.org/pod/DBI)'s connect method. 283 | 284 | - on\_connect\_do : CodeRef|ArrayRef\[Str\]|Str 285 | - on\_disconnect\_do : CodeRef|ArrayRef\[Str\]|Str 286 | 287 | Execute SQL or CodeRef when connected/disconnected. 288 | 289 | - trace\_query : Bool 290 | 291 | Enables to inject a caller information as SQL comment. 292 | SEE ALSO: [DBIx::Handler](https://metacpan.org/pod/DBIx::Handler) 293 | 294 | - trace\_ignore\_if : CodeRef 295 | 296 | Ignore to inject the SQL comment when trace\_ignore\_if's return value is true. 297 | SEE ALSO: [DBIx::Handler](https://metacpan.org/pod/DBIx::Handler) 298 | 299 | - `suppress_row_objects : Bool` 300 | 301 | If this option is true, no create row objects. 302 | Aniki's methods returns hash reference instead of row object. 303 | 304 | - `suppress_result_objects : Bool` 305 | 306 | If this option is true, no create result objects. 307 | Aniki's methods returns array reference instead of result object. 308 | 309 | ## INSTANCE METHODS 310 | 311 | ### `select($table_name, \%where, \%opt)` 312 | 313 | Execute `SELECT` query by generated SQL, and returns result object. 314 | 315 | ```perl 316 | my $result = $db->select(foo => { id => 1 }, { limit => 1 }); 317 | # stmt: SELECT FROM foo WHERE id = ? LIMIT 1 318 | # bind: [1] 319 | ``` 320 | 321 | #### Options 322 | 323 | There are the options of `SELECT` query. 324 | See also [SQL::Maker](https://metacpan.org/pod/SQL::Maker#opt). 325 | 326 | And you can use there options: 327 | 328 | - `suppress_row_objects : Bool` 329 | 330 | If this option is true, no create row objects. 331 | This methods returns hash reference instead of row object. 332 | 333 | - `suppress_result_objects : Bool` 334 | 335 | If this option is true, no create result objects. 336 | This method returns array reference instead of result object. 337 | 338 | - `columns : ArrayRef[Str]` 339 | 340 | List for retrieving columns from database. 341 | 342 | - `prefetch : ArrayRef|HashRef` 343 | 344 | Pre-fetch specified related rows. 345 | See also ["RELATIONSHIP"](#relationship) section. 346 | 347 | ### `select_named($sql, \%bind, \%opt)` 348 | 349 | ### `select_by_sql($sql, \@bind, \%opt)` 350 | 351 | Execute `SELECT` query by specified SQL, and returns result object. 352 | 353 | ```perl 354 | my $result = $db->select_by_sql('SELECT FROM foo WHERE id = ? LIMIT 1', [1]); 355 | # stmt: SELECT FROM foo WHERE id = ? LIMIT 1 356 | # bind: [1] 357 | ``` 358 | 359 | #### Options 360 | 361 | You can use there options: 362 | 363 | - `table_name: Str` 364 | 365 | This is table name using row/result class guessing. 366 | 367 | - `columns: ArrayRef[Str]` 368 | 369 | List for retrieving columns from database. 370 | 371 | - `prefetch: ArrayRef|HashRef` 372 | 373 | Pre-fetch specified related rows. 374 | See also ["RELATIONSHIP"](#relationship) section. 375 | 376 | ### `insert($table_name, \%values, \%opt)` 377 | 378 | Execute `INSERT INTO` query. 379 | 380 | ```perl 381 | $db->insert(foo => { bar => 1 }); 382 | # stmt: INSERT INTO foo (bar) VALUES (?) 383 | # bind: [1] 384 | ``` 385 | 386 | ### `insert_and_fetch_id($table_name, \%values, \%opt)` 387 | 388 | Execute `INSERT INTO` query, and returns `last_insert_id`. 389 | 390 | ```perl 391 | my $id = $db->insert_and_fetch_id(foo => { bar => 1 }); 392 | # stmt: INSERT INTO foo (bar) VALUES (?) 393 | # bind: [1] 394 | ``` 395 | 396 | ### `insert_and_fetch_row($table_name, \%values, \%opt)` 397 | 398 | Execute `INSERT INTO` query, and `SELECT` it, and returns row object. 399 | 400 | ```perl 401 | my $row = $db->insert_and_fetch_row(foo => { bar => 1 }); 402 | # stmt: INSERT INTO foo (bar) VALUES (?) 403 | # bind: [1] 404 | ``` 405 | 406 | ### `insert_and_emulate_row($table_name, \%values, \%opt)` 407 | 408 | Execute `INSERT INTO` query, and returns row object created by `$row` and schema definition. 409 | 410 | ```perl 411 | my $row = $db->insert_and_fetch_row(foo => { bar => 1 }); 412 | # stmt: INSERT INTO foo (bar) VALUES (?) 413 | # bind: [1] 414 | ``` 415 | 416 | This method is faster than `insert_and_fetch_row`. 417 | 418 | #### WARNING 419 | 420 | If you use SQL `TRIGGER` or dynamic default value, this method don't return the correct value, maybe. 421 | In this case, you should use `insert_and_fetch_row` instead of this method. 422 | 423 | ### `insert_on_duplicate($table_name, \%insert, \%update)` 424 | 425 | Execute `INSERT ... ON DUPLICATE KEY UPDATE` query for MySQL. 426 | 427 | ```perl 428 | my $row = $db->insert_on_duplicate(foo => { bar => 1 }, { bar => \'VALUE(bar) + 1' }); 429 | # stmt: INSERT INTO foo (bar) VALUES (?) ON DUPLICATE KEY UPDATE bar = VALUE(bar) + 1 430 | # bind: [1] 431 | ``` 432 | 433 | SEE ALSO: [INSERT ... ON DUPLICATE KEY UPDATE Syntax](https://dev.mysql.com/doc/refman/5.6/en/insert-on-duplicate.html) 434 | 435 | ### `insert_multi($table_name, \@values, \%opts)` 436 | 437 | Execute `INSERT INTO ... (...) VALUES (...), (...), ...` query for MySQL. 438 | Insert multiple rows at once. 439 | 440 | ```perl 441 | my $row = $db->insert_multi(foo => [{ bar => 1 }, { bar => 2 }, { bar => 3 }]); 442 | # stmt: INSERT INTO foo (bar) VALUES (?),(?),(?) 443 | # bind: [1, 2, 3] 444 | ``` 445 | 446 | SEE ALSO: [INSERT Syntax](https://dev.mysql.com/doc/refman/5.6/en/insert.html) 447 | 448 | ### `update($table_name, \%set, \%where)` 449 | 450 | Execute `UPDATE` query, and returns changed rows count. 451 | 452 | ```perl 453 | my $count = $db->update(foo => { bar => 2 }, { id => 1 }); 454 | # stmt: UPDATE foo SET bar = ? WHERE id = ? 455 | # bind: [2, 1] 456 | ``` 457 | 458 | ### `update($row, \%set)` 459 | 460 | Execute `UPDATE` query, and returns changed rows count. 461 | 462 | ```perl 463 | my $row = $db->select(foo => { id => 1 }, { limit => 1 })->first; 464 | my $count = $db->update($row => { bar => 2 }); 465 | # stmt: UPDATE foo SET bar = ? WHERE id = ? 466 | # bind: [2, 1] 467 | ``` 468 | 469 | ### `update_and_fetch_row($row, \%set)` 470 | 471 | Execute `UPDATE` query, and `SELECT` it, and returns row object. 472 | 473 | ```perl 474 | my $row = $db->select(foo => { id => 1 }, { limit => 1 })->first; 475 | my $new_row = $db->update_and_fetch_row($row => { bar => 2 }); 476 | # stmt: UPDATE foo SET bar = ? WHERE id = ? 477 | # bind: [2, 1] 478 | ``` 479 | 480 | ### `update_and_emulate_row($row, \%set)` 481 | 482 | Execute `UPDATE` query, and returns row object created by `$row` and `%set`. 483 | 484 | ```perl 485 | my $row = $db->select(foo => { id => 1 }, { limit => 1 })->first; 486 | my $new_row = $db->update_and_emulate_row($row => { bar => 2 }); 487 | # stmt: UPDATE foo SET bar = ? WHERE id = ? 488 | # bind: [2, 1] 489 | ``` 490 | 491 | This method is faster than `update_and_fetch_row`. 492 | 493 | #### WARNING 494 | 495 | If you use SQL `TRIGGER` or `AutoCommit`, this method don't return the correct value, maybe. 496 | In this case, you should use `update_and_fetch_row` instead of this method. 497 | 498 | ### `delete($table_name, \%where)` 499 | 500 | Execute `DELETE` query, and returns changed rows count. 501 | 502 | ```perl 503 | my $count = $db->delete(foo => { id => 1 }); 504 | # stmt: DELETE FROM foo WHERE id = ? 505 | # bind: [1] 506 | ``` 507 | 508 | ### `delete($row)` 509 | 510 | Execute `DELETE` query, and returns changed rows count. 511 | 512 | ```perl 513 | my $row = $db->select(foo => { id => 1 }, { limit => 1 })->first; 514 | my $count = $db->delete($row); 515 | # stmt: DELETE foo WHERE id = ? 516 | # bind: [1] 517 | ``` 518 | 519 | ## ACCESSORS 520 | 521 | - `schema : Aniki::Schema` 522 | - `filter : Aniki::Filter` 523 | - `query_builder : Aniki::QueryBuilder` 524 | - `root_row_class : Aniki::Row` 525 | - `root_result_class : Aniki::Result` 526 | - `connect_info : ArrayRef` 527 | - `on_connect_do : CodeRef|ArrayRef[Str]|Str` 528 | - `on_disconnect_do : CodeRef|ArrayRef[Str]|Str` 529 | - `suppress_row_objects : Bool` 530 | - `suppress_result_objects : Bool` 531 | - `dbh : DBI::db` 532 | - `handler : Aniki::Handler` 533 | - `txn_manager : DBIx::TransactionManager` 534 | 535 | # CONTRIBUTE 536 | 537 | I need to support documentation and reviewing my english. 538 | This module is developed on [Github](http://github.com/karupanerura/Aniki). 539 | 540 | # LICENSE 541 | 542 | Copyright (C) karupanerura. 543 | 544 | This library is free software; you can redistribute it and/or modify 545 | it under the same terms as Perl itself. 546 | 547 | # CONTRIBUTORS 548 | 549 | - watanabe-yocihi 550 | - Pine Mizune 551 | - Syohei YOSHIDA 552 | 553 | # AUTHOR 554 | 555 | karupanerura 556 | --------------------------------------------------------------------------------