package SPOPS::ClassFactory::DBI;

# $Id: DBI.pm,v 3.10 2004/02/23 05:28:29 lachoy Exp $

use strict;
use Log::Log4perl qw( get_logger );
use SPOPS;
use SPOPS::ClassFactory qw( OK ERROR DONE );

my $log = get_logger();

$SPOPS::ClassFactory::DBI::VERSION  = sprintf("%d.%02d", q$Revision: 3.10 $ =~ /(\d+)\.(\d+)/);

# NOTE: The behavior is installed in SPOPS::DBI


########################################
# MULTIPLE FIELD KEYS
########################################

my $generic_multifield_id = <<'MFID';

    sub %%GEN_CLASS%%::id {
        my ( $self, $id ) = @_;
        if ( $id ) {
	        ( %%ID_FIELD_OBJECT_LIST%% )  = split /\s*,\s*/, $id;
	    }
        return wantarray ? ( %%ID_FIELD_OBJECT_LIST%% )
                         : join( ',', %%ID_FIELD_OBJECT_LIST%% );
    }
MFID


# Generate an ID method for classes that have multiple-field primary
# keys

sub conf_multi_field_key_id {
    my ( $class ) = @_;
    my $CONFIG = $class->CONFIG;
    my $id_field = $CONFIG->{id_field};

    return ( OK, undef ) unless ( ref $id_field eq 'ARRAY' );
    if ( scalar @{ $id_field } == 1 ) {
        $CONFIG->{id_field} = $id_field->[0];
        return ( OK, undef );
    }

    my $id_object_reference = join( ', ',
                                    map { '$self->{' . $_ . '}' }
                                        @{ $id_field } );
    my $id_sub = $generic_multifield_id;
    $id_sub =~ s/%%GEN_CLASS%%/$class/g;
    $id_sub =~ s/%%ID_FIELD_OBJECT_LIST%%/$id_object_reference/g;
    $log->is_debug &&
        $log->debug( "Evaluation method 'id' for class [$class]\n$id_sub" );
    {
        local $SIG{__WARN__} = sub { return undef };
        eval $id_sub;
        if ( $@ ) {
            warn "Code: $id_sub\n";
            return ( ERROR, "Cannot create multifield 'id()' method for " .
                            "class [$class]: $@" );
        }
    }
    return ( DONE, undef );
}


# TODO: The explicit 'SPOPS::DBI' method below works, but it ignores
# anything in ISA between $class and it that might define-and-forward
# (or override) fetch().

my $generic_multifield_etc = <<'MFETC';

    sub %%GEN_CLASS%%::fetch {
        my ( $class, $id, @params ) = @_;
        my $id_string = ( ref $id eq 'ARRAY' )
                          ? join( ',', @{ $id } ) : $id;
        return $class->SPOPS::DBI::fetch( $id_string, @params );
    }

    sub %%GEN_CLASS%%::clone {
        my ( $self, $p ) = @_;
        my $class = $p->{_class} || ref $self;
        $log->is_info &&
            $log->info( "Cloning new object of class ($class) from old ",
                          "object of class (", ref $self, ")" );
        my %initial_data = ();

        my %id_field = map { $_ => 1 } $class->id_field;

        while ( my ( $k, $v ) = each %{ $self } ) {
            next unless ( $k );
            next if ( $id_field{ $k } );
            $initial_data{ $k } = $p->{ $k } || $v;
        }

        my $cloned = $class->new({ %initial_data, skip_default_values => 1 });
        if ( $p->{id} ) {
            $cloned->id( $p->{id} );
        }
        else {
            foreach my $field ( keys %id_field ) {
                $cloned->{ $field } = $p->{ $field } if ( $p->{ $field } );
            }
        }
        return $cloned;
    }

    sub %%GEN_CLASS%%::id_field {
        return wantarray ? %%ID_FIELD_NAME_LIST%%
                         : join( ',', %%ID_FIELD_NAME_LIST%% );
    }

    sub %%GEN_CLASS%%::id_clause {
        my ( $self, $id, $opt, $p ) = @_;
        $opt ||= '';
        $p   ||= {};
        my %val = ();
        my $db = $p->{db} || $self->global_datasource_handle( $p->{connect_key} );
        unless ( $db ) {
            SPOPS::Exception->throw( "Cannot create ID clause: no DB handle available" );
        }

        # let any errors bubble up
        my $type_info = $self->db_discover_types(
                                        $self->table_name,
                                        { dbi_type_info => $p->{dbi_type_info},
                                          db            => $db,
                                          DEBUG         => $p->{DEBUG} } );
        if ( $id and ref $id eq 'ARRAY' ) {
            ( %%ID_FIELD_VARIABLE_LIST%% ) = @{ $id };
        }
        elsif ( $id ) {
      	    ( %%ID_FIELD_VARIABLE_LIST%% ) = split /\s*,\s*/, $id;
        }
        else {
    	    ( %%ID_FIELD_VARIABLE_LIST%% ) = ( %%ID_FIELD_OBJECT_LIST%% );
        }
        unless ( %%ID_FIELD_BOOLEAN_LIST%% ) {
	        SPOPS::Exception->throw( "Insufficient values for ID (%%ID_FIELD_VARIABLE_LIST%%)" );
        }
    	my @clause     = ();
    	my $table_name = $self->table_name;
    	foreach my $id_field ( %%ID_FIELD_NAME_LIST%% ) {
            my $use_id_field = ( $opt eq 'noqualify' )
                                 ? $id_field
                                 : join( '.', $table_name, $id_field );
            my $quoted_value = $self->sql_quote( $val{ $id_field },
                                                 $type_info->get_type( $id_field ),
                                                 $db );
    	    push @clause, join( ' = ', $use_id_field, $quoted_value );
	    }
        return join( ' AND ', @clause );
    }

    # should return something like:
    # ( 'mytable.id1', 'mytable.id2' )
    sub %%GEN_CLASS%%::id_field_select {
        my ( $class, $p ) = @_;
        return ( $p->{noqualify} )
                 ? %%ID_FIELD_NAME_LIST%%
                 : map { join( '.', $class->table_name, $_ ) } %%ID_FIELD_NAME_LIST%%;
    }

