[Catalyst-commits] r8238 - in CatalystX-CRUD/CatalystX-CRUD-Model-RDBO/trunk: . lib/CatalystX/CRUD/Model lib/CatalystX/CRUD/Object t t/lib t/lib/My

karpet at dev.catalyst.perl.org karpet at dev.catalyst.perl.org
Thu Aug 21 06:52:23 BST 2008


Author: karpet
Date: 2008-08-21 06:52:23 +0100 (Thu, 21 Aug 2008)
New Revision: 8238

Modified:
   CatalystX-CRUD/CatalystX-CRUD-Model-RDBO/trunk/Changes
   CatalystX-CRUD/CatalystX-CRUD-Model-RDBO/trunk/Makefile.PL
   CatalystX-CRUD/CatalystX-CRUD-Model-RDBO/trunk/lib/CatalystX/CRUD/Model/RDBO.pm
   CatalystX-CRUD/CatalystX-CRUD-Model-RDBO/trunk/lib/CatalystX/CRUD/Object/RDBO.pm
   CatalystX-CRUD/CatalystX-CRUD-Model-RDBO/trunk/t/01-rdbo.t
   CatalystX-CRUD/CatalystX-CRUD-Model-RDBO/trunk/t/lib/My/Foo.pm
   CatalystX-CRUD/CatalystX-CRUD-Model-RDBO/trunk/t/lib/MyApp.pm
Log:
add support for new relationship api

Modified: CatalystX-CRUD/CatalystX-CRUD-Model-RDBO/trunk/Changes
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD-Model-RDBO/trunk/Changes	2008-08-21 05:52:10 UTC (rev 8237)
+++ CatalystX-CRUD/CatalystX-CRUD-Model-RDBO/trunk/Changes	2008-08-21 05:52:23 UTC (rev 8238)
@@ -42,3 +42,8 @@
         * add ::Manager::Debug to debugging option
         * add 'boolean' to _treat_like_int match
 
+0.13    xx
+        * support new *_related methods in core API
+
+
+

Modified: CatalystX-CRUD/CatalystX-CRUD-Model-RDBO/trunk/Makefile.PL
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD-Model-RDBO/trunk/Makefile.PL	2008-08-21 05:52:10 UTC (rev 8237)
+++ CatalystX-CRUD/CatalystX-CRUD-Model-RDBO/trunk/Makefile.PL	2008-08-21 05:52:23 UTC (rev 8238)
@@ -12,6 +12,7 @@
         'Test::More' => 0,
         'Data::Dump' => 0,   # for testing
         'Rose::DB::Object' => 0,
+        'Rose::DBx::Object::MoreHelpers' => 0,
         'CatalystX::CRUD'  => 0.18,
         'Catalyst::Runtime' => 0,
         'Rose::DBx::TestDB' => 0,

Modified: CatalystX-CRUD/CatalystX-CRUD-Model-RDBO/trunk/lib/CatalystX/CRUD/Model/RDBO.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD-Model-RDBO/trunk/lib/CatalystX/CRUD/Model/RDBO.pm	2008-08-21 05:52:10 UTC (rev 8237)
+++ CatalystX-CRUD/CatalystX-CRUD-Model-RDBO/trunk/lib/CatalystX/CRUD/Model/RDBO.pm	2008-08-21 05:52:23 UTC (rev 8238)
@@ -4,8 +4,10 @@
 use base qw( CatalystX::CRUD::Model CatalystX::CRUD::Model::Utils );
 use CatalystX::CRUD::Iterator;
 use Class::C3;
+use Carp;
+use Data::Dump qw( dump );
 
-our $VERSION = '0.12';
+our $VERSION = '0.13';
 
 __PACKAGE__->mk_ro_accessors(qw( name manager treat_like_int ));
 __PACKAGE__->config->{object_class} = 'CatalystX::CRUD::Object::RDBO';
@@ -254,6 +256,105 @@
     return CatalystX::CRUD::Iterator->new( $iter, $self->object_class );
 }
 
