package CatalystX::CRUD::Model::RDBO;
use strict;
use warnings;
use base qw( CatalystX::CRUD::Model CatalystX::CRUD::Model::Utils );
use CatalystX::CRUD::Iterator;
use MRO::Compat;
use mro 'c3';
use Carp;
use Data::Dump qw( dump );

our $VERSION = '0.22';

__PACKAGE__->mk_ro_accessors(
    qw( name manager treat_like_int load_with related_load_with ));
__PACKAGE__->config( object_class => 'CatalystX::CRUD::Object::RDBO' );

=head1 NAME

CatalystX::CRUD::Model::RDBO - Rose::DB::Object CRUD

=head1 SYNOPSIS

 package MyApp::Model::Foo;
 use base qw( CatalystX::CRUD::Model::RDBO );
 __PACKAGE__->config( 
            name                => 'My::RDBO::Foo', 
            manager             => 'My::RDBO::Foo::Manager',
            load_with           => [qw( bar )],
            related_load_with   => {
                bars => ['doof']
            },
            page_size           => 50,
            );
 1;

=head1 DESCRIPTION

CatalystX::CRUD::Model::RDBO is a CatalystX::CRUD implementation for Rose::DB::Object.

=head1 CONFIGURATION

The config options can be set as in the SYNOPSIS example.

=head1 METHODS

=head2 name

The name of the Rose::DB::Object-based class that the model represents.
Accessible via name() or config->{name}.

=head2 manager

If C<manager> is not defined in config(),
the Xsetup() method will attempt to load a class
named with the C<name> value from config() 
with C<::Manager> appended.
This assumes the namespace convention of Rose::DB::Object::Manager.

If there is no such module in your @INC path, then
the fall-back default is Rose::DB::Object::Manager.

=head2 load_with

The value of C<load_with> should be an array ref of relationship
names. The array ref is passed into all the Manager
get_objects* methods as the C<with_objects> value.

=head2 related_load_with

Similar to C<load_with>, but the C<with_objects> argument is passed
in all the *_related methods. The C<related_load_with> value should
be a hash ref with keys using relationships names and the values
being array refs of relationship names in the foreign (related) classes.

=cut

=head2 Xsetup

Implements the required Xsetup() method. Instatiates the model's
name() and manager() values based on config().

=cut

sub Xsetup {
    my $self = shift;

    $self->next::method(@_);

    $self->{name} = $self->config->{name};
    if ( !$self->name ) {
        return if $self->throw_error("need to configure a Rose class name");
    }

    $self->{manager} = $self->config->{manager} || $self->name . '::Manager';

    my $name = $self->name;
    my $mgr  = $self->manager;

    eval "require $name";
    if ($@) {
        return if $self->throw_error($@);
    }

    # what kind of db driver are we using. makes a difference in make_query().
    my $db = $name->new->db;
    $self->use_ilike(1) if $db->driver eq 'pg';

    # rdbo sql uses 'ne' for not equal
    $self->ne_sign('ne');

    # cache the treat_like_int hash
    $self->_treat_like_int;

    # load the Manager
    eval "require $mgr";

    # don't fret -- just use RDBO::Manager
    if ($@) {
        $self->{manager} = 'Rose::DB::Object::Manager';
        require Rose::DB::Object::Manager;
    }

    # turn on debugging help
    if ( $ENV{CATALYST_DEBUG} && $ENV{CATALYST_DEBUG} > 1 ) {
        $Rose::DB::Object::QueryBuilder::Debug = 1;
        $Rose::DB::Object::Debug               = 1;
        $Rose::DB::Object::Manager::Debug      = 1;
    }

}

=head2 new_object( @param )

Returns a CatalystX::CRUD::Object::RDBO object.

=cut

sub new_object {
    my $self = shift;
    my $rdbo = $self->name;
    my $obj;
    eval { $obj = $rdbo->new(@_) };
    if ( $@ or !$obj ) {
        my $err = defined($obj) ? $obj->error : $@;
        return if $self->throw_error("can't create new $rdbo object: $err");
    }
    return $self->next::method( delegate => $obj );
}

=head2 fetch( @params )

If present,
@I<params> is passed directly to name()'s new() method,
and is expected to be an array of key/value pairs.
Then the load() method is called on the resulting object.

If @I<params> are not present, the new() object is simply returned,
which is equivalent to calling new_object().

All the methods called within fetch() are wrapped in an eval()
and sanity checked afterwards. If there are any errors,
throw_error() is called.

Example:

 my $foo = $c->model('Foo')->fetch( id => 1234 );
 if (@{ $c->error })
 {
    # do something to deal with the error
 }
 
