--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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;
--- /dev/null
+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
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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
--- /dev/null
+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;
projects / dbsrgits/DBIx-Class.git / commitdiff