+=head2 search_related( I<obj>, I<relationship> )
+
+Implements required method. Returns array or array ref based on calling
+context, for objects related to I<obj> via I<relationship>. I<relationship>
+should be a method name callable on I<obj>.
+
+=head2 iterator_related( I<obj>, I<relationship> )
+
+Like search_related() but returns an iterator.
+
+=head2 count_related( I<obj>, I<relationship> )
+
+Like search_related() but returns an integer.
+
+=cut
+
+sub search_related {
+    my ( $self, $obj, $rel ) = @_;
+    return $obj->$rel;
+}
+
+sub iterator_related {
+    my ( $self, $obj, $rel ) = @_;
+    my $method = $rel . '_iterator';
+    return $obj->$method;
+}
+
+sub count_related {
+    my ( $self, $obj, $rel ) = @_;
+    my $method = $rel . '_count';
+    return $obj->$method;
+}
+
+=head2 add_related( I<obj>, I<rel_name>, I<foreign_value> )
+
+Associate foreign object identified by I<foreign_value> with I<obj>
+via the relationship I<rel_name>.
+
+B<CAUTION:> For many-to-many relationships only.
+
+=head2 rm_related( I<obj>, I<rel_name>, I<foreign_value> )
+
+Dissociate foreign object identified by I<foreign_value> from I<obj>
+via the relationship I<rel_name>.
+
+B<CAUTION:> For many-to-many relationships only.
+
+=cut
+
+sub _get_rel_meta {
+    my ( $self, $obj, $rel_name ) = @_;
+
+    my $rel = $obj->meta->relationship($rel_name)
+        or $self->throw_error("no such relationship $rel_name");
+
+    my $map_class = $rel->map_class;
+    my $mcm       = $map_class->meta;
+    my @map_to    = $mcm->relationship( $rel->map_to )->column_map;
+    my @map_from  = $mcm->relationship( $rel->map_from )->column_map;
+    my %m         = (
+        map_to    => \@map_to,
+        map_from  => \@map_from,
+        map_class => $map_class,
+    );
+
+    #carp dump \%m;
+
+    return \%m;
+}
+
+sub add_related {
+    my ( $self, $obj, $rel_name, $fk_val ) = @_;
+    my $addmethod = 'add_' . $rel_name;
+    my $meta = $self->_get_rel_meta( $obj, $rel_name );
+    $obj->$addmethod( { $meta->{map_to}->[1] => $fk_val } );
+    $obj->save;
+}
+
+sub rm_related {
+    my ( $self, $obj, $rel_name, $fk_val ) = @_;
+
+    my $meta = $self->_get_rel_meta( $obj, $rel_name );
+    my $obj_method
+        = $obj->meta->column_accessor_method_name( $meta->{map_from}->[1] );
+    my $query = [
+        $meta->{map_from}->[0] => $obj->$obj_method,
+        $meta->{map_to}->[0]   => $fk_val,
+    ];
+
+    #carp dump $query;
+
+    $self->manager->delete_objects(
+        object_class => $meta->{map_class},
+        where        => $query,
+    );
+    $obj->forget_related($rel_name);
+    return $obj;
+}
+
 =head2 make_query( I<field_names> )
 
 Implement a RDBO-specific query factory based on request parameters.

Modified: CatalystX-CRUD/CatalystX-CRUD-Model-RDBO/trunk/lib/CatalystX/CRUD/Object/RDBO.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD-Model-RDBO/trunk/lib/CatalystX/CRUD/Object/RDBO.pm	2008-08-21 05:52:10 UTC (rev 8237)
+++ CatalystX-CRUD/CatalystX-CRUD-Model-RDBO/trunk/lib/CatalystX/CRUD/Object/RDBO.pm	2008-08-21 05:52:23 UTC (rev 8238)
@@ -3,7 +3,7 @@
 use warnings;
 use base qw( CatalystX::CRUD::Object );
 
-our $VERSION = '0.12';
+our $VERSION = '0.13';
 
 =head1 NAME
 

