CatalystX::CRUD::ModelAdapter::DBIC - CRUD for Catalyst::Model::DBIC::Schema

 # create an adapter class (NOTE not in ::Model namespace)
 package MyApp::MyDBICAdapter;
 use strict;
 use base qw( CatalystX::CRUD::ModelAdapter::DBIC );

 1;

 # your main DBIC::Schema model
 package MyApp::Model::MyDBIC;
 use strict;
 use base qw( Catalyst::Model::DBIC::Schema );

 1;

    perldoc CatalystX::CRUD::ModelAdapter::DBIC

package CatalystX::CRUD::ModelAdapter::DBIC;
use warnings;
use strict;
use base qw(
    CatalystX::CRUD::ModelAdapter
    CatalystX::CRUD::Model::Utils
);
use MRO::Compat;
use mro 'c3';
use Scalar::Util qw( weaken );
use Carp;
use Data::Dump qw( dump );
use Sort::SQL;

__PACKAGE__->mk_ro_accessors(qw( treat_like_int ));

our $VERSION = '0.11';

# TODO others?
my %is_iliker = (
    Pg         => 1,
    PostgreSQL => 1,
);

sub new {
    my $self = shift->next::method(@_);

    # what kind of db driver are we using.
    # makes a difference in make_sql_query().
    my $db_type
        = $self->app_class->model( $self->model_name )->storage->sqlt_type;

    #warn "DBIC driver: " . $db_type;

    $self->use_ilike( exists $is_iliker{$db_type} );

    # SQL for not equal
    $self->ne_sign('!=');

    # cache the treat_like_int hash
    $self->_treat_like_int;

    #warn dump $self;

    return $self;
}

sub _treat_like_int {
    my $self     = shift;
    my $treat    = {};
    my $moniker  = $self->_get_moniker;
    my $rs_class = $self->app_class->model( $self->model_name )
        ->composed_schema->class($moniker);
    for my $col ( $rs_class->columns ) {
        my $info = $rs_class->column_info($col);

        #warn "$col : " . dump($info);

        if ( keys %$info ) {
            if (    $info->{data_type}
                and $info->{data_type} =~ m/(boolean|date|int)/ )
            {
                $treat->{$col} = 1;
            }
        }

    }

    $self->{treat_like_int} = $treat;
}

sub new_object {
    my $self       = shift;
    my $controller = shift;
    my $c          = shift;
    my $moniker    = $self->_get_moniker($c);
    return $c->model( $self->model_name )->resultset($moniker)
        ->new_result( {} );
}