MFETC


sub conf_multi_field_key_other {
    my ( $class ) = @_;
    my $CONFIG = $class->CONFIG;
    my $id_field = $CONFIG->{id_field};

    return ( OK, undef ) unless ( ref $id_field eq 'ARRAY' );
    if ( scalar @{ $id_field } == 1 ) {
        $CONFIG->{id_field} = $id_field->[0];
        return ( OK, undef );
    }

    my $id_object_reference    = join( ', ',
				       map { '$self->{' . $_ . '}' }
				           @{ $id_field } );
    my $id_variable_reference  = join( ', ', map { "\$val{$_}" } @{ $id_field } );
    my $id_boolean_reference   = join( ' and ', map { "\$val{$_}" } @{ $id_field } );
    my $id_field_reference     = 'qw( ' . join( ' ', @{ $id_field } ) . ' )';
    my $other_sub = $generic_multifield_etc;
    $other_sub =~ s/%%GEN_CLASS%%/$class/g;
    $other_sub =~ s/%%ID_FIELD_OBJECT_LIST%%/$id_object_reference/g;
    $other_sub =~ s/%%ID_FIELD_VARIABLE_LIST%%/$id_variable_reference/g;
    $other_sub =~ s/%%ID_FIELD_BOOLEAN_LIST%%/$id_boolean_reference/g;
    $other_sub =~ s/%%ID_FIELD_NAME_LIST%%/$id_field_reference/g;
    $log->is_debug &&
        $log->debug( "Evaluating other multifield key methods:\n$other_sub" );
    {
        local $SIG{__WARN__} = sub { return undef };
        eval $other_sub;
        if ( $@ ) {
            return ( ERROR, "Cannot create multifield key 'clone()', " .
                            "'id_field(), 'id_clause()', and " .
                            "'id_field_select()' methods for [$class]. " .
                            "Error: $@" );
        }
    }
    return ( OK, undef );
}


########################################
# links_to
########################################

# EVAL'D SUBROUTINES
#
# This is the routine we'll be putting in the namespace of all the
# classes that have asked to be linked to other classes; obviously,
# the items marked like this: %%KEY%% will be replaced before the eval
# is done.

