CatalystX::CRUD::Controller - base class for CRUD controllers

    # create a controller
    package MyApp::Controller::Foo;
    use strict;
    use base qw( CatalystX::CRUD::Controller );

    __PACKAGE__->config(
            form_class              => 'MyForm::Foo',
            init_form               => 'init_with_foo',
            init_object             => 'foo_from_form',
            default_template        => 'path/to/foo/edit.tt',
            model_name              => 'Foo',
            model_adapter           => 'FooAdapter', # optional
            model_meta              => { moniker => 'SomeTable' },  # optional
            primary_key             => 'id',
            view_on_single_result   => 0,
            page_size               => 50,
            allow_GET_writes        => 0,
            naked_results           => 0,
    );

    1;

    # now you can manage Foo objects using your MyForm::Foo form class
    # with URIs at:
    #  foo/<pk>/edit
    #  foo/<pk>/view
    #  foo/<pk>/save
    #  foo/<pk>/rm
    #  foo/create
    #  foo/list
    #  foo/search

 /uri/for/user/1234
 /uri/for/user/foobar

 $c->stash->{object}

 http://localhost/foo/create?name=bar
 # form and object will have name set to 'bar'

 http://yourhost/foo/123/bars/456/add

 http://yoururl/user/123/group/456/remove

 http://yoururl/user/123/group/456/add

    perldoc CatalystX::CRUD

package CatalystX::CRUD::Controller;
use strict;
use warnings;
use base qw(
    CatalystX::CRUD
    Catalyst::Controller
);
use Carp;
use Catalyst::Utils;
use CatalystX::CRUD::Results;
use MRO::Compat;
use mro 'c3';
use Data::Dump qw( dump );

__PACKAGE__->mk_accessors(
    qw(
        model_adapter
        form_class
        init_form
        init_object
        model_name
        model_meta
        default_template
        primary_key
        allow_GET_writes
        naked_results
        page_size
        view_on_single_result
        )
);

__PACKAGE__->config(
    primary_key           => 'id',
    view_on_single_result => 0,
    page_size             => 50,
    allow_GET_writes      => 0,
    naked_results         => 0,
);

our $VERSION = '0.51';

sub auto : Private {
    my ( $self, $c, @args ) = @_;
    $c->stash->{form} = $self->form($c);
    $self->maybe::next::method( $c, @args );
    1;
}

sub default : Path {
    my ( $self, $c, @args ) = @_;
    $c->res->body('Not found');
    $c->res->status(404);
}

sub fetch : Chained('/') PathPrefix CaptureArgs(1) {
    my ( $self, $c, $id ) = @_;
    $c->stash->{object_id} = $id;
    my @pk = $self->get_primary_key( $c, $id );

    # make sure all elements of the @pk pairs are not-null
    if ( scalar(@pk) % 2 ) {
        $self->throw_error(
            "Odd number of elements returned from get_primary_key()");
    }
    my %pk_pairs = @pk;
    my $pk_is_null;
    for my $key ( keys %pk_pairs ) {
        my $val = $pk_pairs{$key};
        if ( !defined($val) or !length($val) ) {
            $pk_is_null = $key;
            last;
        }
    }
    if ( $c->debug and defined $pk_is_null ) {
        $c->log->debug("Null PK value for '$pk_is_null'");
    }
    my @arg = ( defined $pk_is_null || !$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 );
    }
}

sub get_primary_key {
    my ( $self, $c, $id ) = @_;
    return () unless defined $id and length $id;
    my $pk = $self->primary_key;
    my @ret;
    if ( ref $pk ) {
        my @val = split( m/;;/, $id );
        for my $col (@$pk) {
            push( @ret, $col => shift(@val) );
        }
    }
    else {
        @ret = ( $pk => $id );
    }
    return @ret;
}

sub make_primary_key_string {
    my ( $self, $obj ) = @_;
    my $pk = $self->primary_key;
    my $id;
    if ( ref $pk ) {
        my @vals;
        for my $field (@$pk) {
            my $v = scalar $obj->$field;
            $v = '' unless defined $v;
            $v =~ s/;/\%3b/g;
            push( @vals, $v );
        }

        # if we had no vals, return undef
        if ( !grep {length} @vals ) {
            return $id;
        }

        $id = join( ';;', @vals );
    }
    else {
        $id = $obj->$pk;
    }

    return $id unless defined $id;

    # must escape any / in $id since passing it to uri_for as-is
    # will break.
    $id =~ s!/!\%2f!g;

    return $id;
}

sub create : Path('create') {
    my ( $self, $c ) = @_;
    $self->fetch( $c, 0 );

    # allow for params to be passed in to seed the form/object
    my $form = $c->stash->{form};
    my $obj  = $c->stash->{object};
    if ( $form->can('field_value') ) {
        for my $field ( $self->field_names($c) ) {
            $c->log->debug("checking for param: $field") if $c->debug;
            if ( exists $c->req->params->{$field} ) {
                $c->log->debug("setting form param: $field") if $c->debug;
                $form->field_value( $field => $c->req->params->{$field} );
                if ( $obj->can($field) ) {
                    $c->log->debug("setting object method: $field")
                        if $c->debug;
                    $obj->$field( $c->req->params->{$field} );
                }
            }
        }
    }

    $self->edit($c);

}