sub fetch {
    my $self       = shift;
    my $controller = shift;
    my $c          = shift;
    my $moniker    = $self->_get_moniker($c);
    if (@_) {
        my $dbic_obj;
        eval {
            $dbic_obj
                = $c->model( $self->model_name )->resultset($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");
        }

        return $dbic_obj;
    }
    else {
        return $self->new_object( $controller, $c );
    }
}

sub search {
    my ( $self, $controller, $c, @arg ) = @_;
    my $query = shift(@arg) || $self->make_query( $controller, $c );
    my @rs
        = $c->model( $self->model_name )->resultset( $self->_get_moniker($c) )
        ->search( $query->{WHERE}, $query->{OPTS} );
    return wantarray ? @rs : \@rs;
}

sub _get_moniker {
    my ( $self, $c ) = @_;
    my $moniker;
    if ( defined $c ) {
        $moniker = $c->stash->{dbic_schema}
            || $self->model_meta->{dbic_schema};
    }
    else {
        $moniker = $self->model_meta->{dbic_schema};
    }
    unless ($moniker) {
        $self->throw_error(
            "must define a dbic_schema in model_meta config for each CRUD controller"
        );
    }
    return $moniker;
}

sub iterator {
    my ( $self, $controller, $c, @arg ) = @_;
    my $query = shift(@arg) || $self->make_query( $controller, $c );
    my $rs
        = $c->model( $self->model_name )->resultset( $self->_get_moniker($c) )
        ->search( $query->{WHERE}, $query->{OPTS} );
    return $rs;
}

sub count {
    my ( $self, $controller, $c, @arg ) = @_;
    my $query = shift(@arg) || $self->make_query( $controller, $c );
    return $c->model( $self->model_name )
        ->resultset( $self->_get_moniker($c) )
        ->count( $query->{WHERE}, $query->{OPTS} );
}

sub make_query {
    my $self       = shift;
    my $controller = shift;
    my $c          = shift;
    my $field_names 
        = shift
        || $c->req->params->{'cxc-query-fields'}
        || $self->_get_field_names( $controller, $c );

    my $query = $self->make_sql_query( $controller, $c, $field_names ) || {};

    # WHERE
    $query->{WHERE} = { @{ $query->{query} } };

    my %opts;

    # PREFETCH, etc.
    if ( $controller->model_meta->{resultset_opts} ) {
        %opts = %{ $controller->model_meta->{resultset_opts} };
    }

    # ORDER BY
    #dump $field_names;
    if ( exists $query->{sort_by} ) {
        $opts{order_by} ||= $query->{sort_by};

        # default is to sort by PK, which might not be prefixed.
        my $ss = Sort::SQL->parse( $opts{order_by} );

        #dump $ss;
        my @order_by;
        for my $clause (@$ss) {
            if ( $clause->[0] !~ m/\./ ) {

                if ( $c->req->params->{'cxc-m2m'} ) {

                    # TODO m2m

                }
                else {

                    # o2m
                    my $name = "me." . $clause->[0];
                    if ( grep { $_ eq $name } @$field_names ) {
                        $clause->[0] = $name;
                    }
                }
            }
            push @order_by, join( ' ', @$clause );
        }
        $opts{order_by} = join( ', ', @order_by );
    }

    #dump \%opts;
    $query->{OPTS} = \%opts;

    $c->log->debug( "query: " . dump $query ) if $c->debug;

    return $query;
}

sub make_sql_query {
    my $self        = shift;
    my $controller  = shift;
    my $c           = shift;
    my $field_names = shift;

    # Model::Utils (make_sql_query) assumes ACCEPT_CONTEXT accessor
    $self->{context} = $c;
    weaken( $self->{context} );

    my $q = $self->next::method($field_names);

    #carp "make_sql_query : " . dump $q;

    if ( $q->{query_obj} ) {
        $q->{query} = $q->{query_obj}->dbic;
    }

    #carp "make_sql_query : " . dump $q;

    return $q;
}

sub search_related {
    my ( $self, $controller, $c, $obj, $rel, $query ) = @_;
    $query ||= $self->make_query( $controller, $c );
    return [ $obj->$rel->search( $query->{WHERE}, $query->{OPTS} ) ];
}

sub iterator_related {
    my ( $self, $controller, $c, $obj, $rel, $query ) = @_;
    $query ||= $self->make_query( $controller, $c );
    return scalar $obj->$rel->search( $query->{WHERE}, $query->{OPTS} );
}

sub count_related {
    my ( $self, $controller, $c, $obj, $rel, $query ) = @_;
    $query ||= $self->make_query( $controller, $c );
    return $obj->$rel->count( $query->{WHERE}, $query->{OPTS} );
}

sub add_related {
    my ( $self, $controller, $c, $obj, $rel, $for_val ) = @_;
    my $rinfo = $self->_get_rel_meta( $controller, $c, $obj, $rel );

    #carp "add_related: " . dump $rinfo;

    if ( exists $rinfo->{m2m} ) {
        my $for_obj
            = $self->_get_m2m_foreign_object( $controller, $c, $obj, $rel,
            $rinfo, $for_val );
        my $add_method = 'add_to_' . $rinfo->{m2m}->{method_name};
        $obj->$add_method($for_obj);
    }
    else {
        croak "TODO o2m";
    }
}

sub _get_m2m_foreign_object {
    my ( $self, $controller, $c, $obj, $rel, $rinfo, $for_val ) = @_;
    if ( !exists $rinfo->{m2m} ) {
        $self->throw_error("relationship $rel is not a many-to-many");
    }

    #carp "get foreign object $for_val for $rel : " . dump $rinfo;

    my $m2m           = $rinfo->{m2m};
    my $foreign_class = $m2m->{foreign_class};
    my $fpk           = $m2m->{foreign_column};
    my $for_obj
        = $c->model( $self->model_name )->resultset($foreign_class)
        ->find( { $fpk => $for_val } )
        or $self->throw_error(
        "can't find foreign object in $foreign_class for $for_val");

    return $for_obj;
}

sub rm_related {
    my ( $self, $controller, $c, $obj, $rel, $for_val ) = @_;
    my $rinfo = $self->_get_rel_meta( $controller, $c, $obj, $rel );

    #carp dump $rinfo;
    if ( exists $rinfo->{m2m} ) {

        # isa m2m
        # must find the foreign object to pass to remove_from_$rel()
        my $for_obj
            = $self->_get_m2m_foreign_object( $controller, $c, $obj, $rel,
            $rinfo, $for_val );
        my $rm_method = 'remove_from_' . $rinfo->{m2m}->{method_name};
        $obj->$rm_method($for_obj);

    }
    else {
        croak "TODO o2m";
    }

}

sub has_relationship {
    my ( $self, $controller, $c, $obj, $rel ) = @_;
    eval { $obj->ensure_class_loaded('DBIx::Class::RDBOHelpers'); };
    if ($@) {
        $self->throw_error("DBIx::Class::RDBOHelpers not loaded for $obj");
    }

    for ( $obj->relationships ) {
        return $obj->relationship_info($_)
            if $_ eq $rel;

        # m2m relationships are not keyed by their method name
        my $info = $obj->relationship_info($_);
        if ( exists $info->{m2m} and $info->{m2m}->{method_name} eq $rel ) {
            return $info;
        }
    }
    return;
}

sub _get_rel_meta {
    my ( $self, $controller, $c, $obj, $rel ) = @_;
    if ( !$self->has_relationship( $controller, $c, $obj, $rel ) ) {
        $self->throw_error("no such relationship $rel defined for $obj");
    }
    return $self->has_relationship( $controller, $c, $obj, $rel )
        || $obj->relationship_info($rel);
}

sub _get_field_names {
    my $self       = shift;
    my $controller = shift;
    my $c          = shift;

    my $moniker = $self->_get_moniker($c);
    return $self->{_field_names}
        if exists $self->{_field_names};

    my $obj
        = $c->model( $self->model_name )->composed_schema->source($moniker);
    my @cols = $obj->columns;
    my @rels = $obj->relationships;

    my @fields;
    for my $rel (@rels) {
        my $info = $self->_get_rel_meta( $controller, $c, $obj, $rel );
        my ( $rel_class, $prefix );

        #warn "rel info for $moniker $rel: " . dump $info;
        if ( exists $info->{m2m} ) {
            $rel_class = $info->{m2m}->{foreign_class};
            $prefix    = $info->{m2m}->{map_to};
        }
        else {
            $rel_class = $info->{class};
            $prefix    = $rel;
        }
        my @rel_cols = $rel_class->columns;
        push( @fields, map { $prefix . '.' . $_ } @rel_cols );
    }
    for my $col (@cols) {
        push( @fields, 'me.' . $col );
    }

    #carp "field_names for $moniker : " . dump \@fields;

    $self->{_field_names} = \@fields;

    return \@fields;
}

sub create {
    my ( $self, $c, $object ) = @_;
    $object->insert;
}

sub read {
    my ( $self, $c, $object ) = @_;

    #$object->find;    # TODO is this right? what about discard_changes()?
    $c->log->error("TODO $object does not implement find() method");
    return $object;
}

sub update {
    my ( $self, $c, $object ) = @_;
    $object->update;
}

sub delete {
    my ( $self, $c, $object ) = @_;
    $object->delete;
}

1;