Modified: CatalystX-CRUD/CatalystX-CRUD-Model-RDBO/trunk/t/01-rdbo.t
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD-Model-RDBO/trunk/t/01-rdbo.t	2008-08-21 05:52:10 UTC (rev 8237)
+++ CatalystX-CRUD/CatalystX-CRUD-Model-RDBO/trunk/t/01-rdbo.t	2008-08-21 05:52:23 UTC (rev 8238)
@@ -1,7 +1,8 @@
-use Test::More tests => 5;
+use Test::More tests => 14;
 
 BEGIN {
-    use lib qw( ../CatalystX-CRUD/lib );
+    $ENV{CATALYST_DEBUG} = $ENV{PERL_DEBUG} || 0;
+    use lib qw( ../../CatalystX-CRUD/trunk/lib );
     use_ok('CatalystX::CRUD::Model::RDBO');
     use_ok('CatalystX::CRUD::Object::RDBO');
     use_ok('Rose::DBx::TestDB');
@@ -11,6 +12,32 @@
 use lib qw( t/lib );
 use Catalyst::Test 'MyApp';
 use Data::Dump qw( dump );
+use HTTP::Request::Common;
 
-ok( get('/foo'), "get /foo" );
+ok( my $res = request('/foo/test'), "get /foo/test" );
 
+#dump $res->headers;
+
+is( $res->headers->{status}, 200, "get 200" );
+
+ok( $res = request('/foo/1/read'), "get /foo/1/read" );
+
+is( $res->headers->{status}, 200, "get 200" );
+
+ok( $res = request('/foo/1/related/bars/2/add'),
+    "GET /foo/1/related/bars/2/add" );
+
+is( $res->headers->{status}, 500, "cannot GET add related" );
+
+# add a new foobar
+ok( $res = request( POST( '/foo/1/related/bars/2/add', [] ) ),
+    "POST /foo/1/related/bars/2/add" );
+
+is( $res->headers->{status}, 200, "POST add related OK" );
+
+# remove an old foobar
+ok( $res = request( POST( '/foo/1/related/bars/1/remove', [] ) ),
+    "POST /foo/1/related/bars/1/remove" );
+
+is( $res->headers->{status}, 200, "POST remove related OK" );
+

Modified: CatalystX-CRUD/CatalystX-CRUD-Model-RDBO/trunk/t/lib/My/Foo.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD-Model-RDBO/trunk/t/lib/My/Foo.pm	2008-08-21 05:52:10 UTC (rev 8237)
+++ CatalystX-CRUD/CatalystX-CRUD-Model-RDBO/trunk/t/lib/My/Foo.pm	2008-08-21 05:52:23 UTC (rev 8238)
@@ -1,43 +1,39 @@
 package My::Foo;
-use base qw( Rose::DB::Object );
+use strict;
+use base qw(
+    Rose::DB::Object
+    Rose::DB::Object::Helpers
+    Rose::DBx::Object::MoreHelpers
+);
 use Carp;
 use Data::Dump qw( dump );
+use My::DB;
 
-# create a temp db
-my $db = Rose::DBx::TestDB->new;
-
-{
-    my $dbh = $db->dbh;
-
-    # create a schema to match this class
-    $dbh->do(
-        "create table foos ( id INTEGER PRIMARY KEY AUTOINCREMENT, name VARCHAR(16) );"
-    );
-
-    # create some data
-    $dbh->do("insert into foos (name) values ('bar');");
-
-    # double check
-    my $sth = $dbh->prepare("SELECT * FROM foos");
-    $sth->execute;
-    croak "bad seed data in sqlite"
-        unless $sth->fetchall_arrayref->[0]->[0] == 1;
-
-    $sth = undef;    # http://rt.cpan.org/Ticket/Display.html?id=22688
-                     # does not seem to work.
-
-}
-
 __PACKAGE__->meta->setup(
     table   => 'foos',
     columns => [
         id   => { type => 'serial',  not_null => 1, primary_key => 1 },
         name => { type => 'varchar', length   => 16 },
     ],
+    
+    primary_key_columns => ['id'],
+
+    relationships => [
+        bar => {
+            class      => 'My::FooBar',
+            column_map => { id => 'foo_id' },
+            type       => 'one to many',
+        },
+
+        bars => {
+            map_class => 'My::FooBar',
+            type      => 'many to many',
+        }
+    ],
 );
 
 sub init_db {
-    return $db;
+    return My::DB->new;
 }
 
 1;

Modified: CatalystX-CRUD/CatalystX-CRUD-Model-RDBO/trunk/t/lib/MyApp.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD-Model-RDBO/trunk/t/lib/MyApp.pm	2008-08-21 05:52:10 UTC (rev 8237)
+++ CatalystX-CRUD/CatalystX-CRUD-Model-RDBO/trunk/t/lib/MyApp.pm	2008-08-21 05:52:23 UTC (rev 8238)
@@ -7,23 +7,4 @@
 
 __PACKAGE__->setup();
 
-sub foo : Local {
-
-    my ( $self, $c, @arg ) = @_;
-
-    my $thing = $c->model('Foo')->new_object( id => 1 );
-
-    for my $m (qw( create read update delete)) {
-        croak unless $thing->can($m);
-    }
-
-    # try fetching our seed data
-    $thing->read();
-
-    croak "bad read" unless ( $thing->delegate->name eq 'bar' );
-
-    $c->res->body("foo is a-ok");
-
-}
-
 1;




More information about the Catalyst-commits mailing list