Genezzo::XEval - Execution and Expression Evaluation

Genezzo documentation Contained in the Genezzo distribution.

Index

Code Index:

NAME

Top

Genezzo::XEval - Execution and Expression Evaluation

SYNOPSIS

Top

use Genezzo::XEval;

DESCRIPTION

Top

Perform expression evaluation and command execution.

ARGUMENTS

Top

FUNCTIONS

Top

Dict

get or set the dictionary object

SQLAlter

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

SQLInsert

Execute SQL INSERT

EXPORT

LIMITATIONS

Top

TODO

Top

Should become more of a dispatch routine, with major guts for each function stashed in separate modules under XEval.
SQLAlter, SQLInsert: move type checking to TypeCheck module.

AUTHOR

Top

Jeffrey I. Cohen, jcohen@genezzo.com

SEE ALSO

Top

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 http://www.genezzo.com

Genezzo documentation Contained in the Genezzo distribution. 
#!/usr/bin/perl
#
# $Header: /Users/claude/fuzz/lib/Genezzo/RCS/XEval.pm,v 7.5 2006/03/30 07:21:36 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.5 $ =~ /\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!",
                    dict => "no dictionary!",
                    magic_dbh => "no dbh!"
                    );

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

    my ($msg, %earg);

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

    my $alg     = $args{plan};
    my $dictobj = $args{dict};
    my $dbh     = $args{magic_dbh};

    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},
                     dict        => $dictobj,
                     magic_dbh   => $dbh,
                     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!