Added setup() class method to create the short-class => schema-class …

…binding

 * adjust schema() to use the new bindings schemes of setup();
 * remove 01-basic.t, no longer adequate.

Signed-off-by: Pedro Melo <melo@simplicidade.org>

dist.ini

@@ -16,4 +16,5 @@ repository = http://github.com/melo/dbicx-shortcuts/
 [Prereq]
 DBIx::Class     = 0
 Test::More      = 0.92
-Test::Exception = 0
+Test::Exception = 0
+File::Temp      = 0

lib/DBICx/Shortcuts.pm

@@ -5,15 +5,46 @@ use warnings;
 
 my %schemas;
 
+sub setup {
+  my ($class, $schema_class) = @_;
+
+  eval "require $schema_class";
+  die if $@;
+  my $schema = $schema_class->connect;
+
+  for my $source ($schema->sources) {
+    my $method = $source;
+    $method =~ s/.+::(.+)$/$1/; ## deal with nested sources
+    $method =~ s/([a-z])([A-Z])/${1}_$2/g;
+    $method = lc($method);
+
+    die "Shortcut failed, '$method' already defined in '$class', "
+      if $class->can($method);
+
+    no strict 'refs';
+    *{__PACKAGE__."::$method"} = sub {
+      my $rs = shift->schema->resultset($source);
+
+      return $rs unless @_;
+      return $rs->find(@_) if defined($_[0]) && !ref($_[0]);
+      return $rs->search(@_);
+    };
+  }
+
+  $schemas{$class} = { class => $schema_class };
+
+  return;
+}
+
 sub schema {
   my $class = shift;
 
-  my $schema = $schemas{$class};
+  my $info = $schemas{$class};
+  my $schema = $info->{schema};
   return $schema if $schema;
 
-  ($schema, my @connect_args) = $class->connect_info(@_);
-
-  return $schemas{$class} = $schema->connect(@connect_args);
+  my @connect_args = $class->connect_info(@_);
+  return $info->{schema} = $info->{class}->connect(@connect_args);
 }
 
 sub connect_info {

t/01-trouble.t

@@ -0,0 +1,22 @@
+#!perl
+
+use strict;
+use warnings;
+use lib 't/tlib';
+use Test::More;
+use Test::Exception;
+use S2;
+
+throws_ok sub { DBICx::Shortcuts->connect_info },
+  qr/Class 'DBICx::Shortcuts' needs to override 'connect_info[(][)]'/,
+  'The connect_info() method dies by default';
+
+throws_ok sub { DBICx::Shortcuts->setup('NoSuchClass') },
+  qr/Can't locate NoSuchClass.pm in [@]INC/,
+  'Failure to load Schema class detected';
+
+throws_ok sub { S2->setup('Schema') },
+  qr/Shortcut failed, 'my_books' already defined in 'S2', /,
+  'Shortcut conflict with method detected';
+
+done_testing();

t/05-shortcuts.t

@@ -4,10 +4,14 @@ use strict;
 use warnings;
 use lib 't/tlib';
 use Test::More;
-use S;
+use S1;
 
-my $schema = S->schema;
+my $schema = S1->schema;
 isa_ok($schema, 'DBIx::Class::Schema', 'Got a valid DBIx::Class::Schema');
 is(ref($schema), 'Schema', '... and of the expected type');
 
+can_ok('S1', qw( my_authors my_books printings ));
+
+is(S1->schema, $schema, 'Second call to schema, same object returned');
+
 done_testing();

t/10-api.t

@@ -0,0 +1,48 @@
+#!perl
+
+use strict;
+use warnings;
+use lib 't/tlib';
+use Test::More;
+use Test::Exception;
+use S3;
+
+eval "require DBD::SQLite";
+plan skip_all => 'API tests require DBD::SQLite, ' if $@;
+
+lives_ok sub { S3->schema->deploy }, 'Schema deployed sucessfuly';
+
+## Basic API
+my $rs = S3->my_books;
+isa_ok($rs, 'DBIx::Class::ResultSet', 'Got the expected resultset');
+
+my $not_found = S3->my_books(-1);
+ok(!defined $not_found, 'Find for non-existing ID, undef');
+
+$rs = S3->my_books({id => 2});
+isa_ok($rs, 'DBIx::Class::ResultSet', 'Got a resultset');
+
+
+## Now with real data
+my $love = S3->my_books->create({title => 'Love your Catalyst'});
+ok($love, 'Got something');
+isa_ok($love, 'Schema::Result::MyBooks', '... and it seems a MyBook');
+
+my $hate = S3->my_books->create({title => 'Hate ponies'});
+ok($hate, 'Second book ok');
+isa_ok($hate, 'Schema::Result::MyBooks', '... proper class at least');
+
+is($hate->title, S3->my_books($hate->id)->title, 'Find shortcut works');
+is(
+  $hate->title,
+  S3->my_books({id => $hate->id})->first->title,
+  'Search shortcut works'
+);
+
+is(
+  $love->title,
+  S3->my_books(undef, { sort => 'title DESC' })->first->title,
+  'Search without contitions shortcut works'
+);
+
+done_testing();

t/tlib/S1.pm

@@ -0,0 +1,8 @@
+package S1;
+use parent 'DBICx::Shortcuts';
+
+__PACKAGE__->setup('Schema');
+
+sub connect_info {}
+
+1;

t/tlib/S2.pm

@@ -0,0 +1,8 @@
+package S2;
+use parent 'DBICx::Shortcuts';
+
+sub connect_info {}
+
+sub my_books {}
+
+1;

t/tlib/S3.pm

@@ -0,0 +1,16 @@
+package S3;
+use parent 'DBICx::Shortcuts';
+use File::Temp qw( tmpnam );
+
+__PACKAGE__->setup('Schema');
+
+my $tmpname = tmpnam();
+sub connect_info {
+  return ("dbi:SQLite:$tmpname");
+}
+
+END {
+  unlink($tmpname) if $tmpname;
+}
+
+1;

t/tlib/Schema/Result/MyBooks.pm

@@ -1,9 +1,19 @@
 package Schema::Result::MyBooks;
-use parent 'DBIx::Class';
+use parent 'DBIx::Class::ResultSource';
 
 __PACKAGE__->load_components('Core');
 __PACKAGE__->table('my_books');
-__PACKAGE__->add_columns(qw(id));
+__PACKAGE__->add_columns(
+  id => {
+    data_type => 'INT',
+    is_nullable => 0,
+    is_auto_increment => 1,
+  },
+  title => {
+    data_type => 'VARCHAR',
+    is_nullable => 0,
+  },
+);
 __PACKAGE__->set_primary_key(qw(id));
 
 1;