B<NOTE:> If the object's presence in the database is questionable,
your controller code may want to use new_object() and then call 
load_speculative() yourself. Example:

 my $foo = $c->model('Foo')->new_object( id => 1234 );
 $foo->load_speculative;
 if ($foo->not_found)
 {
   # do something
 }

=cut

sub fetch {
    my $self = shift;
    my $obj = $self->new_object(@_) or return;

    if (@_) {
        my %v = @_;
        my $ret;
        my $name = $self->name;
        my @arg  = ();
        eval { $ret = $obj->read(@arg); };
        if ( $@ or !$ret ) {
            return
                if $self->throw_error( join( " : ", $@, "no such $name" ) );
        }

        # special handling of fetching
        # e.g. Catalyst::Plugin::Session::Store::DBI records.
        if ( $v{id} ) {

            # stringify in case it's a char instead of int
            # as is the case with session ids
            my $pid = $obj->delegate->id;
            $pid =~ s,\s+$,,;
            unless ( $pid eq $v{id} ) {

                return
                    if $self->throw_error(
                          "Error fetching correct id:\nfetched: $v{id} "
                        . length( $v{id} )
                        . "\nbut got: $pid"
                        . length($pid) );
            }
        }
    }

    return $obj;
}

=head2 search( @params )

@I<params> is passed directly to the Manager get_objects() method.
See the Rose::DB::Object::Manager documentation.

Returns an array or array ref (based on wantarray) of 
CatalystX::CRUD::Object::RDBO objects.

=cut

sub search {
    my $self = shift;
    my $objs = $self->_get_objects( 'get_objects', @_ );

    # save ourselves lots of method-call overhead.
    my $class = $self->object_class;

    my @wrapped = map { $class->new( delegate => $_ ) } @$objs;
    return wantarray ? @wrapped : \@wrapped;
}

=head2 count( @params )

@I<params> is passed directly to the Manager get_objects_count() method.
See the Rose::DB::Object::Manager documentation.

Returns an integer.

=cut

sub count {
    my $self = shift;
    return $self->_get_objects( 'get_objects_count', @_ );
}

=head2 iterator( @params )

@I<params> is passed directly to the Manager get_objects_iterator() method.
See the Rose::DB::Object::Manager documentation.

Returns a CatalystX::CRUD::Iterator object whose next() method
will return a CatalystX::CRUD::Object::RDBO object.

=cut

sub iterator {
    my $self = shift;
    my $iter = $self->_get_objects( 'get_objects_iterator', @_ );
    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 _related_query {
    my ( $self, $obj, $rel_name ) = @_;
    my $relationship = $self->has_relationship( $obj, $rel_name )
        or $self->throw_error("no relationship for $rel_name");

    # set the param so sort is correctly mangled in make_query()
    if ($relationship->isa(
            'Rose::DB::Object::Metadata::Relationship::ManyToMany')
        )
    {
        $self->context->req->params->{'cxc-m2m'} = 1;
    }
    my $query = $self->make_query;
    my @arg;
    if ( @{ $query->{query} } ) {
        @arg = ( query => $query->{query} );
    }
    for (qw( limit offset sort_by )) {
        if ( exists $query->{$_} and length $query->{$_} ) {
            push( @arg, $_ => $query->{$_} );
        }
    }
    if ( $self->related_load_with
        && exists $self->related_load_with->{$rel_name} )
    {
        push(
            @arg,
            with_objects  => $self->related_load_with->{$rel_name},
            multi_many_ok => 1
        );
    }

    #warn dump \@arg;
    return @arg;
}

sub search_related {
    my ( $self, $obj, $rel ) = @_;
    return $obj->$rel( $self->_related_query( $obj, $rel ) );
}

sub iterator_related {
    my ( $self, $obj, $rel ) = @_;
    my $method = $rel . '_iterator';
    return $obj->$method( $self->_related_query( $obj, $rel ) );
}

sub count_related {
    my ( $self, $obj, $rel ) = @_;
    my $method = $rel . '_count';
    return $obj->$method( $self->_related_query( $obj, $rel ) );
}

=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 = $self->has_relationship( $obj, $rel_name )
        or $self->throw_error("no such relationship $rel_name");

    if ( $rel->isa('Rose::DB::Object::Metadata::Relationship::ManyToMany') ) {

        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;

    }
    else {
        $self->throw_error( "unsupport relationship type: " . ref($rel) );
    }
}

=head2 has_relationship( I<obj>, I<rel_name> )

Returns the Rose::DB::Object::Metadata::Relationship instance
for I<rel_name> if it exists, or undef if it does not.

=cut

sub has_relationship {
    my ( $self, $obj, $rel_name ) = @_;
    return $obj->delegate->meta->relationship($rel_name);
}