my $generic_linksto = <<'LINKSTO';

    sub %%GEN_CLASS%%::%%LINKSTO_ALIAS%% {
        my ( $self, $p ) = @_;
        my $log = Log::Log4perl::get_logger();
        $p ||= {};
        $p->{select} = [ '%%LINKSTO_ID_FIELD%%' ];
        $p->{from}   = [ '%%LINKSTO_TABLE%%' ];
        my $id_clause = $self->id_clause( $self->id, 'noqualify', $p );
        $p->{where}  = ( $p->{where} )
                         ? join ( ' AND ', $p->{where}, $id_clause ) : $id_clause;
        $p->{return} = 'list';
        $p->{db}   ||= %%LINKSTO_CLASS%%->global_datasource_handle;
        my $rows = %%LINKSTO_CLASS%%->db_select( $p );
        my @obj = ();
        foreach my $info ( @{ $rows } ) {
            my $item = eval { %%LINKSTO_CLASS%%->fetch( $info->[0], $p ) };
            if ( $@ ) {
                $log->error( " Cannot fetch linked object %%LINKSTO_CLASS%% [$info->[0]] ",
                             "from %%GEN_CLASS%%: $@\nContinuing with others..." );
                next;
            }
            push @obj, $item if ( $item );
        }
        return \@obj;
    }

    sub %%GEN_CLASS%%::%%LINKSTO_ALIAS%%_add {
        my ( $self, $link_id_list, $p ) = @_;
        return 0 unless ( defined $link_id_list );
        my $log = Log::Log4perl::get_logger();

        $p ||= {};

        # Allow user to pass only one ID to add (scalar) or an
        # arrayref (ref)

        $link_id_list = ( ref $link_id_list eq 'ARRAY' )
                          ? $link_id_list : [ $link_id_list ];
        my $added = 0;
        $p->{db} ||= %%LINKSTO_CLASS%%->global_datasource_handle;
        foreach my $link_item ( @{ $link_id_list } ) {
            my $link_id = ( ref $link_item ) ? $link_item->id : $link_item;
            $log->is_info &&
                $log->info( "Trying to add link to ID [$link_id]" );
            %%LINKSTO_CLASS%%->db_insert({ table => '%%LINKSTO_TABLE%%',
                                           field => [ '%%ID_FIELD%%', '%%LINKSTO_ID_FIELD%%' ],
                                           value => [ $self->{%%ID_FIELD%%}, $link_id ],
                                           db    => $p->{db},
                                           DEBUG => $p->{DEBUG} });
            $added++;
        }
        return $added;
    }

    sub %%GEN_CLASS%%::%%LINKSTO_ALIAS%%_remove {
        my ( $self, $link_id_list, $p ) = @_;
        $p ||= {};
        my $log = Log::Log4perl::get_logger();

        # Allow user to pass only one ID to remove (scalar) or an
        # arrayref (ref)

        $link_id_list = ( ref $link_id_list eq 'ARRAY' )
                          ? $link_id_list : [ $link_id_list ];
        my $removed = 0;
        $p->{db} ||= %%LINKSTO_CLASS%%->global_datasource_handle;
        foreach my $link_item ( @{ $link_id_list } ) {
            my $link_id = ( ref $link_item ) ? $link_item->id : $link_item;
            $log->is_info &&
                $log->info( "Trying to remove link to ID ($link_id)" );
            my $from_id_clause = $self->id_clause( undef, 'noqualify', $p  );
            my $to_id_clause   = %%LINKSTO_CLASS%%->id_clause( $link_id, 'noqualify', $p );
            %%LINKSTO_CLASS%%->db_delete({ table => '%%LINKSTO_TABLE%%',
                                           where => join( ' AND ', $from_id_clause, $to_id_clause ),
                                           db    => $p->{db},
                                           DEBUG => $p->{DEBUG} });
            $removed++;
        }
        return $removed;
    }

LINKSTO


#
# ACTUAL SUBROUTINE
#

