From: John Napiorkowski Date: Fri, 18 Apr 2008 22:22:41 +0000 (+0000) Subject: querycounter role, test for that and a new schema hierarchy for additional Moose... X-Git-Tag: v0.08240~485 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=62fa8aecef5887b274659ebfb4233a37cff5a3e6;p=dbsrgits%2FDBIx-Class.git querycounter role, test for that and a new schema hierarchy for additional Moose related development --- diff --git a/lib/DBIx/Class/Storage/DBI/Role/QueryCounter.pm b/lib/DBIx/Class/Storage/DBI/Role/QueryCounter.pm new file mode 100644 index 0000000..9009f65 --- /dev/null +++ b/lib/DBIx/Class/Storage/DBI/Role/QueryCounter.pm @@ -0,0 +1,81 @@ +package DBIx::Class::Storage::DBI::Role::QueryCounter; + +use Moose::Role; +requires '_query_start'; + +=head1 NAME + +DBIx::Class::Storage::DBI::Role::QueryCounter; Role to add a query counter + +=head1 SYNOPSIS + + my $query_count = $schema->storage->query_count; + +=head1 DESCRIPTION + +Each time the schema does a query, increment the counter. + +=head1 ATTRIBUTES + +This package defines the following attributes. + +head2 _query_count + +Is the attribute holding the current query count. It defines a public reader +called 'query_count' which you can use to access the total number of queries +that DBIC has run since connection. + +=cut + +has '_query_count' => ( + reader=>'query_count', + writer=>'_set_query_count', + isa=>'Int', + required=>1, + default=>0, +); + + +=head1 METHODS + +This module defines the following methods. + +=head2 _query_start + +override on the method so that we count the queries. + +=cut + +around '_query_start' => sub { + my ($_query_start, $self, @args) = @_; + $self->_increment_query_count; + return $self->$_query_start(@args); +}; + + +=head2 _increment_query_count + +Used internally. You won't need this unless you enjoy messing with the query +count. + +=cut + +sub _increment_query_count { + my $self = shift @_; + my $current = $self->query_count; + $self->_set_query_count(++$current); +} + + +=head1 AUTHORS + +See L for more information regarding authors. + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut + + +1; \ No newline at end of file diff --git a/t/99schema_roles.t b/t/99schema_roles.t new file mode 100644 index 0000000..770c4ab --- /dev/null +++ b/t/99schema_roles.t @@ -0,0 +1,86 @@ +use strict; +use warnings; +use lib qw(t/lib); +use Test::More; + +BEGIN { + eval "use Moose"; + plan $@ + ? ( skip_all => 'needs Moose for testing' ) + : ( tests => 11 ); +} + +=head1 NAME + +DBICNGTest::Schema::ResultSet:Person; Example Resultset + +=head1 DESCRIPTION + +Tests for the various Schema roles you can either use or apply + +=head1 TESTS + +=head2 initialize database + +create a schema and setup + +=cut + +use_ok 'DBICNGTest::Schema'; + +ok my $db_file = Path::Class::File->new(qw/t var DBIxClassNG.db/) + => 'created a path for the test database'; + +ok my $schema = DBICNGTest::Schema->connect_and_setup($db_file) + => 'Created a good Schema'; + +is ref $schema->source('Person'), 'DBIx::Class::ResultSource::Table' + => 'Found Expected Person Source'; + +is $schema->resultset('Person')->count, 5 + => 'Got the correct number of people'; + +is $schema->resultset('Gender')->count, 3 + => 'Got the correct number of genders'; + + +=head2 check query counter + +Test the query counter role + +=cut + +use_ok 'DBIx::Class::Storage::DBI::Role::QueryCounter'; +DBIx::Class::Storage::DBI::Role::QueryCounter->meta->apply($schema->storage); + +is $schema->storage->query_count, 0 + => 'Query Count is zero'; + +is $schema->resultset('Person')->find(1)->name, 'john' + => 'Found John!'; + +is $schema->resultset('Person')->find(2)->name, 'dan' + => 'Found Dan!'; + +is $schema->storage->query_count, 2 + => 'Query Count is zero'; + + +=head2 cleanup + +Cleanup after ourselves + +=cut + +unlink $db_file; + + +=head1 AUTHORS + +See L for more information regarding authors. + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut \ No newline at end of file diff --git a/t/lib/DBICNGTest/Schema.pm b/t/lib/DBICNGTest/Schema.pm new file mode 100644 index 0000000..15ec398 --- /dev/null +++ b/t/lib/DBICNGTest/Schema.pm @@ -0,0 +1,150 @@ +package # hide from PAUSE + DBICNGTest::Schema; + + use Moose; + use Path::Class::File; + extends 'DBIx::Class::Schema', 'Moose::Object'; + + +=head1 NAME + +DBICNGTest::Schema; Schema Base For Testing Moose Roles, Traits, etc. + +=head1 SYNOPSIS + + my $schema = DBICNGTest::Schema->connect($dsn); + + ## Do anything you would as with a normal $schema object. + +=head1 DESCRIPTION + +Defines the base case for loading DBIC Schemas. We add in some additional +helpful functions for administering you schemas. This namespace is dedicated +to integration of Moose based development practices. + +=head1 PACKAGE METHODS + +The following is a list of package methods declared with this class. + +=head2 load_namespaces + +Automatically load the classes and resultsets from their default namespaces. + +=cut + +__PACKAGE__->load_namespaces( + default_resultset_class => 'ResultSet', +); + + +=head1 ATTRIBUTES + +This class defines the following attributes. + +=head1 METHODS + +This module declares the following methods + +=head2 new + +overload new to make sure we get a good meta object and that the attributes all +get properly setup. This is done so that our instances properly get a L +meta class. + +=cut + +sub new +{ + my $class = shift @_; + my $obj = $class->SUPER::new(@_); + + return $class->meta->new_object( + __INSTANCE__ => $obj, @_ + ); +} + + +=head2 connect_and_setup + +Creates a schema, deploys a database and sets the testing data. + +=cut + +sub connect_and_setup { + my $class = shift @_; + my $db_file = shift @_; + + my ($dsn, $user, $pass) = ( + $ENV{DBICNG_DSN} || "dbi:SQLite:${db_file}", + $ENV{DBICNG_USER} || '', + $ENV{DBICNG_PASS} || '', + ); + + return $class + ->connect($dsn, $user, $pass, { AutoCommit => 1 }) + ->setup; +} + + +=head2 setup + +deploy a database and populate it with the initial data + +=cut + +sub setup { + my $self = shift @_; + $self->deploy(); + $self->initial_populate(@_); + + return $self; +} + + +=head2 initial_populate + +initializing the startup database information + +=cut + +sub initial_populate { + my $self = shift @_; + + my @genders = $self->populate('Gender' => [ + [qw(gender_id label)], + [qw(1 female)], + [qw(2 male)], + [qw(3 transgender)], + ]); + + my @persons = $self->populate('Person' => [ + [ qw(person_id fk_gender_id name age) ], + [ qw(1 1 john 25) ], + [ qw(2 1 dan 35) ], + [ qw(3 2 mary 15) ], + [ qw(4 2 jane 95) ], + [ qw(5 3 steve 40) ], + ]); + + my @friends = $self->populate('FriendList' => [ + [ qw(fk_person_id fk_friend_id) ], + [ qw(1 2) ], + [ qw(1 3) ], + [ qw(2 3) ], + [ qw(3 2) ], + ]); +} + + +=head1 AUTHORS + +See L for more information regarding authors. + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut + + +1; diff --git a/t/lib/DBICNGTest/Schema/Result.pm b/t/lib/DBICNGTest/Schema/Result.pm new file mode 100644 index 0000000..9d13c4a --- /dev/null +++ b/t/lib/DBICNGTest/Schema/Result.pm @@ -0,0 +1,83 @@ +package # hide from PAUSE + DBICNGTest::Schema::Result; + + use Moose; + extends 'DBIx::Class', 'Moose::Object'; + +=head1 NAME + +DBICNGTest::Schema::Result; Base Class for result and class objects + +=head1 SYNOPSIS + + package DBICNGTest::Schema::Result::Member; + + use Moose; + extends 'DBICNGTest::Schema::Result'; + + ## Rest of the class definition. + +=head1 DESCRIPTION + +Defines the base case for loading DBIC Schemas. We add in some additional +helpful functions for administering you schemas. This namespace is dedicated +to integration of Moose based development practices + +=head1 PACKAGE METHODS + +The following is a list of package methods declared with this class. + +=head2 load_components + +Components to preload. + +=cut + +__PACKAGE__->load_components(qw/ + PK::Auto + InflateColumn::DateTime + Core +/); + + +=head1 ATTRIBUTES + +This class defines the following attributes. + +=head1 METHODS + +This module declares the following methods + +=head2 new + +overload new to make sure we get a good meta object and that the attributes all +get properly setup. This is done so that our instances properly get a L +meta class. + +=cut + +sub new +{ + my $class = shift @_; + my $attrs = shift @_; + + my $obj = $class->SUPER::new($attrs); + + return $class->meta->new_object( + __INSTANCE__ => $obj, %$attrs + ); +} + + +=head1 AUTHORS + +See L for more information regarding authors. + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut + + +1; \ No newline at end of file diff --git a/t/lib/DBICNGTest/Schema/Result/FriendList.pm b/t/lib/DBICNGTest/Schema/Result/FriendList.pm new file mode 100644 index 0000000..8c87003 --- /dev/null +++ b/t/lib/DBICNGTest/Schema/Result/FriendList.pm @@ -0,0 +1,118 @@ +package #hide from pause + DBICNGTest::Schema::Result::FriendList; + + use Moose; + extends 'DBICNGTest::Schema::Result'; + + +=head1 NAME + +Zoomwit::tlib::DBIC::Schema::Result::FriendList; An example Friends Class; + +=head1 VERSION + +0.01 + +=cut + +our $VERSION = '0.01'; + + +=head1 DESCRIPTION + +A Person can have zero or more friends +A Person can't be their own friend +A Person over 18 can't be friends with Persons under 18 and vis versa. +A Person can have friendships that are not mutual. + +=head1 ATTRIBUTES + +This class defines the following attributes. + +=head1 PACKAGE METHODS + +This module defines the following package methods + +=head2 table + +Name of the Physical table in the database + +=cut + +__PACKAGE__ + ->table('friend_list'); + + +=head2 add_columns + +Add columns and meta information + +=head3 fk_person_id + +ID of the person with friends + +=head3 fk_friend_id + +Who is the friend? + +=cut + +__PACKAGE__ + ->add_columns( + fk_person_id => { + data_type=>'integer', + }, + fk_friend_id => { + data_type=>'integer', + }, +); + + +=head2 primary_key + +Sets the Primary keys for this table + +=cut + +__PACKAGE__ + ->set_primary_key(qw/fk_person_id fk_friend_id/); + + +=head2 befriender + +The person that 'owns' the friendship (list) + +=cut + +__PACKAGE__ + ->belongs_to( befriender => 'DBICNGTest::Schema::Result::Person', { + 'foreign.person_id' => 'self.fk_person_id' }); + + +=head2 friendee + +The actual friend that befriender is listing + +=cut + +__PACKAGE__ + ->belongs_to( friendee => 'DBICNGTest::Schema::Result::Person', { + 'foreign.person_id' => 'self.fk_friend_id' }); + + +=head1 METHODS + +This module defines the following methods. + +=head1 AUTHORS + +See L for more information regarding authors. + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut + + +1; diff --git a/t/lib/DBICNGTest/Schema/Result/Gender.pm b/t/lib/DBICNGTest/Schema/Result/Gender.pm new file mode 100644 index 0000000..a47e5dd --- /dev/null +++ b/t/lib/DBICNGTest/Schema/Result/Gender.pm @@ -0,0 +1,117 @@ +package #hide from pause + DBICNGTest::Schema::Result::Gender; + + use Moose; + extends 'DBICNGTest::Schema::Result'; + + +=head1 NAME + +DBICNGTest::Schema::Result::Gender; An example Gender Class; + +=head1 DESCRIPTION + +Tests for this type of FK relationship + +=head1 ATTRIBUTES + +This class defines the following attributes. + +=head2 label + +example of using an attribute to add constraints on a table insert + +=cut + +has 'label' =>(is=>'rw', required=>1, isa=>'Str'); + + +=head1 PACKAGE METHODS + +This module defines the following package methods + +=head2 table + +Name of the Physical table in the database + +=cut + +__PACKAGE__ + ->table('gender'); + + +=head2 add_columns + +Add columns and meta information + +=head3 gender_id + +Primary Key which is an auto generated UUID + +=head3 label + +Text label of the gender (ie, 'male', 'female', 'transgender', etc.). + +=cut + +__PACKAGE__ + ->add_columns( + gender_id => { + data_type=>'integer', + }, + label => { + data_type=>'varchar', + size=>12, + }, + ); + + +=head2 primary_key + +Sets the Primary keys for this table + +=cut + +__PACKAGE__ + ->set_primary_key(qw/gender_id/); + + +=head2 + +Marks the unique columns + +=cut + +__PACKAGE__ + ->add_unique_constraint('gender_label_unique' => [ qw/label/ ]); + + +=head2 people + +A resultset of people with this gender + +=cut + +__PACKAGE__ + ->has_many( + people => 'DBICNGTest::Schema::Result::Person', + {'foreign.fk_gender_id' => 'self.gender_id'} + ); + + +=head1 METHODS + +This module defines the following methods. + +=head1 AUTHORS + +See L for more information regarding authors. + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut + + +1; diff --git a/t/lib/DBICNGTest/Schema/Result/Person.pm b/t/lib/DBICNGTest/Schema/Result/Person.pm new file mode 100644 index 0000000..9547cc4 --- /dev/null +++ b/t/lib/DBICNGTest/Schema/Result/Person.pm @@ -0,0 +1,178 @@ +package #hide from pause + DBICNGTest::Schema::Result::Person; + + use Moose; + use DateTime; + extends 'DBICNGTest::Schema::Result'; + + +=head1 NAME + +DBICNGTest::Schema::Result::Person; An example Person Class; + +=head1 DESCRIPTION + +Tests for this type of FK relationship + +=head1 ATTRIBUTES + +This class defines the following attributes. + +=head2 created + +attribute for the created column + +=cut + +has 'created' => ( + is=>'ro', + isa=>'DateTime', + required=>1, + default=>sub { + DateTime->now; + }, +); + + +=head1 PACKAGE METHODS + +This module defines the following package methods + +=head2 table + +Name of the Physical table in the database + +=cut + +__PACKAGE__ + ->table('person'); + + +=head2 add_columns + +Add columns and meta information + +=head3 person_id + +Primary Key which is an auto generated autoinc + +=head3 fk_gender_id + +foreign key to the Gender table + +=head3 name + +Just an ordinary name + +=head3 age + +The person's age + +head3 created + +When the person was added to the database + +=cut + +__PACKAGE__ + ->add_columns( + person_id => { + data_type=>'integer', + }, + fk_gender_id => { + data_type=>'integer', + }, + name => { + data_type=>'varchar', + size=>32, + }, + age => { + data_type=>'integer', + default_value=>25, + }, + created => { + data_type=>'datetime', + default_value=>'date("now")', + }); + + +=head2 primary_key + +Sets the Primary keys for this table + +=cut + +__PACKAGE__ + ->set_primary_key(qw/person_id/); + + +=head2 friendlist + +Each Person might have a resultset of friendlist + +=cut + +__PACKAGE__ + ->has_many( + friendlist => 'DBICNGTest::Schema::Result::FriendList', + {'foreign.fk_person_id' => 'self.person_id'}); + + +=head2 gender + +This person's gender + +=cut + +__PACKAGE__ + ->belongs_to( gender => 'DBICNGTest::Schema::Result::Gender', { + 'foreign.gender_id' => 'self.fk_gender_id' }); + + +=head2 fanlist + +A resultset of the people listing me as a friend (if any) + +=cut + +__PACKAGE__ + ->belongs_to( fanlist => 'DBICNGTest::Schema::Result::FriendList', { + 'foreign.fk_friend_id' => 'self.person_id' }); + + +=head2 friends + +A resultset of Persons who are in my FriendList + +=cut + +__PACKAGE__ + ->many_to_many( friends => 'friendlist', 'friend' ); + + +=head2 fans + +A resultset of people that have me in their friendlist + +=cut + +__PACKAGE__ + ->many_to_many( fans => 'fanlist', 'befriender' ); + + +=head1 METHODS + +This module defines the following methods. + +=head1 AUTHORS + +See L for more information regarding authors. + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut + + +1; diff --git a/t/lib/DBICNGTest/Schema/ResultSet.pm b/t/lib/DBICNGTest/Schema/ResultSet.pm new file mode 100644 index 0000000..7bb83c6 --- /dev/null +++ b/t/lib/DBICNGTest/Schema/ResultSet.pm @@ -0,0 +1,68 @@ +package # hide from PAUSE + DBICNGTest::Schema::ResultSet; + + use Moose; + extends 'DBIx::Class::ResultSet', 'Moose::Object'; + +=head1 NAME + +DBICNGTest::Schema::ResultSet; A base ResultSet Class + +=head1 SYNOPSIS + + package DBICNGTest::Schema::ResultSet::Member; + + use Moose; + extends 'DBICNGTest::Schema::ResultSet'; + + ## Rest of the class definition. + +=head1 DESCRIPTION + +All ResultSet classes will inherit from this. This provides some base function +for all your resultsets and it is also the default resultset if you don't +bother to declare a custom resultset in the resultset namespace + +=head1 PACKAGE METHODS + +The following is a list of package methods declared with this class. + +=head1 ATTRIBUTES + +This class defines the following attributes. + +=head1 METHODS + +This module declares the following methods + +=head2 new + +overload new to make sure we get a good meta object and that the attributes all +get properly setup. This is done so that our instances properly get a L +meta class. + +=cut + +sub new +{ + my $class = shift @_; + my $obj = $class->SUPER::new(@_); + + return $class->meta->new_object( + __INSTANCE__ => $obj, @_ + ); +} + + +=head1 AUTHORS + +See L for more information regarding authors. + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut + + +1; \ No newline at end of file diff --git a/t/lib/DBICNGTest/Schema/ResultSet/Person.pm b/t/lib/DBICNGTest/Schema/ResultSet/Person.pm new file mode 100644 index 0000000..86b4dbb --- /dev/null +++ b/t/lib/DBICNGTest/Schema/ResultSet/Person.pm @@ -0,0 +1,95 @@ +package # hide from pause + DBICNGTest::Schema::ResultSet::Person; + + use Moose; + extends 'DBICNGTest::Schema::ResultSet'; + + +=head1 NAME + +DBICNGTest::Schema::ResultSet:Person; Example Resultset + +=head1 VERSION + +0.01 + +=cut + +our $VERSION = '0.01'; + + +=head1 SYNOPSIS + + ##Example Usage + +See Tests for more example usage. + +=head1 DESCRIPTION + +Resultset Methods for the Person Source + +=head1 ATTRIBUTES + +This class defines the following attributes. + +=head2 literal + +a literal attribute for testing + +=cut + +has 'literal' => (is=>'ro', isa=>'Str', required=>1, lazy=>1, default=>'hi'); + + +=head2 available_genders + +A resultset of the genders people can have. Keep in mind this get's run once +only at the first compile, so it's only good for stuff that doesn't change +between reboots. + +=cut + +has 'available_genders' => ( + is=>'ro', + isa=>'DBICNGTest::Schema::ResultSet', + required=>1, + lazy=>1, + default=> sub { + shift + ->result_source + ->schema + ->resultset('Gender'); + } +); + + +=head1 METHODS + +This module defines the following methods. + +=head2 older_than($int) + +Only people over a given age + +=cut + +sub older_than +{ + my ($self, $age) = @_; + + return $self->search({age=>{'>'=>$age}}); +} + + +=head1 AUTHORS + +See L for more information regarding authors. + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut + + +1;