PC World 1998 October/PCWorld_1998-10_cd.bin/software/prehled/komix/DATA.Z/genproc.tcl

Text File | 1996-06-05 | 14KB | 487 lines

#---------------------------------------------------------------------------
#
# Copyright (c) 1992-1995 by Cadre Technologies Inc.
#
# This software is furnished under a license and may be used only in
# accordance with the terms of such license and with the inclusion of
# the above copyright notice. This software or any other copies thereof
# may not be provided or otherwise made available to any other person.
# No title to and ownership of the software is hereby transferred.
#
# The information in this software is subject to change without notice
# and should not be construed as a commitment by Cadre Technologies Inc.
#
#---------------------------------------------------------------------------
#
#    File        : @(#)genproc.tcl    2.1
#    Original date    : July 1992
#    Description    : Implementation / configuration of Informix R.I.
#                         rules. These are used in the database procedures.
#
#---------------------------------------------------------------------------
#
# @(#)genproc.tcl    2.1 19 Apr 1996 Copyright 1992-1995 Cadre Technologies Inc.
#
#---------------------------------------------------------------------------

#---------------------------------------------------------------------------
# Configuartion arrays. Each array is indexed with "operation,rule" where
# operation is one of (ins, del, up) and rule is the rule as returned
# by get_*_rule

#---------------------------------------------------------------------------
# R.I. rules to check before the operation is performed. These are the checks
# that are not enforced by the Informix R.I. mechanism. The following arrays
# are defined:
#    imp_ri_rules_before    rules to be checked for each import
#    exp_ri_rules_before    rules to be checked for each export

#---------------------------------------------------------------------------
# import rules
global imp_ri_rules_before
set imp_ri_rules_before(del,rej_exist)        rej_exist_del
set imp_ri_rules_before(upd,rej_exist)        rej_exist_upd
#set imp_ri_rules_before(del,del_in_master)    del_in_master
set imp_ri_rules_before(del,rej_last)        rej_last
set imp_ri_rules_before(del,rej_last_in_master)    rej_exist_del

#---------------------------------------------------------------------------
# export rules
# (none)

#---------------------------------------------------------------------------
# R.I. rules to check and possibly repair the R.I. after an Informix R.I.
# violation has been detected. The following arrays are defined:
#
#    imp_ri_rules_after    rules to be checked for each import
#    exp_ri_rules_after    rules to be checked for each export


#---------------------------------------------------------------------------
# import rules
global imp_ri_rules_after
set imp_ri_rules_after(ins,ins_in_master)    ins_in_master
set imp_ri_rules_after(upd,ins_in_master)    ins_in_master

#---------------------------------------------------------------------------
# export rules
global exp_ri_rules_after
set exp_ri_rules_after(del,del_in_detail)    del_in_detail
set exp_ri_rules_after(del,nullify_detail)    nullify_detail

#---------------------------------------------------------------------------
# Rules that are not implemented
#
global exp_not_implemented
set exp_not_implemented(ins,rej_not_exist)    1
set exp_not_implemented(upd,rej_not_exist)    1
global imp_not_implemented


#---------------------------------------------------------------------------
#
#                 PROCEDURES THAT IMPLEMENT THE R.I. RULES
#
#---------------------------------------------------------------------------

# Determine if the complete tuple is needed for a delete (only the key is
# specified).
#
proc tuple_needed_for_del {table} {

    if { ![lempty [get_col_list $table NONKEYS]] } {
    #
    # Check all the (import) rules.
    # Export rules never need the complete tuple
    #

    foreach link [$table importSet] {
        case [$link getDelType] in {
        {rej_exist rej_last rej_last_in_master del_in_master} {
            return 1
        }
        }
    }
    }
    # no reasons found for a complete tuple
    return 0
}


# Generate code to get the complete tuple for a delete, if that is
# necessary
#
proc gen_get_tuple_for_del {section table} {
    if {![tuple_needed_for_del $table]} {
    return
    }
    expand_text $section {
    ~[gen_simple_data_decl_4gl $section $table NONKEYS "DEFINE p_" "" ";\n"]
    SELECT ~[gen_col_list $section $table NONKEYS]
    INTO ~[gen_col_list $section $table NONKEYS "p_"]
    FROM ~[$table getUniqueName]
    WHERE ~[gen_compare $section $table KEYS "" "" "p_" "" " AND\n"];
    }
}


# Reject operation if imported key exists in master
# This is the case if the imported key is not NULL, the existance of
# the foreign key is guaranteed by Informix.
# This procedure does the real work for both rej_exist_del and rej_exist_upd
#
proc rej_exist_master {section link prefix} {
    expand_text $section {
    IF ~[gen_col_listc $current_section [$link columnSet] $prefix \
         " IS NOT NULL" " AND\n"] THEN
        RAISE EXCEPTION 111, 0, "Referential integrity violated";
    END IF;
    }
}

