[Catalyst-commits] r8260 - in CatalystX-CRUD/CatalystX-CRUD/trunk:
. lib/CatalystX/CRUD lib/CatalystX/CRUD/Model
lib/CatalystX/CRUD/Object lib/CatalystX/CRUD/Test t t/lib
t/lib/MyApp/Controller t/lib/MyApp/Controller/REST t/lib/MyApp/Model
karpet at dev.catalyst.perl.org
karpet at dev.catalyst.perl.org
Fri Aug 22 20:39:54 BST 2008
Author: karpet
Date: 2008-08-22 20:39:54 +0100 (Fri, 22 Aug 2008)
New Revision: 8260
Added:
CatalystX-CRUD/CatalystX-CRUD/trunk/t/03-rest.t
CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp/Controller/REST/
CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp/Controller/REST/File.pm
Modified:
CatalystX-CRUD/CatalystX-CRUD/trunk/Changes
CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Controller.pm
CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Model.pm
CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Model/File.pm
CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Object/File.pm
CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/REST.pm
CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Test/Controller.pm
CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Test/Form.pm
CatalystX-CRUD/CatalystX-CRUD/trunk/t/01-file.t
CatalystX-CRUD/CatalystX-CRUD/trunk/t/02-controller.t
CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp.pm
CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp/Model/File.pm
Log:
rewrite REST controller, add lots of tests and get them all passing
Modified: CatalystX-CRUD/CatalystX-CRUD/trunk/Changes
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/Changes 2008-08-22 17:00:39 UTC (rev 8259)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/Changes 2008-08-22 19:39:54 UTC (rev 8260)
@@ -136,5 +136,8 @@
* fix typos in the Tutorial
* add relationship methods to Controller, ModelAdapter and Model core API.
* added sugary alias methods for read(), update() and delete() to match CRUD.
+ * refactored REST controller to support related methods and provide better
+ HTTP status checks and responses.
+
Modified: CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Controller.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Controller.pm 2008-08-22 17:00:39 UTC (rev 8259)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Controller.pm 2008-08-22 19:39:54 UTC (rev 8260)
@@ -9,6 +9,7 @@
use Catalyst::Utils;
use CatalystX::CRUD::Results;
use Class::C3;
+use Data::Dump qw( dump );
__PACKAGE__->mk_accessors(
qw(
@@ -105,6 +106,7 @@
sub auto : Private {
my ( $self, $c, @args ) = @_;
$c->stash->{form} = $self->form($c);
+ $self->next::method( $c, @args ) if $self->next::can;
1;
}
@@ -112,14 +114,14 @@
Attribute: Private
-The fallback method. The default is simply to write a warning to the Catalyst
-log() method.
+The fallback method. The default returns a 404 error.
=cut
sub default : Private {
my ( $self, $c, @args ) = @_;
- $c->log->warn("no action defined for the default() CRUD method");
+ $c->res->body('Not found');
+ $c->res->status(404);
}
=head2 fetch( I<primary_key> )
@@ -138,9 +140,9 @@
sub fetch : Chained('/') PathPrefix CaptureArgs(1) {
my ( $self, $c, $id ) = @_;
$c->stash->{object_id} = $id;
- $c->log->debug("fetch $id") if $c->debug;
my @pk = $self->get_primary_key( $c, $id );
my @arg = $id ? (@pk) : ();
+ $c->log->debug( "fetch: " . dump \@arg ) if $c->debug;
$c->stash->{object} = $self->do_model( $c, 'fetch', @arg );
if ( $self->has_errors($c) or !$c->stash->{object} ) {
$self->throw_error( 'No such ' . $self->model_name );
@@ -213,7 +215,7 @@
but could be any object that has accessor methods with
the same names as the field(s) specified by B<primary_key>.
-Multiple values are joined with C<;;> and any C<;> characters
+Multiple values are joined with C<;;> and any C<;> or C</> characters
in the column values are URI-escaped.
=cut
@@ -235,6 +237,11 @@
else {
$id = $obj->$pk;
}
+
+ # must escape any / in $id since passing it to uri_for as-is
+ # will break.
+ $id =~ s!/!\%2f!g;
+
return $id;
}
@@ -336,7 +343,8 @@
if ( !$self->allow_GET_writes ) {
if ( $c->req->method ne 'POST' ) {
- $self->throw_error('GET request not allowed');
+ $c->res->status(400);
+ $c->res->body('GET request not allowed');
return;
}
}
@@ -396,7 +404,8 @@
my ( $self, $c ) = @_;
if ( !$self->allow_GET_writes ) {
if ( $c->req->method ne 'POST' ) {
- $self->throw_error('GET request not allowed');
+ $c->res->status(400);
+ $c->res->body('GET request not allowed');
return;
}
}
@@ -500,9 +509,16 @@
and I<foreign_pk_value>. Those two values are put in
stash under those key names.
+Note that related() has a PathPart of '' so it does
+not appear in your URL:
+
+ http://yourhost/foo/123/bars/456/add
+
+will resolve in the action_for add().
+
=cut
-sub related : PathPart Chained('fetch') CaptureArgs(2) {
+sub related : PathPart('') Chained('fetch') CaptureArgs(2) {
my ( $self, $c, $rel, $fpk_value ) = @_;
return if $self->has_errors($c);
unless ( $self->can_write($c) ) {
@@ -510,13 +526,14 @@
return;
}
if ( !$self->allow_GET_writes ) {
- if ( $c->req->method ne 'POST' ) {
- $self->throw_error('GET request not allowed');
+ if ( uc( $c->req->method ) ne 'POST' ) {
+ $c->res->status(400);
+ $c->res->body('GET request not allowed');
return;
}
}
- $c->stash->{rel_name} = $rel;
- $c->stash->{foreign_pk_value} = $fpk_value;
+ $c->stash( rel_name => $rel );
+ $c->stash( foreign_pk_value => $fpk_value );
}
=head2 remove
@@ -528,10 +545,13 @@
Example:
- http://yoururl/user/123/group/456/rm_related
+ http://yoururl/user/123/group/456/remove
will remove user C<123> from the group C<456>.
+Sets the 204 (enacted, no content) HTTP response status
+on success.
+
=cut
sub remove : PathPart Chained('related') Args(0) {
@@ -542,6 +562,7 @@
$c->stash->{rel_name},
$c->stash->{foreign_pk_value}
);
+ $c->res->status(204); # enacted, no content
}
=head2 add
@@ -554,10 +575,13 @@
Example:
- http://yoururl/user/123/group/456/add_to
+ http://yoururl/user/123/group/456/add
will add user C<123> to the group C<456>.
+Sets the 204 (enacted, no content) HTTP response status
+on success.
+
=cut
sub add : PathPart Chained('related') Args(0) {
@@ -568,7 +592,7 @@
$c->stash->{rel_name},
$c->stash->{foreign_pk_value}
);
-
+ $c->res->status(204); # enacted, no content
}
=head1 INTERNAL METHODS
@@ -778,9 +802,13 @@
sub view_on_single_result {
my ( $self, $c, $results ) = @_;
return 0 unless $self->config->{view_on_single_result};
+
+ # TODO require $results be a CatalystX::CRUD::Results object
+ # so we can call next() instead of assuming array ref.
my $obj = $results->[0];
- my $id = $self->make_primary_key_string($obj);
+ my $id = $self->make_primary_key_string($obj);
+
# the append . '' is to force stringify anything
# that might be an object with overloading. Otherwise
# uri_for() assumes it is an Action object.
Modified: CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Model/File.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Model/File.pm 2008-08-22 17:00:39 UTC (rev 8259)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Model/File.pm 2008-08-22 19:39:54 UTC (rev 8260)
@@ -8,6 +8,8 @@
use Path::Class::File;
use Class::C3;
+__PACKAGE__->mk_accessors(qw( inc_path ));
+
our $VERSION = '0.29_01';
=head1 NAME
@@ -18,14 +20,17 @@
package MyApp::Model::Foo;
use base qw( CatalystX::CRUD::Model::File );
- __PACKAGE__->config->{object_class} = 'MyApp::File';
- __PACKAGE__->config->{inc_path} = [ '/some/path', '/other/path' ];
+ __PACKAGE__->config(
+ object_class => 'MyApp::File',
+ inc_path => [ '/some/path', '/other/path' ],
+ );
1;
=head1 DESCRIPTION
-CatalystX::CRUD::Model::File is an example implementation of CatalystX::CRUD::Model.
+CatalystX::CRUD::Model::File is an example implementation
+of CatalystX::CRUD::Model.
=head1 METHODS
@@ -35,14 +40,15 @@
=head2 Xsetup
-Implements the CXC::Model API. Sets the C<inc_path> config (if not already set)
+Implements the CXC::Model API.
+Sets the inc_path() (if not already set)
to the C<root> config value.
=cut
sub Xsetup {
my ( $self, $c ) = @_;
- $self->config->{inc_path} ||= [ $c->config->{root} ];
+ $self->{inc_path} ||= [ $c->config->{root} ];
$self->next::method($c);
}
@@ -97,8 +103,6 @@
=cut
-sub inc_path { shift->config->{inc_path} }
-
=head2 make_query
Returns a I<wanted> subroutine suitable for File::Find.
@@ -172,6 +176,108 @@
return CatalystX::CRUD::Iterator::File->new($files);
}
+=head2 add_related( I<file>, I<rel_name>, I<other_file_name> )
+
+For I<rel_name> of "dir" will create a symlink for I<other_file_name>'s
+basename to I<file> in the same directory as I<file>.
+
+If a file already exists for I<other_file_name> in the same
+dir as I<file> will throw an error indicating the relationship
+already exists.
+
+If the symlink fails, will throw_error().
+
+If symlink() is not supported on your system, will print an error
+to the Catalyst log.
+
+=cut
+
+sub add_related {
+ my ( $self, $file, $rel_name, $other_file_name ) = @_;
+ my $other_file = $self->fetch( file => $other_file_name );
+
+ unless ( -r $other_file ) {
+ $self->throw_error("no such file $other_file");
+ }
+
+ if ( $rel_name eq 'dir' ) {
+
+ # if in the same dir, already related.
+ if ( $other_file->dir eq $file->dir ) {
+ $self->throw_error("relationship already exists");
+ }
+
+ # if not, create symlink
+ # wrap in eval since win32 (others?) do not support symlink
+ my $link
+ = Path::Class::File->new( $file->dir, $other_file->basename );
+ my $success = 1;
+ my $symlink_supported
+ = eval { $success = symlink( "$file", "$link" ); 1 };
+ if ($symlink_supported) {
+ if ( !$success ) {
+ $self->throw_error("failed to symlink $link => $file: $@");
+ }
+ else {
+ return 1;
+ }
+ }
+ else {
+
+ # symlink() is not supported on this system.
+ # we do not throw_error because that will cause
+ # tests to fail unnecessarily.
+ # however, we need to signal the problem somehow.
+ $self->context->log->error(
+ "symlink() is not supported on this system");
+ }
+
+ }
+ else {
+ $self->throw_error("unsupported relationship name: $rel_name");
+ }
+}
+
+=head2 rm_related( I<file>, I<rel_name>, I<other_file_name> )
+
+For I<rel_name> of "dir" will create a symlink for I<other_file_name>'s
+basename to I<file> in the same directory as I<file>.
+
+If the symlink represented by I<other_file_name> does not exist
+or is not a symlink, will throw an error.
+
+If the unlink fails will also throw an error.
+
+=cut
+
+sub rm_related {
+ my ( $self, $file, $rel_name, $other_file_name ) = @_;
+
+ my $other_file = $self->fetch( file => $other_file_name );
+
+ unless ( -r $other_file ) {
+ $self->throw_error("no such file $other_file : $!");
+ }
+
+ if ( $rel_name eq 'dir' ) {
+ my $link
+ = Path::Class::File->new( $file->dir, $other_file->basename );
+
+ unless ( -l $link ) {
+ $self->throw_error("$other_file is not a symlink");
+ }
+
+ unlink($link) or $self->throw_error("unlink for $link failed: $!");
+
+ return 1;
+
+ }
+ else {
+ $self->throw_error("unsupported relationship name: $rel_name");
+ }
+
+}
+
1;
__END__
Modified: CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Model.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Model.pm 2008-08-22 17:00:39 UTC (rev 8259)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Model.pm 2008-08-22 19:39:54 UTC (rev 8260)
@@ -11,8 +11,10 @@
our $VERSION = '0.29_01';
-__PACKAGE__->mk_accessors(qw( object_class ));
+__PACKAGE__->mk_accessors(qw( object_class page_size ));
+__PACKAGE__->config( page_size => 50 );
+
=head1 NAME
CatalystX::CRUD::Model - base class for CRUD models
@@ -104,18 +106,17 @@
sub Xsetup {
my ( $self, $c, $arg ) = @_;
- if ( exists $self->config->{object_class} ) {
- my $object_class = $self->config->{object_class};
- eval "require $object_class";
- if ($@) {
- $self->throw_error("$object_class could not be loaded: $@");
- }
- $self->object_class($object_class);
+ if ( !$self->object_class ) {
+ croak "must configure an object_class";
}
- if ( !defined $self->config->{page_size} ) {
- $self->config->{page_size} = 50;
+
+ my $object_class = $self->object_class;
+ eval "require $object_class";
+ if ($@) {
+ $self->throw_error("$object_class could not be loaded: $@");
}
+
return $self;
}
@@ -125,8 +126,6 @@
=cut
-sub page_size { shift->config->{page_size} }
-
=head2 new_object
Returns CatalystX::CRUD::Object->new(). A sane default, assuming
@@ -257,6 +256,10 @@
It is up to the subclass to implement this method.
+=item remove_related
+
+remove_related() is an alias for rm_related().
+
=item has_relationship( I<obj>, I<rel_name> )
Should return true or false as to whether I<rel_name> exists for
@@ -271,6 +274,7 @@
sub make_query { shift->throw_error("must implement make_query()") }
sub add_related { shift->throw_error("must implement add_related()") }
sub rm_related { shift->throw_error("must implement rm_related()") }
+*remove_related = \&rm_related;
sub has_relationship {
shift->throw_error("must implement has_relationship()");
Modified: CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Object/File.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Object/File.pm 2008-08-22 17:00:39 UTC (rev 8259)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Object/File.pm 2008-08-22 19:39:54 UTC (rev 8260)
@@ -45,7 +45,8 @@
my $class = shift;
my $self = $class->next::method(@_);
my $file = $self->{file} or $self->throw_error("file param required");
- $self->{delegate} = Path::Class::File->new($file);
+ $self->{delegate}
+ = Path::Class::File->new( ref $file eq 'ARRAY' ? @$file : $file );
return $self;
}
Modified: CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/REST.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/REST.pm 2008-08-22 17:00:39 UTC (rev 8259)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/REST.pm 2008-08-22 19:39:54 UTC (rev 8260)
@@ -4,7 +4,10 @@
use base qw( CatalystX::CRUD::Controller );
use Carp;
use Class::C3;
+use Data::Dump qw( dump );
+__PACKAGE__->mk_accessors(qw( enable_rpc_compat ));
+
our $VERSION = '0.29_01';
=head1 NAME
@@ -27,6 +30,7 @@
primary_key => 'id',
view_on_single_result => 0,
page_size => 50,
+ enable_rpc_compat => 0,
);
1;
@@ -56,6 +60,20 @@
Controller API, so that you can simply change your @ISA chain and enable
REST features for your application.
+B<IMPORTANT:> If you are using a CatalystX::CRUD::REST subclass
+in your application, it is important to add the following to your main
+MyApp.pm file, just after the setup() call:
+
+ __PACKAGE__->setup();
+
+ # add these 2 lines
+ use Class::C3;
+ Class::C3::initialize();
+
+This is required for Class::C3 to resolve the inheritance chain correctly,
+especially in the case where your app is subclassing more than one
+CatalystX::CRUD::Controller::* class.
+
=cut
=head1 METHODS
@@ -70,6 +88,8 @@
=cut
+__PACKAGE__->config( enable_rpc_compat => 0 );
+
sub create_form : Local {
my ( $self, $c ) = @_;
$self->fetch( $c, 0 );
@@ -92,9 +112,9 @@
$c->res->redirect( $c->uri_for('create_form') );
}
-=head2 default
+=head2 rest
-Attribute: Private
+Attribute: Path Args
Calls the appropriate method based on the HTTP method name.
@@ -107,37 +127,145 @@
'GET' => 'view'
);
-sub default : Path {
+my %rpc_methods
+ = map { $_ => 1 } qw( create read update delete edit save rm view );
+my %related_methods = map { $_ => 1 } qw( add remove );
+
+sub rest : Path Args {
my ( $self, $c, @arg ) = @_;
+ my $method = $self->req_method($c);
+
+ if ( !exists $http_method_map{$method} ) {
+ $c->res->status(400);
+ $c->res->body("Bad HTTP request for method $method");
+ return;
+ }
+
+ $c->log->debug( "rest args : " . dump \@arg ) if $c->debug;
+
+ my $n = scalar @arg;
+ if ( $n <= 2 ) {
+ $self->_rest( $c, @arg );
+ }
+ elsif ( $n <= 4 ) {
+ $self->_rest_related( $c, @arg );
+ }
+ else {
+ $self->_set_status_404($c);
+ return;
+ }
+}
+
+=head2 default
+
+Attribute: Private
+
+Returns 404 status. In theory, this action is never reached,
+and if it is, will log an error. It exists only for debugging
+purposes.
+
+=cut
+
+sub default : Private {
+ my ( $self, $c, @arg ) = @_;
+ $c->log->error("default method reached");
+ $self->_set_status_404($c);
+}
+
+sub _set_status_404 {
+ my ( $self, $c ) = @_;
+ $c->res->status(404);
+ $c->res->body('Resource not found');
+}
+
+sub _rest_related {
+ my ( $self, $c, @arg ) = @_;
+ my ( $oid, $rel_name, $fval, $rpc ) = @arg;
+
+ $c->log->debug("rest_related OID: $oid") if $c->debug;
+
+ if ($rpc) {
+ if ( !$self->enable_rpc_compat or !exists $related_methods{$rpc} ) {
+ $self->_set_status_404($c);
+ return;
+ }
+ }
+
+ my $http_method = $self->req_method($c);
+
+ $self->related( $c, $rel_name, $fval );
+
+ my $rpc_method;
+ if ($rpc) {
+ $rpc_method = $rpc;
+ }
+ elsif ( $http_method eq 'POST' or $http_method eq 'PUT' ) {
+ $rpc_method = 'add';
+ }
+ elsif ( $http_method eq 'DELETE' ) {
+ $rpc_method = 'remove';
+ }
+ else {
+
+ # related() will screen for GET based on config
+ # but we do not allow that for REST
+ $c->res->status(400);
+ $c->res->body("Bad HTTP request for method $http_method");
+ return;
+ }
+
+ $self->_call_rpc_method_as_action( $c, $rpc_method, $oid );
+}
+
+sub _rest {
+ my ( $self, $c, @arg ) = @_;
+
my $oid = shift @arg || '';
- my $rpc = shift @arg; # RPC compat
- $c->log->debug("default OID: $oid") if $c->debug;
+ my $rpc = shift @arg;
+ $c->log->debug("rest OID: $oid") if $c->debug;
+
+ if ($rpc) {
+ if ( !$self->enable_rpc_compat or !exists $rpc_methods{$rpc} ) {
+ $self->_set_status_404($c);
+ return;
+ }
+ }
+
my $method = $self->req_method($c);
+
if ( !length $oid && $method eq 'GET' ) {
$c->action->name('list');
$c->action->reverse( join( '/', $c->action->namespace, 'list' ) );
return $self->list($c);
}
- # everything else requires fetch()
- $self->fetch( $c, $oid );
-
# what RPC-style method to call
- my $to_call = defined($rpc) ? $rpc : $http_method_map{$method};
+ my $rpc_method = defined($rpc) ? $rpc : $http_method_map{$method};
# backwards compat naming for RPC style
- if ( $to_call =~ m/^(create|edit)$/ ) {
- $to_call .= '_form';
+ if ( $rpc_method =~ m/^(create|edit)$/ ) {
+ $rpc_method .= '_form';
}
- $c->log->debug("$method -> $to_call") if $c->debug;
- # so TT (others?) auto-template-deduction works just like RPC style
- $c->action->name($to_call);
- $c->action->reverse( join( '/', $c->action->namespace, $to_call ) );
+ $self->_call_rpc_method_as_action( $c, $rpc_method, $oid );
+}
- return $self->can($to_call) ? $self->$to_call($c) : $self->view($c);
+sub _call_rpc_method_as_action {
+ my ( $self, $c, $rpc_method, $oid ) = @_;
+
+ $self->fetch( $c, $oid );
+
+ my $http_method = $self->req_method($c);
+
+ $c->log->debug("$http_method -> $rpc_method") if $c->debug;
+
+ # so View::TT (others?) auto-template-deduction works just like RPC style
+ $c->action->name($rpc_method);
+ $c->action->reverse( join( '/', $c->action->namespace, $rpc_method ) );
+
+ return $self->$rpc_method($c);
}
=head2 req_method( I<context> )
@@ -209,6 +337,61 @@
return $self->next::method($c);
}
+=head2 remove( I<context> )
+
+Overrides base method to disable chaining.
+
+=cut
+
+sub remove {
+ my ( $self, $c ) = @_;
+ return $self->next::method($c);
+}
+
+=head2 add( I<context> )
+
+Overrides base method to disable chaining.
+
+=cut
+
+sub add {
+ my ( $self, $c ) = @_;
+ return $self->next::method($c);
+}
+
+=head2 delete( I<context> )
+
+Overrides base method to disable chaining.
+
+=cut
+
+sub delete {
+ my ( $self, $c ) = @_;
+ return $self->next::method($c);
+}
+
+=head2 read( I<context> )
+
+Overrides base method to disable chaining.
+
+=cut
+
+sub read {
+ my ( $self, $c ) = @_;
+ return $self->next::method($c);
+}
+
+=head2 update( I<context> )
+
+Overrides base method to disable chaining.
+
+=cut
+
+sub update {
+ my ( $self, $c ) = @_;
+ return $self->next::method($c);
+}
+
=head2 postcommit( I<context>, I<object> )
Overrides base method to redirect to REST-style URL.
Modified: CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Test/Controller.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Test/Controller.pm 2008-08-22 17:00:39 UTC (rev 8259)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Test/Controller.pm 2008-08-22 19:39:54 UTC (rev 8260)
@@ -4,6 +4,7 @@
use base qw( CatalystX::CRUD::Controller );
use Carp;
use Data::Dump;
+use Class::C3;
our $VERSION = '0.29_01';
@@ -113,7 +114,8 @@
sub form {
my ( $self, $c ) = @_;
my $form_class = $self->config->{form_class};
- my $form = $form_class->new( { fields => $self->config->{form_fields} } );
+ my $arg = { fields => $self->config->{form_fields} };
+ my $form = $form_class->new($arg);
return $form;
}
@@ -134,7 +136,9 @@
$c->res->body( $self->serialize_object( $c, $c->stash->{object} ) );
}
if ( $self->has_errors($c) ) {
- $c->res->body( join( "\n", @{ $c->error } ) );
+ my $err = join( "\n", @{ $c->error } );
+ $c->log->error($err) if $c->debug;
+ $c->res->body($err);
$c->res->status(500);
$c->clear_errors;
}
Modified: CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Test/Form.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Test/Form.pm 2008-08-22 17:00:39 UTC (rev 8259)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Test/Form.pm 2008-08-22 19:39:54 UTC (rev 8260)
@@ -141,7 +141,9 @@
sub init_with_object {
my ( $self, $object ) = @_;
for my $f ( keys %{ $self->params } ) {
- $self->params->{$f} = $object->$f;
+ if ( $object->can($f) ) {
+ $self->params->{$f} = $object->$f;
+ }
}
return $self;
}
@@ -156,7 +158,9 @@
sub object_from_form {
my ( $self, $object ) = @_;
for my $f ( keys %{ $self->params } ) {
- $object->$f( $self->params->{$f} );
+ if ( $object->can($f) ) {
+ $object->$f( $self->params->{$f} );
+ }
}
return $object;
}
Modified: CatalystX-CRUD/CatalystX-CRUD/trunk/t/01-file.t
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/t/01-file.t 2008-08-22 17:00:39 UTC (rev 8259)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/t/01-file.t 2008-08-22 19:39:54 UTC (rev 8260)
@@ -1,4 +1,5 @@
-use Test::More tests => 24;
+use Test::More tests => 35;
+use strict;
use lib qw( lib t/lib );
use_ok('CatalystX::CRUD::Model::File');
use_ok('CatalystX::CRUD::Object::File');
@@ -8,7 +9,7 @@
use HTTP::Request::Common;
###########################################
-# set up the test env and config
+# basic sanity check
ok( get('/foo'), "get /foo" );
ok( my $response = request('/file/search'), "response for /file/search" );
@@ -36,6 +37,8 @@
"POST new file response"
);
+is( $res->headers->{status}, 302, "new file 302 redirect status" );
+
# read the file we just created
ok( $res = request( HTTP::Request->new( GET => '/file/testfile/view' ) ),
"GET new file" );
@@ -53,10 +56,48 @@
like( $res->content, qr/content => "foo bar baz"/, "update file" );
+# test for default()
+ok( $res = request('/file/testfile'), "get /file/testfile" );
+
+is( $res->headers->{status}, 404, "default is 404" );
+
+# create related file
+ok( $res = request(
+ POST( '/file/otherdir%2ftestfile2/save', [ content => 'hello world 2' ] )
+ ),
+ "POST new file2"
+);
+
+is( $res->content,
+ '{ content => "hello world 2", file => "otherdir/testfile2" }',
+ "POST new file2 response"
+);
+
+is( $res->headers->{status}, 302, "new file 302 redirect status" );
+
+# create relationship
+ok( $res = request( POST( '/file/testfile/dir/otherdir%2ftestfile2/add', [] ) ),
+ "add related dir/otherdir%2ftestfile2" );
+
+#dump $res;
+
+is( $res->headers->{status}, 204, "relationship created with status 204" );
+
+# remove the relationship
+
+ok( $res = request( POST( '/file/testfile/dir/otherdir%2ftestfile2/remove', [] ) ),
+ "remove related dir/testfile2" );
+
+is( $res->headers->{status}, 204, "relationship removed with status 204" );
+
# delete the file
-ok( $res = request( POST( '/file/testfile/rm', [] ) ), "rm file" );
+ok( $res = request( POST( '/file/testfile/delete', [] ) ), "rm file" );
+# delete the file2
+
+ok( $res = request( POST( '/file/testfile2/delete', [] ) ), "rm file2" );
+
#diag( $res->content );
# confirm it is gone
Modified: CatalystX-CRUD/CatalystX-CRUD/trunk/t/02-controller.t
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/t/02-controller.t 2008-08-22 17:00:39 UTC (rev 8259)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/t/02-controller.t 2008-08-22 19:39:54 UTC (rev 8260)
@@ -1,4 +1,5 @@
use Test::More tests => 7 ;
+use strict;
use_ok('CatalystX::CRUD::Controller');
ok(my $controller = CatalystX::CRUD::Controller->new, "new controller");
Added: CatalystX-CRUD/CatalystX-CRUD/trunk/t/03-rest.t
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/t/03-rest.t (rev 0)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/t/03-rest.t 2008-08-22 19:39:54 UTC (rev 8260)
@@ -0,0 +1,155 @@
+use Test::More tests => 43;
+use strict;
+use lib qw( lib t/lib );
+use_ok('CatalystX::CRUD::Model::File');
+use_ok('CatalystX::CRUD::Object::File');
+
+use Catalyst::Test 'MyApp';
+use Data::Dump qw( dump );
+use HTTP::Request::Common;
+
+###########################################
+# do CRUD stuff
+
+my $res;
+
+# create
+ok( $res = request(
+ POST( '/rest/file/testfile', [ content => 'hello world' ] )
+ ),
+ "POST new file"
+);
+
+is( $res->content,
+ '{ content => "hello world", file => "testfile" }',
+ "POST new file response"
+);
+
+# read the file we just created
+ok( $res = request( HTTP::Request->new( GET => '/rest/file/testfile' ) ),
+ "GET new file" );
+
+#diag( $res->content );
+
+like( $res->content, qr/content => "hello world"/, "read file" );
+
+# update the file
+ok( $res = request(
+ POST( '/rest/file/testfile', [ content => 'foo bar baz' ] )
+ ),
+ "update file"
+);
+
+like( $res->content, qr/content => "foo bar baz"/, "update file" );
+
+# create related file
+ok( $res = request(
+ POST(
+ '/rest/file/otherdir%2ftestfile2',
+ [ content => 'hello world 2' ]
+ )
+ ),
+ "POST new file2"
+);
+
+is( $res->content,
+ '{ content => "hello world 2", file => "otherdir/testfile2" }',
+ "POST new file2 response"
+);
+
+is( $res->headers->{status}, 302, "new file 302 redirect status" );
+
+# test the Arg matching with no rpc
+
+ok( $res = request('/rest/file'), "zero" );
+is( $res->headers->{status}, 302, "redirect == zero" );
+ok( $res = request('/rest/file/testfile'), "one" );
+is( $res->headers->{status}, 200, "oid == one" );
+ok( $res = request('/rest/file/testfile/view'), "view" );
+is( $res->headers->{status}, 404, "rpc == two" );
+ok( $res
+ = request(
+ POST( '/rest/file/testfile/dir/otherdir%2ftestfile2', [] ) ),
+ "three"
+);
+is( $res->headers->{status}, 204, "related == three" );
+ok( $res = request(
+ POST( '/rest/file/testfile/dir/otherdir%2ftestfile2/rpc', [] )
+ ),
+ "four"
+);
+is( $res->headers->{status},
+ 404, "404 == related rpc with no enable_rpc_compat" );
+ok( $res = request('/rest/file/testfile/two/three/four/five'), "five" );
+is( $res->headers->{status}, 404, "404 == five" );
+ok( $res = request(
+ POST(
+ '/rest/file/testfile/dir/otherdir%2ftestfile2',
+ [ 'x-tunneled-method' => 'DELETE' ]
+ )
+ ),
+ "three"
+);
+is( $res->headers->{status}, 204, "related == three" );
+
+# turn rpc enable on and run again
+MyApp->controller('REST::File')->enable_rpc_compat(1);
+
+ok( $res = request('/rest/file'), "zero with rpc" );
+is( $res->headers->{status}, 302, "redirect == zero with rpc" );
+ok( $res = request('/rest/file/testfile'), "one with rpc" );
+is( $res->headers->{status}, 200, "oid == one with rpc" );
+ok( $res = request('/rest/file/testfile/view'), "view with rpc" );
+is( $res->headers->{status}, 200, "rpc == two with rpc" );
+ok( $res = request(
+ POST( '/rest/file/testfile/dir/otherdir%2ftestfile2/add', [] )
+ ),
+ "three with rpc"
+);
+is( $res->headers->{status}, 204, "related == three with rpc" );
+ok( $res = request(
+ POST( '/rest/file/testfile/dir/otherdir%2ftestfile2/rpc', [] )
+ ),
+ "four"
+);
+is( $res->headers->{status},
+ 404, "404 == related rpc with enable_rpc_compat" );
+
+ok( $res = request('/rest/file/testfile/two/three/four/five'),
+ "five with rpc" );
+is( $res->headers->{status}, 404, "404 == five with rpc" );
+
+ok( $res = request(
+ POST(
+ '/rest/file/testfile/dir/otherdir%2ftestfile2/remove',
+ [ 'x-tunneled-method' => 'DELETE' ]
+ )
+ ),
+ "three with rpc"
+);
+is( $res->headers->{status}, 204, "related == three with rpc" );
+
+# delete the file
+
+ok( $res = request(
+ POST( '/rest/file/testfile', [ _http_method => 'DELETE' ] )
+ ),
+ "rm file"
+);
+
+ok( $res = request(
+ POST( '/rest/file/testfile2/delete', [ _http_method => 'DELETE' ] )
+ ),
+ "rm file2"
+);
+
+#diag( $res->content );
+
+# confirm it is gone
+ok( $res = request( HTTP::Request->new( GET => '/rest/file/testfile' ) ),
+ "confirm we nuked the file" );
+
+#diag( $res->content );
+
+like( $res->content, qr/content => undef/, "file nuked" );
+
Added: CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp/Controller/REST/File.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp/Controller/REST/File.pm (rev 0)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp/Controller/REST/File.pm 2008-08-22 19:39:54 UTC (rev 8260)
@@ -0,0 +1,55 @@
+package MyApp::Controller::REST::File;
+use strict;
+use base qw(
+ CatalystX::CRUD::REST
+ CatalystX::CRUD::Test::Controller
+);
+use Carp;
+use Data::Dump qw( dump );
+use File::Temp;
+use MyApp::Form;
+use Class::C3;
+
+__PACKAGE__->config(
+ primary_key => 'absolute',
+ form_class => 'MyApp::Form',
+ form_fields => [qw( file content )],
+ model_name => 'File',
+ primary_key => 'file',
+ init_form => 'init_with_file',
+ init_object => 'file_from_form',
+);
+
+# test the view_on_single_result method
+# search for a file where we know there is only one
+# and then check for a redirect response code
+
+# TODO real search
+
+sub do_search {
+
+ my ( $self, $c, @arg ) = @_;
+
+ $self->config->{view_on_single_result} = 1;
+
+ my $tmpf = File::Temp->new;
+
+ my $file = $c->model( $self->model_name )
+ ->new_object( file => $tmpf->filename );
+
+ if ( my $uri = $self->view_on_single_result( $c, [$file] ) ) {
+ $c->response->redirect($uri);
+ return;
+ }
+
+ $self->throw_error("view_on_single_result failed");
+
+}
+
+sub end : Private {
+ my ( $self, $c ) = @_;
+ $c->log->debug( "Body: " . $c->res->body ) if $c->debug;
+ $self->next::method($c);
+}
+
+1;
Modified: CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp/Model/File.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp/Model/File.pm 2008-08-22 17:00:39 UTC (rev 8259)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp/Model/File.pm 2008-08-22 19:39:54 UTC (rev 8260)
@@ -2,7 +2,7 @@
use strict;
use base qw( CatalystX::CRUD::Model::File );
use MyApp::File;
-__PACKAGE__->config->{object_class} = 'MyApp::File';
+__PACKAGE__->config( object_class => 'MyApp::File' );
1;
Modified: CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp.pm 2008-08-22 17:00:39 UTC (rev 8259)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp.pm 2008-08-22 19:39:54 UTC (rev 8260)
@@ -3,40 +3,50 @@
use Catalyst;
use Carp;
use Data::Dump qw( dump );
-use File::Temp;
-our $VERSION = '0.03';
+our $VERSION = '0.04';
__PACKAGE__->setup();
+Class::C3::initialize(); # for REST
+
+my @temp_files;
+
+sub push_temp_files {
+ shift;
+ push( @temp_files, @_ );
+}
+
+END {
+ for my $f (@temp_files) {
+ warn "unlinking $f\n" if $ENV{CATALYST_DEBUG};
+ $f->remove;
+ }
+}
+
sub foo : Local {
my ( $self, $c, @arg ) = @_;
- my $tempf = File::Temp->new;
+ #carp "inc_path: " . dump $c->model('File')->inc_path;
- # have to set inc_path() after we create our first file
- # so that we know where the temp dir is.
+ my $file
+ = $c->model('File')
+ ->new_object(
+ file => [ $c->model('File')->inc_path->[0], 'crud_temp_file' ] );
- #carp "inc_path: " . dump $c->model('File')->inc_path;
+ $self->push_temp_files($file);
- my $file = $c->model('File')->new_object( file => $tempf->filename );
-
#carp dump $file;
$file->content('hello world');
- $file->create;
+ $file->create or croak "failed to create $file : $!";
my $filename = $file->basename;
#carp "filename = $filename";
- # set inc_path now that we know dir
- $c->model('File')->config->{inc_path} = [ $file->dir ];
-
- #carp "inc_path: " . dump $c->model('File')->inc_path;
-
$file = $c->model('File')->fetch( file => $filename );
#carp dump $file;
@@ -49,12 +59,14 @@
$file->content('change the text');
- #carp dump $file;
+ #carp $file;
$file->update;
$file = $c->model('File')->fetch( file => $filename );
+ #carp $file;
+
$c->res->body("foo is a-ok");
}
@@ -62,12 +74,14 @@
sub autoload : Local {
my ( $self, $c ) = @_;
- my $tempf = File::Temp->new;
+ my $file = $c->model('File')->new_object(
+ file => [ $c->model('File')->inc_path->[0], 'autoload_test' ],
+ content => 'test AUTOLOAD black magic'
+ );
- # have to set inc_path() after we create our first file
- # so that we know where the temp dir is.
+ $self->push_temp_files($file);
- my $file = $c->model('File')->new_object( file => $tempf->filename );
+ $file->create;
#warn "testing basename on $file";
More information about the Catalyst-commits
mailing list