[Catalyst-commits] r7489 - in
CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk: .
lib/CatalystX/CRUD/Model lib/CatalystX/CRUD/Object t t/lib
t/lib/MyApp t/lib/MyApp/Controller t/lib/MyApp/Model
karpet at dev.catalyst.perl.org
karpet at dev.catalyst.perl.org
Wed Mar 12 03:28:09 GMT 2008
Author: karpet
Date: 2008-03-12 03:28:08 +0000 (Wed, 12 Mar 2008)
New Revision: 7489
Added:
CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/t/lib/MyApp/Controller/
CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/t/lib/MyApp/Controller/CRUD.pm
CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/t/lib/MyForm.pm
Modified:
CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/Makefile.PL
CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/lib/CatalystX/CRUD/Model/DBIC.pm
CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/lib/CatalystX/CRUD/Object/DBIC.pm
CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/t/01-dbic.t
CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/t/example.sql
CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/t/insertdb.pl
CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/t/lib/MyApp/Model/Main.pm
Log:
add some CRUD tests. TODO factor MyForm out into CatalystX::CRUD::MockForm and the test controller into ::MockController
Modified: CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/Makefile.PL
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/Makefile.PL 2008-03-11 17:22:53 UTC (rev 7488)
+++ CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/Makefile.PL 2008-03-12 03:28:08 UTC (rev 7489)
@@ -10,7 +10,7 @@
PL_FILES => {},
PREREQ_PM => {
'Test::More' => 0,
- 'CatalystX::CRUD' => '0.22',
+ 'CatalystX::CRUD' => '0.25',
'DBIx::Class' => 0,
'Catalyst::Model::DBIC::Schema' => 0,
Modified: CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/lib/CatalystX/CRUD/Model/DBIC.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/lib/CatalystX/CRUD/Model/DBIC.pm 2008-03-11 17:22:53 UTC (rev 7488)
+++ CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/lib/CatalystX/CRUD/Model/DBIC.pm 2008-03-12 03:28:08 UTC (rev 7489)
@@ -1,8 +1,9 @@
package CatalystX::CRUD::Model::DBIC;
use strict;
use warnings;
-
+use Carp;
use CatalystX::CRUD::Iterator;
+use NEXT;
# @INC order important!
use base qw(
@@ -105,7 +106,17 @@
sub new_object {
my $self = shift;
- return $self->schema->resultset( $self->moniker )->new(@_);
+ my $dbic_obj;
+ my $moniker = $self->moniker;
+ eval { $dbic_obj = $self->schema->resultset($moniker)->new(@_) };
+ if ( $@ or !$dbic_obj ) {
+ my $err = defined($dbic_obj) ? $dbic_obj->error : $@;
+ return
+ if $self->throw_error("can't create new $moniker object: $err");
+ }
+
+ # must call SUPER instead of NEXT. Why??
+ return $self->SUPER::new_object( delegate => $dbic_obj );
}
=head2 fetch( @params )
@@ -116,7 +127,26 @@
sub fetch {
my $self = shift;
- return $self->schema->resultset( $self->moniker )->find(@_);
+ if (@_) {
+ my $moniker = $self->moniker;
+ my $dbic_obj;
+ eval {
+ $dbic_obj
+ = $self->schema->resultset( $self->moniker )->find( {@_} );
+ };
+ if ( $@ or !$dbic_obj ) {
+ my $err = defined($dbic_obj) ? $dbic_obj->error : $@;
+ return
+ if $self->throw_error(
+ "can't create new $moniker object: $err");
+ }
+
+ # must call SUPER instead of NEXT. Why??
+ return $self->SUPER::new_object( delegate => $dbic_obj );
+ }
+ else {
+ return $self->new_object({});
+ }
}
=head2 make_query( I<\@field_names> )
Modified: CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/lib/CatalystX/CRUD/Object/DBIC.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/lib/CatalystX/CRUD/Object/DBIC.pm 2008-03-11 17:22:53 UTC (rev 7488)
+++ CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/lib/CatalystX/CRUD/Object/DBIC.pm 2008-03-12 03:28:08 UTC (rev 7489)
@@ -30,13 +30,13 @@
=head2 create
-Calls delegate->create().
+Calls delegate->insert().
=cut
# required methods
sub create {
- shift->delegate->create(@_);
+ shift->delegate->insert(@_);
}
=head2 read
Modified: CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/t/01-dbic.t
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/t/01-dbic.t 2008-03-11 17:22:53 UTC (rev 7488)
+++ CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/t/01-dbic.t 2008-03-12 03:28:08 UTC (rev 7489)
@@ -1,4 +1,4 @@
-use Test::More tests => 10;
+use Test::More tests => 14;
BEGIN {
use lib qw( ../CatalystX-CRUD/lib t );
@@ -8,11 +8,12 @@
system("cd t/ && $^X insertdb.pl") and die "can't create db: $!";
}
-END { unlink('t/example.db'); }
+END { unlink('t/example.db') unless $ENV{PERL_DEBUG}; }
use lib qw( t/lib );
use Catalyst::Test 'MyApp';
use Data::Dump qw( dump );
+use HTTP::Request::Common;
ok( my $res = request('/test1'), "get /test1" );
is( $res->content, 13, "right number of results" );
@@ -23,4 +24,29 @@
ok( $res = request('/test4?cd.title=Bad'), "get /test4" );
is( $res->content, 3, "count for cd.title=Bad" );
-# TODO need some actual CRUD. so far all we've done is search/retrieve.
\ No newline at end of file
+# read
+ok( $res = request( HTTP::Request->new( GET => '/crud/1/view' ) ),
+ "GET view" );
+
+#diag( $res->content );
+is( $res->content, '{ cd => 3, title => "Beat It", trackid => 1 }',
+ "GET track 1" );
+
+# create
+ok( $res = request(
+ POST(
+ '/crud/0/save',
+ [ cd => 3,
+ title => 'Something New, Something Blue',
+ trackid => 0
+ ]
+ )
+ ),
+ "POST new track"
+);
+
+#diag( $res->content );
+is( $res->content,
+ '{ cd => 3, title => "Something New, Something Blue", trackid => 8 }',
+ "POST new track"
+);
Modified: CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/t/example.sql
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/t/example.sql 2008-03-11 17:22:53 UTC (rev 7488)
+++ CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/t/example.sql 2008-03-12 03:28:08 UTC (rev 7489)
@@ -1,16 +1,16 @@
CREATE TABLE artist (
- artistid INTEGER PRIMARY KEY,
+ artistid INTEGER PRIMARY KEY AUTOINCREMENT,
name TEXT NOT NULL
);
CREATE TABLE cd (
- cdid INTEGER PRIMARY KEY,
+ cdid INTEGER PRIMARY KEY AUTOINCREMENT,
artist INTEGER NOT NULL REFERENCES artist(artistid),
title TEXT NOT NULL
);
CREATE TABLE track (
- trackid INTEGER PRIMARY KEY,
+ trackid INTEGER PRIMARY KEY AUTOINCREMENT,
cd INTEGER NOT NULL REFERENCES cd(cdid),
title TEXT NOT NULL
);
Modified: CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/t/insertdb.pl
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/t/insertdb.pl 2008-03-11 17:22:53 UTC (rev 7488)
+++ CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/t/insertdb.pl 2008-03-12 03:28:08 UTC (rev 7489)
@@ -9,7 +9,7 @@
$dbh->do(
qq{
CREATE TABLE artist (
- artistid INTEGER PRIMARY KEY,
+ artistid INTEGER PRIMARY KEY AUTOINCREMENT,
name TEXT NOT NULL
);}
) or die;
@@ -17,7 +17,7 @@
$dbh->do(
qq{
CREATE TABLE cd (
- cdid INTEGER PRIMARY KEY,
+ cdid INTEGER PRIMARY KEY AUTOINCREMENT,
artist INTEGER NOT NULL REFERENCES artist(artistid),
title TEXT NOT NULL
);
@@ -27,7 +27,7 @@
$dbh->do(
qq{
CREATE TABLE track (
- trackid INTEGER PRIMARY KEY,
+ trackid INTEGER PRIMARY KEY AUTOINCREMENT,
cd INTEGER NOT NULL REFERENCES cd(cdid),
title TEXT NOT NULL
);
@@ -48,7 +48,7 @@
);
my @cds;
-foreach my $lp ( keys %albums ) {
+foreach my $lp ( sort keys %albums ) {
my $artist
= $schema->resultset('Artist')->search( { name => $albums{$lp} } );
push @cds, [ $lp, $artist->first ];
@@ -67,7 +67,7 @@
);
my @tracks;
-foreach my $track ( keys %tracks ) {
+foreach my $track ( sort keys %tracks ) {
my $cdname
= $schema->resultset('Cd')->search( { title => $tracks{$track}, } );
push @tracks, [ $cdname->first, $track ];
Added: CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/t/lib/MyApp/Controller/CRUD.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/t/lib/MyApp/Controller/CRUD.pm (rev 0)
+++ CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/t/lib/MyApp/Controller/CRUD.pm 2008-03-12 03:28:08 UTC (rev 7489)
@@ -0,0 +1,96 @@
+package MyApp::Controller::CRUD;
+use strict;
+use warnings;
+use base qw( CatalystX::CRUD::Controller );
+use Carp;
+use Data::Dump;
+use MyForm;
+
+__PACKAGE__->config(
+ form_class => 'MyForm',
+ init_form => 'init_with_track',
+ init_object => 'track_from_form',
+ default_template => 'no/such/file',
+ model_name => 'Main',
+ primary_key => 'trackid',
+ view_on_single_result => 0,
+ page_size => 50,
+ allow_GET_writes => 0,
+);
+
+sub form {
+ my ( $self, $c ) = @_;
+ my $form = $self->SUPER::form($c);
+ $form->fields( [qw( title cd trackid )] );
+ return $form;
+}
+
+# this more or less verbatim from RHTMLO controller.
+sub form_to_object {
+ my ( $self, $c ) = @_;
+ my $form = $c->stash->{form};
+ my $obj = $c->stash->{object};
+ my $obj_meth = $self->init_object;
+ my $form_meth = $self->init_form;
+ my $pk = $self->primary_key
+ ; # id always comes from url but not necessarily from form
+ my $id = $c->req->params->{$pk} || $c->stash->{object_id};
+
+ # initialize the form with the object's values
+ $form->$form_meth( $obj->delegate );
+
+ # set param values from request
+ $form->params( $c->req->params );
+ $form->param( $pk => $id );
+
+ # override form's values with those from params
+ # no_clear is important because we already initialized with object
+ # and we do not want to undo those mods.
+ $form->init_fields( no_clear => 1 );
+
+ # return if there was a problem with any param values
+ unless ( $form->validate() ) {
+ $c->stash->{error} = $form->error; # NOT throw_error()
+ $c->stash->{template} ||= $self->default_template; # MUST specify
+ return 0;
+ }
+
+ # re-set object's values from the now-valid form
+ $form->$obj_meth( $obj->delegate );
+
+ # set id explicitly since there's some bug
+ # with param() setting it in save()
+ $obj->$pk($id);
+
+ # let serial column work its magic
+ $obj->$pk(undef)
+ if ( !$obj->$pk || $obj->$pk eq '0' || $id eq '0' );
+
+ #carp "object $pk == $id ? " . $obj->$pk;
+
+ #carp $self->serialize( $c, $obj );
+
+ return $obj;
+}
+
+sub end : Private {
+ my ( $self, $c ) = @_;
+ $c->res->body( $self->serialize( $c, $c->stash->{object} ) );
+}
+
+sub serialize {
+ my ( $self, $c, $object ) = @_;
+ my $fields = $c->stash->{form}->fields;
+ my $serial = {};
+ for my $f (@$fields) {
+ if ( $f eq 'cd' && defined $object->$f ) {
+ $serial->{$f} = $object->$f->cdid;
+ }
+ else {
+ $serial->{$f} = $object->$f;
+ }
+ }
+ return Data::Dump::dump($serial);
+}
+
+1;
Modified: CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/t/lib/MyApp/Model/Main.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/t/lib/MyApp/Model/Main.pm 2008-03-11 17:22:53 UTC (rev 7488)
+++ CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/t/lib/MyApp/Model/Main.pm 2008-03-12 03:28:08 UTC (rev 7489)
@@ -1,5 +1,5 @@
package MyApp::Model::Main;
-use base qw/CatalystX::CRUD::Model::DBIC/;
+use base qw( CatalystX::CRUD::Model::DBIC );
__PACKAGE__->config(
schema_class => 'MyDB::Main',
Added: CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/t/lib/MyForm.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/t/lib/MyForm.pm (rev 0)
+++ CatalystX-CRUD/CatalystX-CRUD-Model-DBIC/trunk/t/lib/MyForm.pm 2008-03-12 03:28:08 UTC (rev 7489)
@@ -0,0 +1,71 @@
+package MyForm;
+use strict;
+use warnings;
+use Carp;
+use Data::Dump;
+use base qw( Class::Accessor::Fast );
+
+__PACKAGE__->mk_accessors(qw( params fields ));
+
+# poor man's form class
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new(@_);
+ $self->params( {} );
+ return $self;
+}
+
+sub param {
+ my $self = shift;
+ my $key = shift;
+ croak "key required" if !defined $key;
+ my $val = shift;
+ $self->params->{$key} = $val;
+}
+
+sub init_fields {
+ my $self = shift;
+
+ # nothing to do
+ #$self->dump;
+}
+
+sub clear {
+ my $self = shift;
+ $self->params( {} );
+}
+
+sub validate {
+ my $self = shift;
+
+ # nothing to do in this poor man's form.
+ #$self->dump;
+
+ 1;
+}
+
+sub init_with_track {
+ my ( $self, $track ) = @_;
+ for my $f ( keys %{ $self->params } ) {
+ $self->params->{$f} = $track->$f;
+ }
+ #$self->dump;
+ return $self;
+}
+
+sub track_from_form {
+ my ( $self, $track ) = @_;
+ for my $f ( keys %{ $self->params } ) {
+ $track->$f( $self->params->{$f} );
+ }
+ #Data::Dump::dump($track);
+ return $track;
+}
+
+sub dump {
+ my $self = shift;
+ Data::Dump::dump($self);
+}
+
+1;
More information about the Catalyst-commits
mailing list