# Reject delete operation if imported key exists in master
#
proc rej_exist_del {section link} {
    rej_exist_master $section $link p_
}

# Reject update operation if imported key exists in master
#
proc rej_exist_upd {section link} {
    rej_exist_master $section $link o_
}

# Determine if del_in_detail can be performed by a query. This is only the
# case if all the RI rules are enforced by Informix. Otherwise the del_in_detail
# must be performed by calling the appropriate stored procedure
#
proc query_for_del_detail {link} {
    set detail [$link detail]
    foreach link [$detail importSet] {
    if {[$link getDelType] != "none"} {
        return 0
    }
    }
    foreach link [$detail exportSet] {
    set rule [$link getDelType]
    if {$rule != "none" && $rule != "rej_exist"} {
        return 0
    }
    }
    return 1
}


# Delete in detail by calling the appropriate stored procedure
#
proc del_by_proc {section link} {
    set columns [$link columnSet]
    set detail [$link detail]
    expand_text $section {
    BEGIN
        ~[gen_simple_data_decl_4gl $section $detail KEYS "DEFINE l_" ";\n"];
        FOREACH SELECT ~[gen_col_list $section $detail KEYS]
            INTO   ~[gen_col_list $section $detail KEYS "l_"]
            FROM   ~[$detail getUniqueName]
            WHERE  ~[gen_compare_cl $section $link "" "" "p_" "" \
                " AND\n"]
        CALL pdel_~[$detail getUniqueName](~[
                gen_col_list $section $detail KEYS "l_"]);
        END FOREACH
    END
    }
}


# delete tuples with the exported key from the detail table
#
proc del_in_detail {section link} {
    if [query_for_del_detail $link] {
    expand_text $section {
        DELETE
        FROM ~[[$link detail] getUniqueName]
        WHERE ~[gen_compare_cl $section $link "" "" "p_" "" \
           " AND\n"];
    }
    } else {
    del_by_proc $section $link
    }
}


# delete tuples with the imported key from the master table
#
proc del_in_master {section link} {
    expand_text $section {
    DELETE
    FROM ~[[$link master] getUniqueName]
    WHERE ~[gen_compare_cl $section $link "p_" "" "" "" \
           " AND\n"];
    }
}


# Reject delete on last imported key in current table
#
proc rej_last {section link} {
    expand_text $section {
        BEGIN
            DEFINE counter INT;

            SELECT COUNT(*)
            INTO counter
            FROM ~[[$link detail] getUniqueName]
            WHERE ~[gen_compare_cl $section $link "" "" "p_" "" " AND\n"];
            IF counter = 1 THEN
            RAISE EXCEPTION 111, 0, "Referential integrity violated";
            END IF;
        END
    }
}


# Update the value of a column that is "serial"
#
proc update_serial {section link} {
    foreach col [$link columnSet] {
    if [is_serial [get_type_4gl $col]] {
        set name [$col getUniqueName]
        expand_text $section {
        IF p_~$name == 0 THEN
            SELECT MAX(~$name)
            INTO p_~$name
            FROM ~[[$link master] getUniqueName];
        END IF;
        }
        return;
    }
    }
}

#
#    Generate parameters for a CALL in an EXCEPTION block
#

proc gen_par_list {link} {

    set parlist ""
    set implist [gen_sorted_columns $link]

    foreach imp $implist {
    if {$parlist == ""} {
        set parlist "p_[$imp getUniqueName]"
    } else {
        set parlist "$parlist, p_[$imp getUniqueName]"
    }
    }

    set mastertable [$link master]
    set mastercolumns [get_col_list $mastertable "NONKEYS"]

    foreach master $mastercolumns {
    set parlist "$parlist, NULL"
    }

    return $parlist
}

#
# Insert imported key in master table
#

proc ins_in_master {section link} {

    expand_text $section {
        BEGIN
            DEFINE counter INT;

            SELECT COUNT(*)
            INTO counter
            FROM ~[[$link master] getUniqueName]
            WHERE ~[gen_compare_cl $section $link "p_" "" "" "" " AND\n"];
            IF counter = 0 THEN
                CALL pins_~[[$link master] getUniqueName](~[gen_par_list $link]);
            END IF;
        END
    }

    update_serial $section $link
}

#
# Update exported key in detail table
#

proc upd_in_detail {section link} {
    $section pushIndent
    set columns [$link columnSet]
    expand_text $section {
    UPDATE ~[[$link detail] getUniqueName]
    SET ~[gen_comparec $section $columns "" "" "p_" "" ",\n"]
    WHERE ~[gen_comparec $section $columns "" "" "p_" "" " AND\n"];
    }
    $section popIndent
}