sub conf_relate_links_to {
    my ( $class ) = @_;
    my $config = $class->CONFIG;
    $log->is_info &&
        $log->info( "Adding DBI relationships for: ($class)" );

    # Grab the information for the class we're modifying

    my $this_id_field = $config->{id_field};
    my $this_alias    = $config->{main_alias};

    # Process the 'links_to' aliases -- pretty straightforward (see pod)

    if ( my $links_to = $config->{links_to} ) {
        while ( my ( $to_class, $link_info ) = each %{ $links_to } ) {

            # Since the class specified can be a subclass of what's
            # generated, ensure that it's available

            eval "require $to_class";
            my $require_error = $@;
            my $to_config = eval { $to_class->CONFIG };
            if ( $@ ) {
                return ( ERROR, "Failed to retrieve configuration from " .
                                "'$to_class': $@. (Require error: $require_error)" );
            }

            my ( $to_alias, $to_id_field, $link_table, $from_id_field );

            # If the linking information is a hashref then give the
            # user the opportunity to define everything

            if ( ref( $link_info ) eq 'HASH' ) {
                $link_table    = $link_info->{table};
                $to_alias      = $link_info->{alias}
                                 || $to_config->{main_alias};
                $to_id_field   = $link_info->{to_id_field}
                                 || $to_config->{id_field};
                $from_id_field = $link_info->{from_id_field}
                                 || $this_id_field;
            }

            # Otherwise, if the value is a simple scalar then it names
            # the table

            else {
                $link_table     = $link_info;
                $to_alias       = $to_config->{main_alias};
                $to_id_field    = $to_config->{id_field};
                $from_id_field  = $this_id_field;
            }

            my $link_subs = $generic_linksto;
            $link_subs =~ s/%%ID_FIELD%%/$this_id_field/g;
            $link_subs =~ s/%%GEN_CLASS%%/$class/g;
            $link_subs =~ s/%%LINKSTO_CLASS%%/$to_class/g;
            $link_subs =~ s/%%LINKSTO_ALIAS%%/$to_alias/g;
            $link_subs =~ s/%%LINKSTO_ID_FIELD%%/$to_id_field/g;
            $link_subs =~ s/%%LINKSTO_TABLE%%/$link_table/g;
            $log->is_debug &&
                $log->debug( "Trying to create links_to routines from ",
                              "[$class: $from_id_field] to ",
                              "[$to_class: $to_id_field] using ",
                              "table [$link_table]" );
            $log->is_debug &&
                $log->debug( "Now going to eval the routine:\n$link_subs" );
            {
                local $SIG{__WARN__} = sub { return undef };
                eval $link_subs;
                if ( $@ ) {
                    return ( ERROR, "Cannot create 'links_to' methods for " .
                                    "class [$class] linking to class " .
                                    "[$to_class] via table [$link_table]. " .
                                    "Error: $@" );
                }
            }
        }
    }
    $log->is_info &&
        $log->info( "Finished adding DBI relationships for ($class)" );
    return ( OK, undef );
}

1;

__END__

=pod

=head1 NAME

SPOPS::ClassFactory::DBI - Define additional configuration methods

=head1 SYNOPSIS

 # Put SPOPS::DBI in your isa
 my $config = {
       class => 'My::SPOPS',
       isa   => [ 'SPOPS::DBI::Pg', 'SPOPS::DBI' ],
 };

=head1 DESCRIPTION

This class implements a behavior for the 'links_to' slot as described
in L<SPOPS::ClassFactory|SPOPS::ClassFactory>.

It is possible -- and perhaps desirable for the sake of clarity -- to
create a method within I<SPOPS::DBI> that does all the work that this
behavior does, then we would only need to create a subroutine that
calls that subroutine.

However, creating routines with the values embedded directly in them
should be quicker and more efficient. So we will try it this way.

=head1 METHODS

Note: Even though the first parameter for all behaviors is C<$class>,
they are not class methods. The parameter refers to the class into
which the behaviors will be installed.

B<conf_relate_links_to( $class )>

Slot: links_to

Get the config for C<$class> and find the 'links_to' configuration
information. If defined, we auto-generate subroutines to implement the
linking functionality.

Please see
L<SPOPS::Manual::Relationships|SPOPS::Manual::Relationships> for how
to configure this and examples of usage.

=head1 TO DO

B<Make 'links_to' more flexible>

We need to account for different types of linking; this may require an
additional field beyond 'links_to' that has a similar effect but works
differently.

For instance, Table-B might have a 'has_a' relationship with Table-A,
but Table-A might have a 'links_to' relationship with Table-B. (Themes
in OpenInteract work like this.) We need to be able to specify that
when Table-A severs its relationship with one or more objects from
Table-B, the actual B<object> is removed rather than just a link
between them.

=head1 BUGS

None known.

=head1 COPYRIGHT

Copyright (c) 2001-2002 intes.net, inc.. All rights reserved.

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

=head1 AUTHORS

Chris Winters  E<lt>chris@cwinters.comE<gt>

See the L<SPOPS|SPOPS> module for the full author list.

=cut