sub add_related {
    my ( $self, $obj, $rel_name, $fk_val ) = @_;
    my $addmethod = 'add_' . $rel_name;
    my $meta      = $self->_get_rel_meta( $obj, $rel_name );
    my $fpk       = $meta->{map_to}->[1];
    $obj->$addmethod( { $fpk => $fk_val } );
    $obj->save;

    # so next access reflects change.
    $obj->forget_related($rel_name);
}

sub rm_related {
    my ( $self, $obj, $rel_name, $fk_val ) = @_;

    my $meta = $self->_get_rel_meta( $obj, $rel_name );
    my $obj_method = $obj->delegate->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,
    );

    # so next access reflects change
    $obj->forget_related($rel_name);
    return $obj;
}

=head2 make_query( I<field_names> )

Implement a RDBO-specific query factory based on request parameters.
Return value can be passed directly to search(), iterator() or count() as
documented in the CatalystX::CRUD::Model API.

See CatalystX::CRUD::Model::Utils::make_sql_query() for API details.

=cut

sub _get_field_names {
    my $self = shift;
    return $self->{_field_names} if $self->{_field_names};
    my @cols = $self->name->meta->column_names;
    $self->{_field_names} = \@cols;
    return \@cols;
}

=head2 treat_like_int

Returns hash ref of all column names that return type =~ m/^date(time)$/.
This is so that wildcard searches for date and datetime-based columns
will get proper SQL rendering.

=cut

sub _treat_like_int {
    my $self = shift;
    return $self->{treat_like_int} if $self->{treat_like_int};
    $self->{treat_like_int} = {};
    my $col_names = $self->_get_field_names;

    # treat wildcard timestamps like ints not text (>= instead of ILIKE)
    for my $name (@$col_names) {
        my $col = $self->name->meta->column($name);
        if ( $col->type =~ m/date|time|boolean|int/ ) {
            $self->{treat_like_int}->{$name} = 1;
        }
    }

    return $self->{treat_like_int};
}

sub _join_with_table_prefix {
    my ( $self, $q, $prefix ) = @_;
    return join( ', ',
        map     { $prefix . '.' . $_->[0] . ' ' . $_->[1] }
            map { [%$_] } @{ $q->{sort_order} } );
}

sub make_query {
    my $self        = shift;
    my $c           = $self->context;
    my $field_names = shift || $self->_get_field_names;
    my $q           = $self->make_sql_query($field_names);

    # many2many relationships always have two tables,
    # and we are sorting my the 2nd one. The 1st one is the mapper.
    # however, we leave sort_by alone if it already has . in it,
    # since then we assume the request knew enough to ask.
    if ( length( $q->{sort_by} ) && !( $q->{sort_by} =~ m/\./ ) ) {
        if ( $c->req->params->{'cxc-m2m'} ) {
            if ( !( $q->{sort_by} =~ m/t\d\./ ) ) {
                $q->{sort_by} = $self->_join_with_table_prefix( $q, 't2' );
            }
        }
        else {
            if ( !( $q->{sort_by} =~ m/t\d\./ ) ) {
                $q->{sort_by} = $self->_join_with_table_prefix( $q, 't1' );
            }
        }
    }

    $c->log->debug("make_query: WHERE $q->{query_obj} ORDER BY $q->{sort_by}")
        if $c->debug;

    return $q;
}

sub _get_objects {
    my $self    = shift;
    my $method  = shift || 'get_objects';
    my @args    = @_;
    my $manager = $self->manager;
    my $name    = $self->name;
    my @params  = ( object_class => $name );    # not $self->object_class

    if ( ref $args[0] eq 'HASH' ) {
        push( @params, %{ $args[0] } );
    }
    elsif ( ref $args[0] eq 'ARRAY' ) {
        push( @params, @{ $args[0] } );
    }
    else {
        push( @params, @args );
    }

    push(
        @params,
        with_objects  => $self->load_with,
        multi_many_ok => 1
    ) if $self->load_with;

    return $manager->$method(@params);
}

1;

__END__

=head1 AUTHOR

Peter Karman, C<< <karman at cpan.org> >>

=head1 BUGS

Please report any bugs or feature requests to
C<bug-catalystx-crud-model-rdbo at rt.cpan.org>, or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CatalystX-CRUD-Model-RDBO>.
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc CatalystX::CRUD::Model::RDBO

You can also look for information at:

=over 4

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/CatalystX-CRUD-Model-RDBO>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/CatalystX-CRUD-Model-RDBO>

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=CatalystX-CRUD-Model-RDBO>

=item * Search CPAN

L<http://search.cpan.org/dist/CatalystX-CRUD-Model-RDBO>

=back

=head1 ACKNOWLEDGEMENTS

This module is based on Catalyst::Model::RDBO by the same author.

=head1 COPYRIGHT & LICENSE

Copyright 2007 Peter Karman, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut