vdw/trunk/Obj_Srvr.pm

package Obj_Srvr;

# ===========================================================================
#  Obj_Srvr.pm
#
#  Serves live high-level data from a low level DB, using code instead of a
#  Data Warehouse.  Will run embedded in obj_srvr sql parser.  obj_srvr
#  passes the parsed sql to sub get_data() in Obj_Srvr.pm, which returns
#  the data in delimited character format.  This data may be passed to
#  oracle_obj_srvr.pl which translates it into Net8 packets for the BI-
#  Query desktop client. 
#
#  obj_srvr.pm makes use of various Student Information System (SIS) perl
#  modules located on the wouprd server (currently Spruce).
#
#  obj_srvr source is generated from obj_srvr.l and obj_srvr.y using lex and
#  yacc, then compiled and linked with exec_sql.o to produce the obj_srvr
#  executable (see Makefile).
#
#  obj_srvr and Obj_Srvr.pm will be installed on the same server as the
#  wouprd database (currently Spruce).
#
#  Jeremy Hickerson, 5/8/2002
#
# ===========================================================================

use strict;

BEGIN {
    use Exporter   ();
    use vars       qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);

    # set the version for version checking
    $VERSION     = 1.00;
    @ISA         = qw(Exporter);
    @EXPORT      = qw(&obj_srvr_connect &get_data &get_yyin &send_yyout
                      &connect2client &like2re &tr_op);
    %EXPORT_TAGS = ( );     # eg: TAG => [ qw!name1 name2! ],
    our @EXPORT_OK   = qw($FH_OUT);

    if ($^O eq "VMS")  {
    # jhjh ( grep /gen\$com/i, @INC ) || unshift @INC, "gen\$com";
    ( grep /woup:\[wou_sis_mods.com\]/i, @INC ) || unshift @INC, "woup:[wou_sis_mods.com]";  # jhjh
    }
    # default to Unix
    else {
        ( grep /\/usr\/local\/bin/, @INC ) || unshift @INC, "/\/usr\/local\/bin";
    }

    $DBI::drh->{debug} = 1;

}

our @EXPORT_OK;

use subs qw(obj_srvr_connect get_data get_yyin send_yyout connect2client like2re
    tr_op);

use DBI;
use WOU_Admit;
use WOU_Person;
use WOU_Student;
use WOU_AR;
use WOU_SIS_Util;
use WOU_Util;
use Socket;
use Safe;


# ============================================================================
#                             Package-Level Stuff
# ============================================================================

my $DBH;  # needs to be package level (this package's sub's assume this)
our $FH_OUT;  # let obj_srvr.pl see this
my $FH_IN;

my (%table_objs, %obj_accessor, %methods);  # these are populated in 
                                                 # obj_srvr.tables

# jhjh !! make sure obj_srvr.tables is readonly; it contains perl code to be eval'ed

if ($^O eq "VMS")  {
    eval `type obj_srvr.tables`;  # table layout file
}
# default to Unix
else {
    eval `cat obj_srvr.tables`;
}

my $compartment = new Safe;

$compartment->permit(qw( entereval ));  # need for stuff like date_compare()

#$compartment->permit_only(qw());  # nothing!  jhjh - need to see what to put
                                   # in here to allow what we need but nothing
                                   # else.  Even without this it seems to stop
                                   # things like system().

$compartment->share_from('WOU_Util', [ 'date_compare' ] );


# ============================================================================
#                                     routines
#                         (will be embedded in a C Program)
# ============================================================================

sub obj_srvr_connect {
    my ($uid, $passwd) = @_;

    print STDERR "before DBI->connect...\n";  # jhjh
    $DBH = DBI->connect('dbi:Oracle:', qq{$uid/$passwd\@(DESCRIPTION=
    (ADDRESS_LIST = 
    (ADDRESS = 
      (COMMUNITY = tcp.cedar.osshe.edu)
      (PROTOCOL = TCP)
      (HOST = 140.211.10.26)
      (PORT = 1541)
    )
    )
    (CONNECT_DATA = 
      (SID = wouprd)
      (SRVR = DEDICATED)
    ) ) }, "", {debug => 1} )
      or die "$!:  Can't connect to DB";

    print STDERR "after DBI->connect...\n";  # jhjh

    # help performance of select with join on remote spriden table
    $DBH->do("alter session set optimizer_goal = ALL_ROWS");

    # defaults - will be redirected if connected to oracle_obj_srvr
    $FH_IN  = \*STDIN;
    $FH_OUT = \*STDOUT;

}

sub connect2client {
    my ($remote, $port) = @_;

print STDERR "host = $remote, port = $port\n";  # jhjh

    my ($iaddr, $paddr, $proto, $line, $pid, $cnt);

    $| = 1;

    if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') }
    die "No port" unless $port;

    $iaddr   = inet_aton($remote)               || die "no host: $remote";
    $paddr   = sockaddr_in($port, $iaddr);

    $proto   = getprotobyname('tcp');
    socket(SOCK, PF_INET, SOCK_STREAM, $proto)  || die "socket: $!";

    $cnt = 0;
    CONNECT_LOOP:
    while ($cnt++ < 10 ) {
        sleep(2);

        if (connect(SOCK, $paddr) ) {
            print STDERR "Connected\n";
            last CONNECT_LOOP;
        }
        else { print STDERR "$!:  problem with connect\n" }  # jhjh

        ( die "can't connect to lsnr") if $cnt == 10;
    }

    select(SOCK);    $| = 1;   # make unbuffered
    select(STDERR);  $| = 1;   # make unbuffered

    $FH_IN  = \*SOCK;
    $FH_OUT = \*SOCK;

    select($FH_OUT); $| = 1;   # make unbuffered
    select(STDOUT);

    return 1;

}

sub get_yyin {

    my $size = shift;

    my $yychars;

    sysread($FH_IN, $yychars, $size); 
print STDERR "read $yychars\n";  # jhjh

    return $yychars;
}

sub send_yyout {

    my $str = shift;

    print $FH_OUT $str;

    return 1;
}

sub get_data {

    my ($cols, $tab, $where, $order) = @_;

    $cols  = lc($cols);  
    $tab   = lc($tab);  
    $order = lc($order);  
    # handle "where" separately; it may have upper-case scalars that we
    # need to preserve

    # oracle_obj_srvr may have broken query up into 254 byte chunks separated by \n
    $cols =~ s/\n//g;
    $tab =~ s/\n//g;
    $where =~ s/\n//g;
    $order =~ s/\n//g;


    my ($rh_driver_objs, $ra_results, $ra_support_results, $rh_result, $rh_data,
        $rh_join_obj, $ra_join_objs, $col, $table, $subname, @field_order, $rh_stu,
        $rh_support_objs, $parm, $ref_key, @subst_parms, @save_parms,
        %filtered_results, $cnt, @save_where, $word, $subst_where, $col_info,
        @converted_order, $special_sort, %special_sort);

    if (!defined($cols) )  { $cols = "" }
    if (!defined($tab) )   { $tab = "" }
    if (!defined($where) ) { $where = "" }
    if (!defined($order) ) { $order = "" }

    my %query = ( "columns"    => [ ],
                  "table"      => [ ],
                  "where"      => [ ],
                  "order"      => [ ] );

    $special_sort = 0;
print STDERR "cols = $cols\n";  # jhjh
print STDERR "tab = $tab\n";  # jhjh
print STDERR "where = $where\n";  # jhjh

    @{$query{"columns"} } = split(/,/, $cols);
    ($query{"table"} )    = split(/,/, $tab);

    $where =~ s/([^\\]),/$1\|/g;  # save escaped comma's
    @{$query{"where"} }   = split(/\|/, $where);  
    @{$query{"order"} }   = split(/,/, $order);

    # convert numeric col refs to names
    if ( defined($query{order}->[0] ) ) {
        if ( $query{order}->[0] =~ /^\d+$/ ) {
            print STDERR "converting numeric col refs\n";  # jhjh 
            while ( $col = shift  @{ $query{order} } ) {
                push @converted_order, $query{columns}->[$col - 1];
                print STDERR "$col:  ", $query{columns}->[$col - 1], "\n";  # jhjh 
            }
            push @{ $query{order} }, @converted_order;
        }

        # see if special sorts are needed
        foreach $col ( @{ $query{order} } ) {

            if (exists($obj_accessor{ $query{table} }->{$col}->{datatype}) ) {
                if ($obj_accessor{ $query{table} }->{$col}->{datatype}
                    eq "numeric" ) {

                    $special_sort = 1;
                    $special_sort{$col} = \&num_sort;  # defined in WOU_Util.pm
                }
                if ($obj_accessor{ $query{table} }->{$col}->{datatype}
                    eq "date" ) {

                    $special_sort = 1;
                    $special_sort{$col} = \&date_sort;  # defined in WOU_Util.pm
                }
            }

            # can add check for descending sort, etc. below if needed
        }
    }

print STDERR "order = $order :", @{ $query{order} }, "\n";  # jhjh

    $rh_driver_objs = get_driver_objs(\%query);  # rh_driver_objs now has
                                                 # one or more sub refs as
                                                 # hash keys and a hash ref
                                                 # holding the sub ref in key
                                                 # "sub" and an array ref of
                                                 # args for the sub in key
                                                 # "parms"
    $rh_support_objs = get_support_objs(\%query);

    # add any field_maps for all columns returned by supporting subs, even
    # if columns are not in "select" statement (they might be in "where" clause)
    add_field_maps($rh_support_objs, $query{table} );

    # run the driver sub  (Only allow 1 driver table)
    push @{$ra_results}, @{ &{ $rh_driver_objs->{"subref"} }(
                               @{ $rh_driver_objs->{"parms"} })
                          };

    # run the supporting subs
    foreach $rh_stu ( @{$ra_results} ) {

        foreach $subname (keys %{$rh_support_objs} ) {

            while ( shift @subst_parms ) { }  # empty each time

            # substitute driver table column values for referential parms
            while ( $parm = shift @{ $rh_support_objs->{$subname}->{"parms"} } ) {

                push @save_parms, $parm;

                if ($parm =~ /^\$/ ) {

                    $ref_key = $parm;
                    $ref_key =~ s/^\$//;

                    if (exists($rh_stu->{ $ref_key } ) ) {
                        push @subst_parms, $rh_stu->{$ref_key};
                    }
                    else {  # error (can't find as driver field):  leave "$pidm"
                            # or whatever as parm
                        push @subst_parms, $parm;
                    }
                }
                else {
                    push @subst_parms, $parm;
                }
            }

            # restore parms, including "$" parms
            while ( $parm = shift @save_parms ) {

                push  @{ $rh_support_objs->{$subname}->{"parms"} }, $parm;

            }

            add2hash($rh_stu,
                     \%{ &{ $rh_support_objs->{$subname}->{"subref"} }(
                            @subst_parms) },
                     $rh_support_objs->{$subname}->{"field_map"} );
        }

    }


    # Explanation: 
    # 1.  Will translate where-clause into perl expression, then use reval
    #     to check for TRUE after all column values have been plugged in. 
    #     This will involve implementing all SQL predicate operators
    #     (comparison, between, like, in, etc.) in (or for) obj_srvr.pl.
    #     Some of these need no translation (most of the comparison operators
    #     mean the same thing in perl, for instance.)

    # 3 passes through entire population so far...
    $cnt = 0;
    # we have substituted some words in $query{where} while we were getting params;
    # copy @{ $query{where} } onto $where putting spaces between words
    $where = ""; push @save_where, @{ $query{where} };
    while ( defined($word = shift @{ $query{where} } ) ) { $where .= $word . " " }
    $where =~ s/\s*$//;
    push @{ $query{where} }, @save_where;

    $where =~ s/([^\\])'/$1"/g;  # allow escaped single quotes to stay
    $where =~ s/\\//g;       # remove escape char's, now that we're done w/ them
    $where =~ s/^/ /;  # put space at beginning, makes substitution below
                       # work for first word
print STDERR "WHERE = ", $where, "\n";  # jhjh
    while ( $rh_stu = shift @{$ra_results} ) {

        $subst_where = $where;  # reset

        # substitute column vals into where expression in order to evaluate
        # (only subst if word is delimited by spaces or reg. exp. slashes)
        foreach $col (keys %{$rh_stu} ) {
            $col = lc($col);  # all hash column names are lower case, so
                              # need this to make sure substitution references
                              # the actual column name and not the capitalized
                              # hash column name.  Still need to do case-insensitive
                              # substitution below because the query column name
                              # may be upper case.

            # turn nulls into null strings
            if (!defined($rh_stu->{$col} ) ) { 
                if (exists($obj_accessor{ $query{table} }->{$col}->{datatype}) and
                    $obj_accessor{ $query{table} }->{$col}->{datatype}
                    eq "numeric" ) {
                    $rh_stu->{$col} = 0;
                }
                else { $rh_stu->{$col} = "" }
            }
            $subst_where =~ s/ $col / "$rh_stu->{$col}" /ig;  # /i handles upper-
                                                              # case query col names
            $subst_where =~ s/\/\^$col\$\//\/\^$rh_stu->{$col}\$\//ig;
        }

        if (where_clause_true($subst_where) ) {
            $filtered_results{++$cnt} = $rh_stu;
        }

    }

    # jhjh push @field_order, @{$query{columns} };

    if ($order) {
        if ($special_sort) {
            $ra_results = compound_sort(\%filtered_results, $query{"order"},
                \%special_sort );
        }
        else {
            $ra_results = compound_sort(\%filtered_results, $query{"order"} );
        }
    }
    else { push @{ $ra_results }, values %filtered_results }


    foreach $col ( @{ $query{columns} } ) {
        $col_info .= 
            $col . ":" . $obj_accessor{ $query{table} }->{$col}->{size} . "|";
    }
    $col_info =~ s/\|$//;

    print $FH_OUT "$col_info\n";

    output_delimited($FH_OUT, $ra_results, $query{columns},  "", "");

    print $FH_OUT "\n$cnt rows returned\n";

    return 1;

}


sub get_driver_objs {

    my $rh_query = shift;
    my %driver_objs =
        ( "subname" => $table_objs{ $rh_query->{table} }->{subname},
          "subref"  => $table_objs{ $rh_query->{table} }->{subref},
          "parms"   => get_parms(0, $table_objs{ $rh_query->{table} }->{subname},
                           $rh_query) );

    return \%driver_objs;
}


sub get_support_objs {

    my $rh_query = shift;

    my ($subname, %support_objs, $col);


    foreach $col (@{$rh_query->{columns} } ) {

        # next if column is a driver sub column
        next if $obj_accessor{$rh_query->{table} }->{$col}->{subname} eq "SELF";

print STDERR "support_objs:  col = $col\n";  # jhjh
print STDERR "support_objs->subname = ", $obj_accessor{ $rh_query->{table} }->{$col}->{subname}, "\n";  # jhjh

        # these get populated the same way multiple times if several fields share
        # a subname
        # Data looks like this:
        # $support_objs{"get_addr_lo"}->{"subref"} = \&get_addr, for example

        $support_objs{ $obj_accessor{ $rh_query->{table} }->{
            $col}->{subname} }->{"subref"} =
                $obj_accessor{ $rh_query->{table} }->{$col}->{subref};

        $support_objs{ $obj_accessor{ $rh_query->{table} }->{
            $col}->{subname} }->{"parms"} =
                get_parms(1,
                          $obj_accessor{$rh_query->{table} }->{$col}->{subname},
                          $rh_query);

        # jhjh - don't need this, done elsewhere now
        # This adds a new field_map pair each time.
        # Data looks like this:
        # $support_objs{"get_addr_lo"}->{"field_map}->{"city"} = "city_lo",
        # for example, where "city is the fieldname returned by the subref and
        # "city_lo" is the fieldname to be used in the virtual table being created.
        # $support_objs{ 
        #         $obj_accessor{ $rh_query->{table} }->{$col}->{subname}
        #     }->{"field_map"}->{
        #         $obj_accessor{$rh_query->{table} }->{$col}->{field}
        #             } = $col;
            
    }

    # maybe there's a column in the "where" clause but not in the select column
    # list, and it's sub is not shared with any of the select list columns
    foreach $col (keys %{ $obj_accessor{ $rh_query->{table} } } ) {

        if ( grep /^$col$/i, @{ $rh_query->{where} } and
             $obj_accessor{ $rh_query->{table} }->{$col}->{subname} ne "SELF" ) {

            # Data looks like this:
            # $support_objs{"get_addr_lo"}->{"subref"} = \&get_addr, for example

            $support_objs{ $obj_accessor{ $rh_query->{table} }->{
                $col}->{subname} }->{"subref"} =
                    $obj_accessor{ $rh_query->{table} }->{$col}->{subref};

            $support_objs{ $obj_accessor{ $rh_query->{table} }->{
                $col}->{subname} }->{"parms"} =
                    get_parms(1,
                              $obj_accessor{$rh_query->{table} }->{$col}->{subname},
                              $rh_query);
        }

    }

    return \%support_objs;

}


