querycounter role, test for that and a new schema hierarchy for additional Moose...
John Napiorkowski [Fri, 18 Apr 2008 22:22:41 +0000 (22:22 +0000)]
lib/DBIx/Class/Storage/DBI/Role/QueryCounter.pm [new file with mode: 0644]
t/99schema_roles.t [new file with mode: 0644]
t/lib/DBICNGTest/Schema.pm [new file with mode: 0644]
t/lib/DBICNGTest/Schema/Result.pm [new file with mode: 0644]
t/lib/DBICNGTest/Schema/Result/FriendList.pm [new file with mode: 0644]
t/lib/DBICNGTest/Schema/Result/Gender.pm [new file with mode: 0644]
t/lib/DBICNGTest/Schema/Result/Person.pm [new file with mode: 0644]
t/lib/DBICNGTest/Schema/ResultSet.pm [new file with mode: 0644]
t/lib/DBICNGTest/Schema/ResultSet/Person.pm [new file with mode: 0644]

diff --git a/lib/DBIx/Class/Storage/DBI/Role/QueryCounter.pm b/lib/DBIx/Class/Storage/DBI/Role/QueryCounter.pm
new file mode 100644 (file)
index 0000000..9009f65
--- /dev/null
@@ -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<DBIx::Class> 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 (file)
index 0000000..770c4ab
--- /dev/null
@@ -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<DBIx::Class> 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 (file)
index 0000000..15ec398
--- /dev/null
@@ -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<Moose>
+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<DBIx::Class> 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 (file)
index 0000000..9d13c4a
--- /dev/null
@@ -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<Moose>
+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<DBIx::Class> 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 (file)
index 0000000..8c87003
--- /dev/null
@@ -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<DBIx::Class> 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 (file)
index 0000000..a47e5dd
--- /dev/null
@@ -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<DBIx::Class> 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 (file)
index 0000000..9547cc4
--- /dev/null
@@ -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<DBIx::Class> 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 (file)
index 0000000..7bb83c6
--- /dev/null
@@ -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<Moose>
+meta class.
+
+=cut
+
+sub new
+{
+    my $class = shift @_;
+    my $obj = $class->SUPER::new(@_);
+  
+    return $class->meta->new_object(
+        __INSTANCE__ => $obj, @_
+    );
+}
+
+
+=head1 AUTHORS
+
+See L<DBIx::Class> 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 (file)
index 0000000..86b4dbb
--- /dev/null
@@ -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<DBIx::Class> for more information regarding authors.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+
+1;