# Nullify exported key in detail table
#
proc nullify_detail {section link} {
    set columns [$link columnSet]
    expand_text $section {
    UPDATE ~[[$link detail] getUniqueName]
    SET ~[gen_col_listl $section [$link friendLink] "" " = NULL"]
    WHERE ~[gen_compare_cl $section $link "" "" "p_" "" " AND\n"];
    }
}

# Check which procedures cannot be implemented.
# Put those procedures in the array 'not_possible', indexed by operation
# and table-handle.
#
proc check_not_implemented {model np} {
    upvar $np not_possible
    set operations {ins del upd}
    foreach table [$model tableSet] {
    foreach link [$table importSet] {
        foreach oper $operations {
        if [get imp_not_implemented($oper,[get_${oper}_type $link]) 0] {
            set not_possible($oper,$table) 1
            m4_warning $W_NOT_IMPLEMENTED p${oper}_[$table getUniqueName]
        }
        }
    }
    foreach link [$table exportSet] {
        foreach oper $operations {
        if [get exp_not_implemented($oper,[get_${oper}_type $link]) 0] {
            set not_possible($oper,$table) 1
            m4_warning $W_NOT_IMPLEMENTED p${oper}_[$table getUniqueName]
        }
        }
    }
    }
}

# this procedure does the real work for gen_rules_{before,after}
#
proc gen_ri_rules {section table when oper} {
    foreach link [$table importSet] {
    set procrule [get imp_ri_rules_${when}($oper,[get_${oper}_type $link])]
    if {$procrule != ""} {
        $procrule $section $link
    }
    }
    foreach link [$table exportSet] {
    set procrule [get exp_ri_rules_${when}($oper,[get_${oper}_type $link])]
    if {$procrule != ""} {
        $procrule $section $link
    }
    }
}

# Generate R.I. rules to check before the operation is executed
#
proc gen_rules_before {section table oper} {
    gen_ri_rules $section $table before $oper
}

# Generate R.I. rules to check after the operation has executed and has failed
#
proc gen_rules_after {section table oper query} {
    set tmp [TextSection new]
    gen_ri_rules $tmp $table after $oper
    if {[$tmp lineNr] > 1} {
    # something is generated: create an ON EXCEPTION block
    $section pushIndent
    expand_text $section {
        ON EXCEPTION
            ~[$section pushIndent
            $section appendSect $tmp
            expand_text $section $query currtab $table
            $section popIndent]
        END EXCEPTION;
    }
    $section popIndent
    }
}


# Generate procedure body
#
proc gen_inf_proc_body {section table oper query} {
    $section pushIndent
    case $oper in {
    {del} {
    gen_get_tuple_for_del $section $table
    }
    {upd} {
    gen_get_tuple_for_upd $section $table
    }}

#
#    ON EXCEPTION must be first statement in block,
#    so we just create another block ...
#

    expand_text $section {
    BEGIN
        ~[$section pushIndent
        gen_rules_after $section $table $oper $query
        gen_rules_before $section $table $oper
        expand_text $section $query currtab $table
        $section popIndent]
    END
    }
#
#   Special case: del_in_master must be generated AFTER the query, but NOT
#   in the exception block
#
    if {$oper == "del"} {
    gen_del_in_master $section $table
    }
    $section popIndent
}


# Generate code for "del_in_master", if needed.
#
proc gen_del_in_master {section table} {
    foreach link [$table importSet] {
    if {[$link getDelType] == "del_in_master"} {
        expand_text $section {
        CALL pdel_~[[$link master] getUniqueName](~[
            gen_col_listc $section [$link columnSet] p_]);
        }
    }
    }
}


# Generate code to get the complete "old" tuple that is updated, if needed.
#
proc gen_get_tuple_for_upd {section table} {
    if {![tuple_needed_for_upd $table]} {
    return
    }
    expand_text $section {
        ~[gen_simple_data_decl_4gl $section $table ALL "DEFINE o_" "" ";\n"]
        SELECT *
        INTO ~[gen_col_list $section $table ALL "o_"]
        FROM ~[$table getUniqueName]
        WHERE ~[gen_compare $section $table KEYS "" "" "p_" "" " AND\n"];
    }
}

# Is old tuple needed for an update?
# This is only the case when the old values are needed to check the R.I, i.e.
# if an import rule "rej_exist" exists.
#
proc tuple_needed_for_upd {table} {
    foreach link [$table importSet] {
        if {[$link getUpdType] == "rej_exist"} {
        return 1
    }
    }
    return 0
}