sub get_parms {

    my ($rec_key, $subname, $rh_query) = @_;

    my ($parm, @parms);

    foreach $parm (@{$methods{$subname}->{parms}  } ) {
        push @parms, get_parm_val($rec_key, $parm, $rh_query);
    }

    return \@parms;
}


sub get_parm_val {

    my ($rec_key, $parm, $rh_query) = @_;

    my ($word, $got_word, @subst_where);

    if ($parm eq "dbh") { return $DBH }  # package var

    if ($rec_key == 0 ) {  # i.e. sub is the driver ("table"), so we require
                           # params to be scalar predicates in where-clause.

        # for drivers ("tables") we require single-valued, "=" params.
        # we will handle "!=", "in", "like" values at a higher level and
        # simply run the sub multiple times (maybe?).

        $got_word = 0;
        while ( $word = shift  @{$rh_query->{where} } ) {
            if ($got_word) { $got_word++ }


            if (lc($word) eq $parm) { # so any future parms must also be lc
                $got_word = 1;
                $word = "TRUE";  # replace driver parms with true statements;
                                 # reval of where clause doesn't need to
                                 # look at these again, and any "%" values
                                 # will wrongly fail the revel

                                 # jhjh ! May want to rethink TRUE = TRUE
                                 # idea:  need to handle conditions other than
                                 # "=" on driver parm columns (like "in", "!=").
                                 # Would be good to pass this to the eval like
                                 # everything else.  Have to think of another
                                 # way to get around parms that accept "=%".
            }

            if ($got_word == 3) { 

                push @subst_where, "TRUE";
                unshift @{ $rh_query->{where} }, @subst_where;
                $word =~ s/'//g;  # don't want single quotes as part of # the string

                return $word;

            }  # 2 is "="

            push @subst_where, $word;
        }
        # won't be reached unless parm not in where clause
        unshift @{ $rh_query->{where} }, @subst_where;
    }


    else {  # Params are referential:  they come from the driver object.
            # (We are representing a single table to the user, but pulling
            # the data from a driver object and whatever supporting
            # subroutines we need.)  If a supporting subroutine requires
            # a parameter that is not referential (like gpa_type for all_gpa),
            # we will create additional columns for the possible values.  I.e.,
            # column cgpa_o is gpa_type 'O' (overall), column cgpa_t is
            # gpa_type 'T' (transfer), etc.

            return $parm;  # substitute after getting driver records

            # jhjh - still need to handle scalar where-clause conditions for
            # support obj columns - i.e. a required param for a support object
            # cannot be figured out referentially.  Handle these with higher
            # level wrapper subs.

        # fall-through
        return;
    }

}