sub edit : PathPart Chained('fetch') Args(0) {
    my ( $self, $c ) = @_;
    return if $self->has_errors($c);
    unless ( $self->can_read($c) ) {
        $self->throw_error('Permission denied');
        return;
    }
    my $meth = $self->init_form;
    $c->stash->{form}->$meth( $c->stash->{object} );

    # might get here from create()
    $c->stash->{template} = $self->default_template;
}

sub view : PathPart Chained('fetch') Args(0) {
    my ( $self, $c ) = @_;
    return if $self->has_errors($c);
    unless ( $self->can_read($c) ) {
        $self->throw_error('Permission denied');
        return;
    }
    my $meth = $self->init_form;
    $c->stash->{form}->$meth( $c->stash->{object} );
}

sub read : PathPart Chained('fetch') Args(0) {
    my ( $self, $c ) = @_;
    $self->view($c);
}

sub save : PathPart Chained('fetch') Args(0) {
    my ( $self, $c ) = @_;

    if ( !$self->allow_GET_writes ) {
        if ( $c->req->method ne 'POST' ) {
            $c->res->status(400);
            $c->res->body('GET request not allowed');
            return;
        }
    }

    if ($c->request->params->{'_delete'}
        or ( exists $c->request->params->{'x-tunneled-method'}
            and $c->request->params->{'x-tunneled-method'} eq 'DELETE' )
        )
    {
        $c->action->name('rm');    # so we can test against it in postcommit()
        $self->rm($c);
        return;
    }

    return if $self->has_errors($c);
    unless ( $self->can_write($c) ) {
        $self->throw_error('Permission denied');
        return;
    }

    # get a valid object
    my $obj = $self->form_to_object($c);
    if ( !$obj ) {
        $c->log->debug("form_to_object() returned false") if $c->debug;
        return 0;
    }

    # write our changes
    unless ( $self->precommit( $c, $obj ) ) {
        $c->stash->{template} ||= $self->default_template;
        return 0;
    }
    $self->save_obj( $c, $obj );
    $self->postcommit( $c, $obj );

    1;
}

sub update : PathPart Chained('fetch') Args(0) {
    my ( $self, $c ) = @_;
    $self->save($c);
}

sub rm : PathPart Chained('fetch') Args(0) {
    my ( $self, $c ) = @_;
    if ( !$self->allow_GET_writes ) {
        if ( $c->req->method ne 'POST' ) {
            $c->res->status(400);
            $c->res->body('GET request not allowed');
            return;
        }
    }
    return if $self->has_errors($c);
    unless ( $self->can_write($c) ) {
        $self->throw_error('Permission denied');
        return;
    }

    my $o = $c->stash->{object};

    unless ( $self->precommit( $c, $o ) ) {
        return 0;
    }
    if ( $self->model_adapter ) {
        $self->model_adapter->delete( $c, $o );
    }
    else {
        $o->delete;
    }
    $self->postcommit( $c, $o );
}

sub delete : PathPart Chained('fetch') Args(0) {
    my ( $self, $c ) = @_;
    $self->rm($c);
}

sub list : Local {
    my ( $self, $c, @arg ) = @_;
    unless ( $self->can_read($c) ) {
        $self->throw_error('Permission denied');
        return;
    }

    $self->do_search( $c, @arg );
}

sub search : Local {
    my ( $self, $c, @arg ) = @_;
    unless ( $self->can_read($c) ) {
        $self->throw_error('Permission denied');
        return;
    }

    $self->do_search( $c, @arg );
}

sub count : Local {
    my ( $self, $c, @arg ) = @_;
    unless ( $self->can_read($c) ) {
        $self->throw_error('Permission denied');
        return;
    }

    $c->stash->{fetch_no_results} = 1;

    $self->do_search( $c, @arg );
}

sub related : PathPart('') Chained('fetch') CaptureArgs(2) {
    my ( $self, $c, $rel, $fpk_value ) = @_;
    return if $self->has_errors($c);
    unless ( $self->can_write($c) ) {
        $self->throw_error('Permission denied');
        return;
    }
    if ( !$self->allow_GET_writes ) {
        if ( uc( $c->req->method ) ne 'POST' ) {
            $c->res->status(400);
            $c->res->body('GET request not allowed');
            $c->stash->{error} = 1;    # so has_errors() will return true
            return;
        }
    }
    $c->stash( rel_name         => $rel );
    $c->stash( foreign_pk_value => $fpk_value );
}

sub remove : PathPart Chained('related') Args(0) {
    my ( $self, $c ) = @_;
    return if $self->has_errors($c);
    $self->do_model(
        $c, 'rm_related', $c->stash->{object},
        $c->stash->{rel_name},
        $c->stash->{foreign_pk_value}
    );
    $c->res->status(204);    # enacted, no content
}

