#!/usr/bin/perl
#
# $Header: /Users/claude/fuzz/lib/Genezzo/RCS/XEval.pm,v 7.4 2005/11/26 01:57:30 claude Exp claude $
#
# copyright (c) 2005 Jeffrey I Cohen, all rights reserved, worldwide
#
#
package Genezzo::XEval;
use Genezzo::Util;

use Genezzo::XEval::Prepare;
use Genezzo::XEval::SQLAlter;

use strict;
use warnings;
use warnings::register;

use Carp;

our $VERSION;

BEGIN {
    $VERSION = do { my @r = (q$Revision: 7.4 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; # must be all one line, for MakeMaker

}

our $GZERR = sub {
    my %args = (@_);

    return 
        unless (exists($args{msg}));

    if (exists($args{self}))
    {
        my $self = $args{self};
        if (defined($self) && exists($self->{GZERR}))
        {
            my $err_cb = $self->{GZERR};
            return &$err_cb(%args);
        }
    }

    my $warn = 1;
    if (exists($args{severity}))
    {
        my $sev = uc($args{severity});
        $sev = 'WARNING'
            if ($sev =~ m/warn/i);

        # don't print 'INFO' prefix
        if ($args{severity} =~ m/info/i)
        {
            printf ("%s: ", $sev);
            $warn = 0;
        }

    }
    carp $args{msg}
      if (warnings::enabled() && $warn);
    
};

sub _init
{
    my $self = shift;
    my %args = (@_);

    return 0
        unless (defined($args{plan}));

    $self->{plan} = $args{plan};
    $self->{prepare} = Genezzo::XEval::Prepare->new();
    
    return 1;
}

sub new 
{
    my $invocant = shift;
    my $class = ref($invocant) || $invocant ; 
    my $self = { };
    
    my %args = (@_);

    if ((exists($args{GZERR}))
        && (defined($args{GZERR}))
        && (length($args{GZERR})))
    {
        # NOTE: don't supply our GZERR here - will get
        # recursive failure...
        $self->{GZERR} = $args{GZERR};
        my $err_cb     = $self->{GZERR};
        # capture all standard error messages
        $Genezzo::Util::UTIL_EPRINT = 
            sub {
                &$err_cb(self     => $self,
                         severity => 'error',
                         msg      => @_); };
        
        $Genezzo::Util::WHISPER_PRINT = 
            sub {
                &$err_cb(self     => $self,
#                         severity => 'error',
                         msg      => @_); };
    }

    return undef
        unless (_init($self, %args));

    return bless $self, $class;

} # end new

# get or set the dictionary object
sub Dict
{
    my $self = shift;

    if (scalar(@_))
    {
        $self->{dictobj} = shift;
    }
    return $self->{dictobj};    
}

sub Prepare
{
    whoami;

    my $self = shift;

    my %required = (
                    plan => "no plan!"
                    );

    my %args = ( # %optional,
                @_);

    my ($msg, %earg);

    return undef
        unless (Validate(\%args, \%required));

    my $alg = $args{plan};

    return ($self->{prepare}->Prepare(plan => $alg,
                                      dict => $self->Dict()));

}

sub SQLAlter
{
    whoami;

    my $self = shift;

    my %required = (
                    plan => "no plan!"
                    );

    my %args = ( # %optional,
                @_);

    my ($msg, %earg);

    return undef
        unless (Validate(\%args, \%required));

    my $alg = $args{plan};

    return 0
        unless (exists($alg->{sql_alter}));

    if (exists($alg->{sql_alter}->{add_table_cons}))
    {
        my $add_tab_cons = $alg->{sql_alter}->{add_table_cons};

        my $tablename = $alg->{sql_alter}->{tc_table_fullname};
        
        my $cons_name;

        if (scalar(@{$add_tab_cons->{name}}))
        {
           $cons_name = 
             $add_tab_cons->{name}->[0]->[0]->{bareword};
        }

        greet $tablename, $cons_name;

        my %nargs = (
                     tname   => $tablename,
                     dbh_ctx => $args{dbh_ctx}
                     );

        if (defined($cons_name))
        {
            $nargs{cons_name} = $cons_name;
        }
        
        if (exists($add_tab_cons->{constraint}) &&
            exists($add_tab_cons->{constraint}->{cons_type}) &&
            ($add_tab_cons->{constraint}->{cons_type} 
             =~ m/check|primary|unique/i))
        {
            $nargs{cons_type} = $add_tab_cons->{constraint}->{cons_type};
        }
        else
        {
            $msg = "unknown constraint\n";
            $msg .= Data::Dumper->Dump( [%nargs]);
            %earg = (self => $self, msg => $msg,
                     severity => 'warn');
            
            &$GZERR(%earg)
                if (defined($GZERR));
            
            return 0;
        }

        if ($add_tab_cons->{constraint}->{cons_type} 
            =~ m/primary|unique/i)
        {

            # XXX XXX XXX: need to move these checks to typecheck
            my %dupi;

            # check the column list for duplicates
            for my $col (@{$add_tab_cons->{constraint}->{tc_column_list}})
            {
                if (exists($dupi{$col}))
                {
                    $msg = 'Duplicate column (' . $col . ') ';
                    $msg .= 'in constraint declaration';
                    %earg = (self => $self, msg => $msg,
                             severity => 'warn');
                    
                    &$GZERR(%earg)
                        if (defined($GZERR));
            
                    return 0;

                }
                else
                {
                    $dupi{$col} = 1;
                }
            }


            $nargs{cols} = $add_tab_cons->{constraint}->{tc_column_list};
        }
        elsif ($add_tab_cons->{constraint}->{cons_type} 
               =~ m/check/i)
        {
            my $where_clause =
                $add_tab_cons->{constraint}->{operands}->{sc_txt};
            $nargs{where_clause} = $where_clause;

            # needs to be an array to match WHERE clause
            my $where_arr = [
                $add_tab_cons->{constraint}->{operands}
                             ];

            my $where_filter = 
                $self->{plan}->SQLWhere2(tablename => $tablename,
                                         where     => $where_arr
                                         );

            unless (defined($where_filter))
            {
                $msg = "invalid where clause";
                %earg = (self => $self, msg => $msg,
                            severity => 'warn');
                    
                &$GZERR(%earg)
                    if (defined($GZERR));
                return 0;
            }
            $nargs{where_filter} = $where_filter->{filter_text};
        }

        greet %nargs;

        my ($stat, $new_consname, $new_iname) = 
            $self->{dictobj}->DictTableAddConstraint(%nargs);
        
        my $severity;
        if ($stat)
        {
            $cons_name = $new_consname
                unless (defined($cons_name));
            $msg = "Added constraint $cons_name" .
                " to table $tablename\n";
            $severity = 'info';
        }
        else
        {
            $msg = "Failed to add constraint\n";
            $severity = 'warn';
        }
        %earg = (self => $self, msg => $msg,
                 severity => $severity);
        
        &$GZERR(%earg)
            if (defined($GZERR));
        
        return $stat;
        
    } # end alter table constraint
    
    $msg = "cannot execute ALTER command";
    %earg = (self => $self, msg => $msg,
             severity => 'warn');
                    
    &$GZERR(%earg)
        if (defined($GZERR));

    return 0;
} # end SQLAlter

sub SQLInsert
{
    whoami;

    my $self = shift;

    my %required = (
                    plan => "no plan!"
                    );

    my %args = ( # %optional,
                @_);

    my ($msg, %earg);

    return undef
        unless (Validate(\%args, \%required));

    my $alg = $args{plan};

    unless (exists($alg->{sql_insert}) &&
            exists($alg->{sql_insert}->[1]->{insert_values}))
    {
        $msg = "cannot execute INSERT command";
        %earg = (self => $self, msg => $msg,
                 severity => 'warn');
        
        &$GZERR(%earg)
            if (defined($GZERR));
        
        return undef;
    }
    
    if (exists($alg->{sql_insert}->[0]->{insert_tabinfo}->{tc_column_list}))
    {
        my $tabinfo = $alg->{sql_insert}->[0]->{insert_tabinfo};


        # XXX XXX XXX: need to move these checks to typecheck
        my %dupi;

        # check the column list for duplicates
        for my $col (@{$tabinfo->{tc_column_list}})
        {
            if (exists($dupi{$col}))
            {
                $msg = 'Duplicate column (' . $col . ') ';
                $msg .= 'in INSERT';
                %earg = (self => $self, msg => $msg,
                         severity => 'warn');
                
                &$GZERR(%earg)
                    if (defined($GZERR));
            
                return undef;

            }
            else
            {
                unless (exists($tabinfo->{tc_table_colhsh}->{$col}))
                {
                    $msg =  'No such column ('. $col . ') ';
                    $msg .= 'in table ' . $tabinfo->{tc_table_fullname};
                    $msg .= ' for INSERT';
                    %earg = (self => $self, msg => $msg,
                             severity => 'warn');
                    
                    &$GZERR(%earg)
                        if (defined($GZERR));
            
                    return undef;

                }

                $dupi{$col} = 1;
            }
        }
    }

    # standard INSERT into ... VALUES ...
    if (ref($alg->{sql_insert}->[1]->{insert_values}) eq 'ARRAY')
    {
        my $tabinfo = $alg->{sql_insert}->[0]->{insert_tabinfo};

        use Genezzo::Row::RSExpr;
        use Genezzo::Row::RSDual;

        my @sel_list;
        
        for my $val (@{$alg->{sql_insert}->[1]->{insert_values}})
        {
            push @sel_list, { value_expression => $val};
        }
        greet @sel_list;
        
        my %tempo;
        my $rsd_tv = tie %tempo, 'Genezzo::Row::RSDual';
        
        my %nargs = (
                     GZERR       => $self->{GZERR},
                     rs          => $rsd_tv,
                     select_list => \@sel_list,
                     # NOTE: alias is now a required argument for
                     # RSExpr, even though the DUAL rowsource cannot
                     # have name column expressions.
                     alias       => $tabinfo->{tc_table_fullname}
                     );
        my %rsx_h;
        my $rsx_tv = tie %rsx_h, 'Genezzo::Row::RSExpr', %nargs;
        
        my $sth = $rsx_tv->SQLPrepare();
        
        return ("vanilla", $sth);

    }
    elsif (ref($alg->{sql_insert}->[1]->{insert_values}) eq 'HASH')
    {
        my %q1 = (
                  orderby_clause => [],
                  sql_query      =>  $alg->{sql_insert}->[1]->{insert_values}
                  );
        return ("insert select", \%q1);
    }

    $msg = "cannot execute INSERT command";
    %earg = (self => $self, msg => $msg,
             severity => 'warn');
    
    &$GZERR(%earg)
        if (defined($GZERR));
    
    return undef;
} # end SQLInsert

END { }       # module clean-up code here (global destructor)

## YOUR CODE GOES HERE

1;  # don't forget to return a true value from the file

__END__
# Below is stub documentation for your module. You better edit it!

=head1 NAME

Genezzo::XEval - Execution and Expression Evaluation

=head1 SYNOPSIS

use Genezzo::XEval;


=head1 DESCRIPTION

Perform expression evaluation and command execution.

=head1 ARGUMENTS

=head1 FUNCTIONS

=over 4

=item Dict

get or set the dictionary object

=item SQLAlter

entry point for SQL Alter commands, e.g. ALTER TABLE 

=item SQLInsert

Execute SQL INSERT

=back

=head2 EXPORT

=over 4


=back


=head1 LIMITATIONS


=head1 TODO

=over 4

=item Should become more of a dispatch routine, with major guts for
each function stashed in separate modules under XEval.

=item SQLAlter, SQLInsert: move type checking to TypeCheck module.

=back

=head1 AUTHOR

Jeffrey I. Cohen, jcohen@genezzo.com

=head1 SEE ALSO

L<perl(1)>.

Copyright (c) 2005 Jeffrey I Cohen.  All rights reserved.

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA

Address bug reports and comments to: jcohen@genezzo.com

For more information, please visit the Genezzo homepage 
at L<http://www.genezzo.com>

=cut