sub add_field_maps {

    my ($rh_support_objs, $table) = @_;

    my ($col, $subname);

    COL_LOOP:
    foreach $col (keys %{ $obj_accessor{$table} } ) {
        next COL_LOOP if $obj_accessor{$table}->{$col}->{"subname"} eq "SELF";

        # fall-through
        foreach $subname ( keys %{ $rh_support_objs } ) {

            # only put it in if we used it
            if ($obj_accessor{$table}->{$col}->{"subname"} eq $subname ) {

                if ( exists( $obj_accessor{$table}->{$col}->{"field"} )  ) {

                    # Data looks like this:
                    # $support_objs{"get_addr_lo"}->{"field_map}->{
                    #   "city"} = "city_lo", for example
                    $rh_support_objs->{$subname}->{"field_map"}->{
                        $obj_accessor{$table}->{$col}->{"field"} } = $col;

                }
            }
        }
    }
}


sub where_clause_true {

    my $where = shift;

    # note:  we are guaranteed white space between operands and operators
    #        because of how we processed the where clause earlier
    #        (may come in handy to know this)

    # need to think about how to skip these substitutions if character is inside
    # a string (maybe in parser translate these chars to something else if they're
    # in a string, then translate them back further below

    # Need to use safe eval, or build in some checking for system() and
    # backticks, etc. (i.e. "where lname = `<dangerous os command>` " for
    # where clause... ).  Safe->reval should do it.

# print STDERR "EVAL where = $where\n";  # jhjh

    # use reval to see if substituted where clause is true;
    $compartment->reval( qq{
        if ($where) { return 1 }

        # fall-through
        return 0;
    } );
}


sub like2re {

    my ($str, $word, $negative);
    $negative = 0;

    # stop on LIKE for LIKE/NOT LIKE
    while ( ($word = shift) !~ /^like$/i ) {
        if ($word =~ /^not$/i) {
            $negative = 1;
        }
        else { $str .= $word . "," }  # replace whitespace w/ comma's just like the
                                      # parser does
    }
    $str .= $word . ",";  # add LIKE to $str

    $word = shift;  # $word now holds the SQL LIKE expression


    # if LIKE expr contains SQL % wildcard, then turn into perl reg exp
    if ( $word =~ /'(.*%.*)'/i ) {

        $word = $1;
        $str =~ s/like,$/=~,/i;

        $negative && ( $str =~ s/=~/!~/ );

        $word =~ s/^([^%])/\^$1/;
        $word =~ s/([^%])$/$1\$/;
        $word =~ s/%/\.\*/g;
        $word = "/" . $word . "/";
        
    }

    # otherwise turn like into "="  ( we will turn "=" into "eq" in get_data(),
    # this sub is used by the yacc parser)
    else {
        $str =~ s/like,$/=,/i;
    }

    $str .= $word;

    return $str;

}


sub tr_op {
    my ($table, $lval, $op, $rval) = @_;
print STDERR "\$lval = $lval, \$op = $op, \$rval = $rval\n";  # jhjh
    if ( $op eq '<>') { $op = "!=" }

    # translate $op for strings
    if ( $lval =~ /^'.*'$/ or
         $rval =~ /^'.*'$/ ) {

        $op = $op eq '='  ? 'eq' :
              $op eq '!=' ? 'ne' :
              $op eq '<'  ? 'lt' :
              $op eq '<=' ? 'le' :
              $op eq '>'  ? 'gt' :
              $op eq '>=' ? 'ge' : $op;
    }
    else {
        $op = $op eq '=' ? '==' : $op;
    }

    # translate $op for dates
    if (exists($obj_accessor{lc($table) }->{lc($lval) }->{datatype}) and
                $obj_accessor{lc($table) }->{lc($lval) }->{datatype}
                eq "date" ) {

        $op = "date_compare_$op";
    }

    return $op;
}

return 1;