sub add : PathPart Chained('related') Args(0) {
    my ( $self, $c ) = @_;
    return if $self->has_errors($c);
    $self->do_model(
        $c, 'add_related', $c->stash->{object},
        $c->stash->{rel_name},
        $c->stash->{foreign_pk_value}
    );
    $c->res->status(204);    # enacted, no content
}

sub new {
    my ( $class, $app_class, $args ) = @_;
    my $self = $class->next::method( $app_class, $args );

    # if model_adapter class is defined, load and instantiate it.
    if ( $self->model_adapter ) {
        Catalyst::Utils::ensure_class_loaded( $self->model_adapter );
        $self->model_adapter(
            $self->model_adapter->new(
                {   model_name => $self->model_name,
                    model_meta => $self->model_meta,
                    app_class  => $app_class,
                }
            )
        );
    }
    return $self;
}

sub do_model {
    my $self   = shift;
    my $c      = shift or $self->throw_error("context required");
    my $method = shift or $self->throw_error("method required");
    if ( $self->model_adapter ) {
        return $self->model_adapter->$method( $self, $c, @_ );
    }
    else {
        return $c->model( $self->model_name )->$method(@_);
    }
}

sub model_can {
    my $self   = shift;
    my $c      = shift or $self->throw_error("context required");
    my $method = shift or $self->throw_error("method name required");
    if ( $self->model_adapter ) {
        return $self->model_adapter->can($method);
    }
    else {
        return $c->model( $self->model_name )->can($method);
    }
}

sub form {
    my ( $self, $c ) = @_;
    $self->{_form} ||= $self->form_class->new;
    if ( $self->{_form}->can('clear') ) {
        $self->{_form}->clear;
    }
    elsif ( $self->{_form}->can('reset') ) {
        $self->{_form}->reset;
    }
    $self->maybe::next::method($c);
    return $self->{_form};
}

sub field_names {
    my ($self) = @_;
    return $self->form->field_names;
}

sub can_read {1}

sub can_write {1}

sub form_to_object {
    shift->throw_error("must override form_to_object()");
}

sub save_obj {
    my ( $self, $c, $obj ) = @_;
    my $method = $c->stash->{object_id} ? 'update' : 'create';
    if ( $self->model_adapter ) {
        $self->model_adapter->$method( $c, $obj );
    }
    else {
        $obj->$method;
    }
}

sub precommit {1}

sub postcommit {
    my ( $self, $c, $o ) = @_;

    unless ( defined $c->res->location and length $c->res->location ) {
        my $id = $self->make_primary_key_string($o);

        if ( $c->action->name eq 'rm' ) {
            $c->response->redirect( $c->uri_for('') );
        }
        else {
            $c->response->redirect( $c->uri_for( '', $id, 'view' ) );
        }
    }

    1;
}

sub uri_for_view_on_single_result {
    my ( $self, $c, $results ) = @_;
    return 0 unless $self->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);

    # force stringify $id in case it is an object.
    # Otherwise uri_for() assumes it is an Action object.
    return $c->uri_for( "$id", 'view' );
}

sub do_search {
    my ( $self, $c, @arg ) = @_;

    # stash the form so it can be re-displayed
    # subclasses must stick-ify it in their own way.
    $c->stash->{form} ||= $self->form($c);

    # if we have no input, just return for initial search
    if ( !@arg && !$c->req->param && $c->action->name eq 'search' ) {
        return;
    }

    # turn flag on unless explicitly turned off
    $c->stash->{view_on_single_result} = 1
        unless exists $c->stash->{view_on_single_result};

    my $query;
    if ( $self->can('make_query') ) {
        $query = $self->make_query( $c, @arg );
    }
    elsif ( $self->model_can( $c, 'make_query' ) ) {
        $query = $self->do_model( $c, 'make_query', @arg );
    }
    else {
        $self->throw_error(
            "neither controller nor model implement a make_query() method");
    }
    my $count = $self->do_model( $c, 'count', $query ) || 0;
    my $results;
    unless ( $c->stash->{fetch_no_results} ) {
        $results = $self->do_model( $c, 'search', $query );
    }

    if (   $results
        && $count == 1
        && $c->stash->{view_on_single_result}
        && ( my $uri = $self->uri_for_view_on_single_result( $c, $results ) )
        )
    {
        $c->log->debug("redirect for single_result") if $c->debug;
        $c->response->redirect($uri);
    }
    else {

        my $pager;
        if ( $count && $self->model_can( $c, 'make_pager' ) ) {
            $pager = $self->do_model( $c, 'make_pager', $count, $results );
        }

        $c->stash->{results}
            = $self->naked_results
            ? $results
            : CatalystX::CRUD::Results->new(
            {   count   => $count,
                pager   => $pager,
                results => $results,
                query   => $query,
            }
            );
    }

}

# see http://use.perl.org/~LTjake/journal/31738
# PathPrefix will likely end up in an official Catalyst RSN.
# This lets us have a sane default fetch() method without having
# to write one in each subclass.
sub _parse_PathPrefix_attr {
    my ( $self, $c, $name, $value ) = @_;
    return PathPart => $self->path_prefix;
}

1;

__END__